├── .devcontainer ├── Dockerfile └── devcontainer.json ├── .envrc ├── .format.ignore ├── .github ├── dependabot.yml └── workflows │ └── ci.yaml ├── .gitignore ├── .vscode ├── .gitignore └── tasks.json ├── Checklist ├── LICENSE ├── Readme.md ├── Setup.hs ├── aclocal.m4 ├── benchmark └── Main.hs ├── bin ├── build-all ├── build-js ├── build-mhs ├── build-native ├── build-native-expired ├── build-wasm32 └── format ├── cabal.project ├── changelog.md ├── configure.ac ├── fourmolu.yaml ├── fullcheck.ps1 ├── justfile ├── lib ├── Data │ ├── Format.hs │ ├── Time.hs │ └── Time │ │ ├── Calendar.hs │ │ ├── Calendar │ │ ├── CalendarDiffDays.hs │ │ ├── Days.hs │ │ ├── Easter.hs │ │ ├── Gregorian.hs │ │ ├── Julian.hs │ │ ├── JulianYearDay.hs │ │ ├── Month.hs │ │ ├── MonthDay.hs │ │ ├── OrdinalDate.hs │ │ ├── Private.hs │ │ ├── Quarter.hs │ │ ├── Types.hs │ │ ├── Week.hs │ │ └── WeekDate.hs │ │ ├── Clock.hs │ │ ├── Clock │ │ ├── Internal │ │ │ ├── AbsoluteTime.hs │ │ │ ├── CTimespec.hsc │ │ │ ├── CTimeval.hs │ │ │ ├── DiffTime.hs │ │ │ ├── NominalDiffTime.hs │ │ │ ├── POSIXTime.hs │ │ │ ├── SystemTime.hs │ │ │ ├── UTCDiff.hs │ │ │ ├── UTCTime.hs │ │ │ └── UniversalTime.hs │ │ ├── POSIX.hs │ │ ├── System.hs │ │ └── TAI.hs │ │ ├── Format.hs │ │ ├── Format │ │ ├── Format │ │ │ ├── Class.hs │ │ │ └── Instances.hs │ │ ├── ISO8601.hs │ │ ├── Internal.hs │ │ ├── Locale.hs │ │ ├── Parse.hs │ │ └── Parse │ │ │ ├── Class.hs │ │ │ └── Instances.hs │ │ ├── LocalTime.hs │ │ └── LocalTime │ │ └── Internal │ │ ├── CalendarDiffTime.hs │ │ ├── Foreign.hs │ │ ├── LocalTime.hs │ │ ├── TimeOfDay.hs │ │ ├── TimeZone.hs │ │ └── ZonedTime.hs ├── cbits │ └── HsTime.c └── include │ └── HsTime.h ├── stack.yaml ├── stack.yaml.lock ├── test ├── CurrentTime.hs ├── ForeignCalls.hs ├── RealToFracBenchmark.hs ├── ShowDST.hs ├── ShowDefaultTZAbbreviations.hs ├── ShowTime.hs ├── TimeZone.hs ├── UseCases.lhs ├── main │ ├── Main.hs │ └── Test │ │ ├── Arbitrary.hs │ │ ├── Calendar │ │ ├── AddDays.hs │ │ ├── AddDaysRef.hs │ │ ├── CalendarProps.hs │ │ ├── Calendars.hs │ │ ├── CalendarsRef.hs │ │ ├── ClipDates.hs │ │ ├── ClipDatesRef.hs │ │ ├── ConvertBack.hs │ │ ├── DayPeriod.hs │ │ ├── Duration.hs │ │ ├── Easter.hs │ │ ├── EasterRef.hs │ │ ├── LongWeekYears.hs │ │ ├── LongWeekYearsRef.hs │ │ ├── MonthDay.hs │ │ ├── MonthDayRef.hs │ │ ├── MonthOfYear.hs │ │ ├── Valid.hs │ │ ├── Week.hs │ │ └── Year.hs │ │ ├── Clock │ │ ├── Conversion.hs │ │ ├── Lift.hs │ │ ├── Resolution.hs │ │ └── TAI.hs │ │ ├── Format │ │ ├── Compile.hs │ │ ├── Format.hs │ │ ├── ISO8601.hs │ │ └── ParseTime.hs │ │ ├── LocalTime │ │ ├── CalendarDiffTime.hs │ │ ├── Time.hs │ │ ├── TimeOfDay.hs │ │ └── TimeRef.hs │ │ ├── TestUtil.hs │ │ └── Types.hs └── unix │ ├── Main.hs │ └── Test │ ├── Format │ ├── Format.hs │ ├── FormatStuff.c │ └── FormatStuff.h │ ├── LocalTime │ └── TimeZone.hs │ └── TestUtil.hs └── time.cabal /.devcontainer/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM mcr.microsoft.com/devcontainers/base:bookworm 2 | 3 | # update Debian 4 | ENV DEBIAN_FRONTEND=noninteractive 5 | RUN apt-get update && apt-get -y dist-upgrade 6 | 7 | # user 8 | USER vscode 9 | WORKDIR /home/vscode 10 | ENV LC_ALL=en_US.utf-8 11 | 12 | # ghcup 13 | ARG BOOTSTRAP_HASKELL_NONINTERACTIVE=1 14 | ARG BOOTSTRAP_HASKELL_MINIMAL=1 15 | RUN curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh 16 | ENV PATH=/home/vscode/.ghcup/bin:$PATH 17 | 18 | # cabal 19 | RUN ghcup install cabal --set latest 20 | RUN cabal update 21 | ENV PATH=/home/vscode/.cabal/bin:$PATH 22 | 23 | # native back-end 24 | ENV GHC_NATIVE_VERSIONS="9.8.4 9.10.1 9.12.2" 25 | ENV GHC_NATIVE_EXPIRED_VERSIONS="9.4.8 9.6.7" 26 | WORKDIR /home/vscode 27 | RUN for V in $GHC_NATIVE_VERSIONS $GHC_NATIVE_EXPIRED_VERSIONS; do ghcup install ghc $V; done 28 | RUN sudo apt-get install -y libgmp-dev 29 | 30 | # formatter 31 | WORKDIR /home/vscode 32 | RUN ghcup set ghc 9.12.2 33 | RUN cabal install fourmolu-0.18.0.0 34 | 35 | # WebAssembly back-end 36 | ENV GHC_WASM32_VERSIONS="wasm32-wasi-9.8.4.20250206 wasm32-wasi-9.10.1.20250327 wasm32-wasi-9.12.2.20250327" 37 | WORKDIR /home/vscode 38 | RUN sudo apt-get install -y zstd 39 | RUN curl https://gitlab.haskell.org/haskell-wasm/ghc-wasm-meta/-/raw/master/bootstrap.sh | SKIP_GHC=1 sh 40 | RUN ghcup config add-release-channel https://gitlab.haskell.org/haskell-wasm/ghc-wasm-meta/-/raw/master/ghcup-wasm-0.0.9.yaml 41 | RUN . /home/vscode/.ghc-wasm/env && for V in $GHC_WASM32_VERSIONS; do ghcup install ghc $V -- $CONFIGURE_ARGS; done 42 | RUN curl -LO https://github.com/bytecodealliance/wasmtime/releases/download/dev/wasmtime-dev-x86_64-linux.tar.xz 43 | RUN xz -d wasmtime-dev-x86_64-linux.tar.xz 44 | RUN tar xvf wasmtime-dev-x86_64-linux.tar 45 | ENV PATH=/home/vscode/wasmtime-dev-x86_64-linux:$PATH 46 | 47 | # JavaScript back-end 48 | ENV GHC_JS_VERSIONS="javascript-unknown-ghcjs-9.10.0.20240413 javascript-unknown-ghcjs-9.12.1" 49 | WORKDIR /home/vscode 50 | RUN sudo apt-get install -y nodejs 51 | RUN ghcup config add-release-channel cross 52 | RUN git clone https://github.com/emscripten-core/emsdk.git 53 | WORKDIR /home/vscode/emsdk 54 | RUN sudo apt-get install -y python3 55 | RUN ./emsdk install 3.1.57 56 | RUN ./emsdk activate 3.1.57 57 | RUN . ./emsdk_env.sh && emconfigure ghcup install ghc javascript-unknown-ghcjs-9.10.0.20240413 58 | RUN ./emsdk install 3.1.74 59 | RUN ./emsdk activate 3.1.74 60 | RUN . ./emsdk_env.sh && emconfigure ghcup install ghc javascript-unknown-ghcjs-9.12.1 61 | 62 | # MicroHs back-end 63 | WORKDIR /home/vscode 64 | RUN git clone https://github.com/augustss/MicroHs.git --branch stable-7 mhs 65 | WORKDIR /home/vscode/mhs 66 | RUN make minstall 67 | ENV PATH=/home/vscode/.mcabal/bin:$PATH 68 | 69 | # build commands 70 | WORKDIR /home/vscode 71 | RUN sudo apt-get install -y autoconf 72 | ENV PATH=/workspaces/time/bin:$PATH 73 | ENV TZ="America/Los_Angeles" 74 | -------------------------------------------------------------------------------- /.devcontainer/devcontainer.json: -------------------------------------------------------------------------------- 1 | // For format details, see https://aka.ms/devcontainer.json. For config options, see the 2 | // README at: https://github.com/devcontainers/templates/tree/main/src/debian 3 | { 4 | "name": "Builder", 5 | "build": 6 | { 7 | "dockerfile": "Dockerfile" 8 | } 9 | } 10 | -------------------------------------------------------------------------------- /.envrc: -------------------------------------------------------------------------------- 1 | use nix -p devcontainer just act docker 2 | -------------------------------------------------------------------------------- /.format.ignore: -------------------------------------------------------------------------------- 1 | ./lib/Data/Time.hs 2 | ./lib/Data/Time/Format/Locale.hs 3 | -------------------------------------------------------------------------------- /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | updates: 3 | - package-ecosystem: "github-actions" 4 | directory: "/" 5 | schedule: 6 | interval: "daily" 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | GNUmakefile 2 | autom4te.cache/ 3 | conf* 4 | !configure.ac 5 | a.out 6 | configure 7 | dist/ 8 | dist-newstyle/ 9 | dist-install 10 | dist-mcabal 11 | *.pkg 12 | ghc.mk 13 | lib/include/HsTimeConfig.h 14 | lib/include/HsTimeConfig.h.in 15 | test-sdist 16 | .stack-work 17 | -------------------------------------------------------------------------------- /.vscode/.gitignore: -------------------------------------------------------------------------------- 1 | ipch 2 | -------------------------------------------------------------------------------- /.vscode/tasks.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": "2.0.0", 3 | "presentation": { 4 | "echo": true, 5 | "reveal": "always", 6 | "focus": false, 7 | "panel": "shared", 8 | "showReuseMessage": false, 9 | "clear": true 10 | }, 11 | "tasks": [ 12 | { 13 | "group": { 14 | "kind": "build", 15 | "isDefault": true 16 | }, 17 | "label": "Build", 18 | "type": "shell", 19 | "command": "cd ${workspaceRoot} && stack build && echo OK", 20 | "problemMatcher": [ 21 | { 22 | "owner": "stack", 23 | "fileLocation": "absolute", 24 | "pattern": [ 25 | { 26 | "regexp": "^(.*):(\\d+):(\\d+):\\s+(warning|error):", 27 | "file": 1, 28 | "line": 2, 29 | "column": 3, 30 | "severity": 4 31 | }, 32 | { 33 | "regexp": "^\\s+(.*)$", 34 | "message": 1 35 | } 36 | ] 37 | } 38 | ] 39 | } 40 | ] 41 | } 42 | -------------------------------------------------------------------------------- /Checklist: -------------------------------------------------------------------------------- 1 | Before release: 2 | 3 | 1. Check milestone is complete 4 | 5 | https://github.com/haskell/time/milestones 6 | 7 | 2. Pull upstream changes 8 | 9 | git switch master 10 | git pull 11 | 12 | 3. Update version numbers 13 | 14 | https://pvp.haskell.org/ 15 | time.cabal 16 | configure.ac 17 | 18 | 4. Update changelog, add current UTC date 19 | 20 | date -u 21 | changelog.md 22 | 23 | 5. Use latest LTS resolver 24 | 25 | https://www.stackage.org/lts 26 | stack.yaml 27 | 28 | 6. Use correct & latest GHC versions 29 | 30 | https://www.haskell.org/ghc/download.html 31 | fullcheck 32 | fullcheck.ps1 33 | time.cabal 34 | - tested-with 35 | - base dependency lower bound 36 | .github/workflows/ci.yml 37 | 38 | 7. Use latest stack 39 | 40 | stack upgrade 41 | stack --version 42 | 43 | 8. Format source 44 | 45 | just format 46 | 47 | 9. Build & test 48 | 49 | just fullbuild 50 | 51 | 10. Run benchmarks 52 | 53 | stack bench 54 | 55 | 11. Inspect generated haddock, if necessary 56 | 57 | dist/doc/html/time/index.html 58 | 59 | 12. Commit and push changes to repo 60 | 61 | git commit -a 62 | git push 63 | 64 | 13. Check builds (these can be done in parallel) 65 | 66 | 13a. Check GitHub build 67 | 68 | https://github.com/haskell/time/actions 69 | 70 | 13b. Build and test on 32-bit Linux machine 71 | 72 | git switch master 73 | just fullbuild 74 | 75 | 13c. Build and test on FreeBSD machine 76 | 77 | git switch master 78 | just fullbuild 79 | 80 | 13d. Build and test on Windows 81 | 82 | (in PowerShell) 83 | Set-ExecutionPolicy -Scope CurrentUser RemoteSigned 84 | git switch master 85 | .\fullcheck 86 | 87 | 14. Upload to Hackage 88 | 89 | git clean -dXf 90 | autoreconf -i 91 | stack upload . 92 | http://hackage.haskell.org/package/time 93 | 94 | 15. Tag commit 95 | 96 | git tag -a -s VERSION -m "Version VERSION" 97 | git push --tags 98 | 99 | 16. Update ghc branch 100 | 101 | git switch ghc 102 | git merge master 103 | git push 104 | 105 | 17. Restore local branch for next development 106 | 107 | git switch master 108 | 109 | 18. Close completed milestone 110 | 111 | https://github.com/haskell/time/milestones 112 | 113 | 19. Inform GHC team 114 | 115 | https://gitlab.haskell.org/ghc/ghc/-/issues 116 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | TimeLib is Copyright (c) Ashley Yakeley and contributors, 2004-2022. All rights reserved. 2 | Certain sections are Copyright 2004, The University Court of the University of Glasgow. All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | 8 | - Neither name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 9 | 10 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 11 | -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | # time 2 | 3 | This is the haskell time library that is bundled with [GHC][GHC] the Glasgow/ 4 | Glorious Haskell compiler. 5 | 6 | To build this package using Cabal directly from git, you must run 7 | "autoreconf" before the usual Cabal build steps (configure/build/install). 8 | autoreconf is included in the GNU autoconf tools. There is no need to run 9 | the "configure" script: the "setup configure" step will do this for you. 10 | 11 | [GHC]: https://www.haskell.org/ghc/ 12 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | module Main ( 2 | main, 3 | ) where 4 | 5 | import Distribution.Simple 6 | 7 | main :: IO () 8 | main = defaultMainWithHooks autoconfUserHooks 9 | -------------------------------------------------------------------------------- /aclocal.m4: -------------------------------------------------------------------------------- 1 | # FP_DECL_ALTZONE 2 | # --------------- 3 | # Defines HAVE_DECL_ALTZONE to 1 if declared, 0 otherwise. 4 | # 5 | # Used by base package. 6 | AC_DEFUN([FP_DECL_ALTZONE], 7 | [ 8 | AC_CHECK_HEADERS_ONCE([sys/time.h]) 9 | 10 | AC_CHECK_HEADERS([sys/time.h]) 11 | AC_CHECK_DECLS([altzone], [], [],[ 12 | #if HAVE_SYS_TIME_H 13 | #include 14 | #endif 15 | #include 16 | ]) 17 | ])# FP_DECL_ALTZONE 18 | -------------------------------------------------------------------------------- /benchmark/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Criterion.Main 4 | import Data.Time 5 | import Data.Time.Clock.POSIX 6 | import Data.Time.Clock.System 7 | 8 | main :: IO () 9 | main = do 10 | getCurrentTime >>= print 11 | getPOSIXTime >>= print . posixSecondsToUTCTime 12 | getZonedTime >>= print 13 | ct <- getCurrentTime 14 | defaultMain 15 | [ bench "getCurrentTime" $ nfIO getCurrentTime 16 | , bench "getPOSIXTime" $ nfIO getPOSIXTime 17 | , bench "getSystemTime" $ nfIO getSystemTime 18 | , bench "getTimeZone" $ nfIO $ getTimeZone ct 19 | , bench "getCurrentTimeZone" $ nfIO getCurrentTimeZone 20 | , bench "getZonedTime" $ nfIO getZonedTime 21 | ] 22 | -------------------------------------------------------------------------------- /bin/build-all: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env -S bash -e 2 | git clean -dXf 3 | cabal update 4 | 5 | for V in $GHC_NATIVE_VERSIONS 6 | do 7 | build-native $V 8 | done 9 | 10 | for V in $GHC_NATIVE_EXPIRED_VERSIONS 11 | do 12 | build-native-expired $V 13 | done 14 | 15 | for V in $GHC_WASM32_VERSIONS 16 | do 17 | build-wasm32 $V 18 | done 19 | 20 | for V in $GHC_JS_VERSIONS 21 | do 22 | build-js $V 23 | done 24 | 25 | build-mhs 26 | -------------------------------------------------------------------------------- /bin/build-js: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env -S bash -e 2 | ghcup set ghc $1 3 | autoreconf -i 4 | cabal \ 5 | --with-compiler=javascript-unknown-ghcjs-ghc \ 6 | --with-hc-pkg=javascript-unknown-ghcjs-ghc-pkg \ 7 | --with-hsc2hs=javascript-unknown-ghcjs-hsc2hs \ 8 | test \ 9 | --ghc-options='-Werror' 10 | -------------------------------------------------------------------------------- /bin/build-mhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env -S bash -e 2 | autoreconf -i 3 | mcabal install 4 | mkdir -p dist-mcabal/bin 5 | mhs test/ForeignCalls.hs -odist-mcabal/bin/ForeignCalls 6 | dist-mcabal/bin/ForeignCalls 7 | mhs test/ShowDefaultTZAbbreviations.hs -odist-mcabal/bin/ShowDefaultTZAbbreviations 8 | dist-mcabal/bin/ShowDefaultTZAbbreviations 9 | mhs test/ShowTime.hs -odist-mcabal/bin/ShowTime 10 | dist-mcabal/bin/ShowTime 11 | -------------------------------------------------------------------------------- /bin/build-native: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env -S bash -e 2 | ghcup set ghc $1 3 | autoreconf -i 4 | cabal test --ghc-options='-Werror' 5 | -------------------------------------------------------------------------------- /bin/build-native-expired: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env -S bash -e 2 | ghcup set ghc $1 3 | autoreconf -i 4 | if cabal v1-configure --enable-tests; 5 | then 6 | echo "time incorrectly selected with unsupported GHC version $1" 7 | exit 1 8 | else 9 | echo "time correctly deselected with unsupported GHC version $1" 10 | fi 11 | -------------------------------------------------------------------------------- /bin/build-wasm32: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env -S bash -e 2 | ghcup set ghc $1 3 | autoreconf -i 4 | source $HOME/.ghc-wasm/env 5 | cabal \ 6 | --with-compiler=wasm32-wasi-ghc \ 7 | --with-hc-pkg=wasm32-wasi-ghc-pkg \ 8 | --with-hsc2hs=wasm32-wasi-hsc2hs \ 9 | --test-wrapper=wasmtime \ 10 | test \ 11 | --ghc-options='-Werror' 12 | -------------------------------------------------------------------------------- /bin/format: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env -S bash -e 2 | fourmolu -i -o -XPatternSynonyms \ 3 | `find -name '*.hs' -not -path '*.stack-work/*' -not -path '*/dist/*' -not -path '*/dist-newstyle/*' | grep -xvf .format.ignore` 4 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: time.cabal 2 | tests: true 3 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | # Change Log 2 | 3 | ## [1.15] - Unreleased 4 | 5 | - support GHC backends (with CI): 6 | - JavaScript 7 | - WebAssembly 8 | - MicroHs 9 | - add instance ParseTime DayOfWeek 10 | - make use of %s specifiers in parsing various types 11 | - add Lift instances to all types (really this time) 12 | - hide Data.Time.Format.Internal 13 | 14 | ## [1.14] - 2024-03-10 15 | - add Lift instances to all types 16 | - add Generic instances to all types that have exposed constructors 17 | - fix show of CalendarDiffTime 18 | - fix diffGregorianDurationRollOver, diffJulianDurationRollOver 19 | - Parsing is now maximal munch rather than ambiguous for 20 | - digits of %q and %Q specifiers 21 | - optional timezone for UTCTime 22 | - optional specifiers in ISO8601 formats 23 | 24 | ## [1.12.2] - 2022-05-14 25 | - add weekFirstDay, weekLastDay, weekAllDays 26 | - expose formatting/parsing internals 27 | - fix: handle +HH format for ISO8601 timeOffsetFormat etc. 28 | - fix clock_REALTIME for WebAssembly 29 | 30 | ## [1.12.1] - 2021-10-24 31 | - add DayPeriod class for periods of days 32 | - add QuarterDay pattern and DayOfQuarter type synonym 33 | - add CommonEra and BeforeCommonEra patterns 34 | 35 | ## [1.12] - 2021-06-12 36 | - support GHC 8.8, 8.10, 9.0 only 37 | - add patterns for each month of year 38 | - fix: don't provide TAI clock where it's unavailable (e.g. FreeBSD) 39 | - fix: handle time of day 24:00:00 for ISO 8601 parsing (only) 40 | - fix parsing of %f and %G with negative years 41 | 42 | ## [1.11.1.2] - 2021-04-24 43 | - fix cabal file 44 | - correct "license" field in cabal file 45 | - add dates to changelog entries 46 | 47 | ## [1.11.1.1] - 2020-12-09 48 | - fix module Safe status 49 | 50 | ## [1.11.1] - 2020-11-23 51 | - all modules Safe or Trustworthy 52 | - fix NFData instances for DiffTime, NominalDiffTime, TimeOfDay 53 | - add missing Ix, Enum, NFData instances to DayOfWeek, CalendarDiffDays, CalendarDiffTime, Month, Quarter, QuarterOfYear 54 | 55 | ## [1.11] - 2020-10-14 56 | - new calendrical type synonyms and abstract constructors 57 | - new Month type, with appropriate functions 58 | - new QuarterOfYear and Quarter type, with appropriate functions 59 | - new functions for working with week-based years 60 | - new parseTimeMultipleM function for a list of (format, input) pairs 61 | - add instance Ord DayOfWeek 62 | - add instance Read DiffTime (and NominalDiffTime) 63 | - change instance Read UTCTime to allow omitted timezone 64 | - parsing dates rejects ambiguity based on digits, even if there's only one valid date 65 | 66 | ## [1.10] - 2020-03-13 67 | - remove deprecated functions parseTime, readTime, readsTime 68 | - deprecate iso8601DateFormat 69 | - parsing: fix %_Q %-Q %_q %-q 70 | - parsing: fix parsing of BCE years 71 | - formatting: fix %3ES %3Es 72 | - change internal members of ParseTime to allow newtype-deriving 73 | - new functions (aliases) pastMidnight & sinceMidnight 74 | 75 | ## [1.9.3] - 2019-05-20 76 | - documentation fixes 77 | 78 | ## [1.9.2] - 2018-08-01 79 | - add Data and Typeable instance for CalendarDiffDays and CalendarDiffTime 80 | - "@since" annotations for everything after 1.9 81 | - fix import issue with GHC 8.6 82 | 83 | ## [1.9.1] - 2018-02-27 84 | - new functions secondsToNominalDiffTime & nominalDiffTimeToSeconds 85 | - expose FormatTime and ParseTime in Data.Time.Format.Internal 86 | 87 | ## [1.9] - 2018-01-25 88 | - new conversion functions timeToDaysAndTimeOfDay & daysAndTimeOfDayToTime 89 | - new DayOfWeek type 90 | - new CalendarDiffDays and CalendarDiffTime types 91 | - new ISO8601 module for ISO 8601 formatting & parsing 92 | - new addLocalTime, diffLocalTime 93 | - hide members of FormatTime and ParseTime classes 94 | - formatting & parsing for diff types (NominalDiffTime, DiffTime, CalendarDiffDays, CalendarDiffTime) 95 | - formatting: %Ez and %EZ for ±HH:MM format 96 | - parseTimeM: use MonadFail constraint when supported 97 | - parsing: reject invalid (and empty) time-zones with %z and %Z 98 | - parsing: reject invalid hour/minute/second specifiers 99 | 100 | ## [1.8.0.4] - 2018-01-09 101 | - Fix "show minBound" bug 102 | - haddock: example for parseTimeM 103 | 104 | ## [1.8.0.3] - 2017-08-04 105 | - Add "Quick start" documentation 106 | 107 | ## [1.8.0.2] - 2017-05-13 108 | - Fix behaviour of %Q in format 109 | 110 | ## [1.8.0.1] - 2017-03-11 111 | - Get building on 32 bit machine 112 | 113 | ## [1.8] - 2017-02-14 114 | - Added SystemTime 115 | - Data.Time.Format: allow padding widths in specifiers for formatting (but not parsing) 116 | - Test: use tasty, general clean-up 117 | - Test: separate out UNIX-specific tests, so the others can be run on Windows 118 | - Clean up haddock. 119 | 120 | ## [1.7.0.1] - 2016-12-19 121 | - Fix bounds issue in .cabal file 122 | 123 | ## [1.7] - 2016-11-19 124 | - Data.Time.Clock.TAI: change LeapSecondTable to LeapSecondMap with Maybe type; remove parseTAIUTCDATFile 125 | 126 | ## [1.6.0.1] - 2016-05-07 127 | - Get building with earlier GHC versions 128 | - Set lower bound of base correctly 129 | 130 | ## [1.6] - 2015-12-20 131 | 132 | ### Added 133 | - FormatTime, ParseTime, Show and Read instances for UniversalTime 134 | - diffTimeToPicoseconds 135 | - this change log 136 | 137 | ### Changed 138 | - Use clock_gettime where available 139 | - Read and Show instances exported in the same module as their types 140 | - Fixed bug in fromSundayStartWeekValid 141 | - Parsing functions now reject invalid dates 142 | - Various documentation fixes 143 | 144 | ## [1.5.0.1] - 2014-12-13 145 | 146 | ## [1.5] - 2014-09-10 147 | 148 | ## [1.4.2] - 2014-03-03 149 | 150 | ## [1.4.1] - 2013-06-24 151 | 152 | ## [1.4.0.2] - 2012-11-25 153 | 154 | ## [1.4.0.1] - 2011-10-31 155 | 156 | ## [1.4] - 2011-09-13 157 | 158 | ## [1.3] - 2011-08-10 159 | 160 | ## [1.2.0.5] - 2011-05-11 161 | 162 | ## [1.2.0.4] - 2011-02-03 163 | 164 | ## [1.2.0.3] - 2010-06-22 165 | 166 | ## [1.2.0.2] - 2010-04-26 167 | 168 | ## [1.2.0.1] - 2010-04-11 169 | 170 | ## [1.2] - 2010-04-11 171 | 172 | ## [1.1.4] - 2009-07-17 173 | 174 | ## [1.1.3] - 2009-06-01 175 | 176 | ## [1.1.2.4] - 2009-04-17 177 | 178 | ## [1.1.2.3] - 2009-01-17 179 | 180 | ## [1.1.2.2] - 2008-10-11 181 | 182 | ## [1.1.2.1] - 2008-06-19 183 | 184 | ## [1.1.2.0] - 2007-11-03 185 | 186 | ## [1.1.1] - 2007-04-22 187 | 188 | ## [1.0] - 2006-11-02 189 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | AC_INIT([Haskell time package],[1.15],[ashley@semantic.org],[time]) 2 | 3 | # Safety check: Ensure that we are in the correct source directory. 4 | AC_CONFIG_SRCDIR([lib/include/HsTime.h]) 5 | 6 | # These are to silence warnings with older Cabal versions 7 | AC_ARG_WITH([gcc],[Gnu C compiler]) 8 | AC_ARG_WITH([compiler],[Haskell compiler]) 9 | 10 | AC_PROG_CC() 11 | 12 | AC_USE_SYSTEM_EXTENSIONS 13 | 14 | AC_CONFIG_HEADERS([lib/include/HsTimeConfig.h]) 15 | 16 | AC_CHECK_HEADERS([time.h]) 17 | AC_CHECK_FUNCS([gmtime_r localtime_r]) 18 | 19 | AC_CHECK_FUNCS([clock_gettime]) 20 | AC_CHECK_FUNCS([tzset]) 21 | 22 | AC_STRUCT_TM 23 | AC_STRUCT_TIMEZONE 24 | 25 | FP_DECL_ALTZONE 26 | 27 | AC_OUTPUT 28 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | respectful: false 2 | haddock-style: single-line 3 | let-style: newline 4 | in-style: no-space 5 | single-constraint-parens: never 6 | single-deriving-parens: never 7 | -------------------------------------------------------------------------------- /fullcheck.ps1: -------------------------------------------------------------------------------- 1 | $ErrorActionPreference = "Stop" 2 | & "git" "clean" "-dXf" 3 | if (!$?) {Exit 1} 4 | & "git" "pull" 5 | if (!$?) {Exit 1} 6 | & "stack" "exec" "--" "env" "autoreconf" "-i" 7 | if (!$?) {Exit 1} 8 | & "ghcup" "upgrade" 9 | if (!$?) {Exit 1} 10 | & "ghcup" "install" "cabal" "latest" 11 | if (!$?) {Exit 1} 12 | & "ghcup" "set" "cabal" "latest" 13 | if (!$?) {Exit 1} 14 | ForEach ($c in "9.8.4","9.10.1","9.12.2") 15 | { 16 | & "ghcup" "install" "ghc" "$c" 17 | if (!$?) {Exit 1} 18 | & "ghcup" "set" "ghc" "$c" 19 | if (!$?) {Exit 1} 20 | & "cabal" "update" 21 | if (!$?) {Exit 1} 22 | & "cabal" "v1-install" "--only-dependencies" "--enable-tests" 23 | if (!$?) {Exit 1} 24 | & "cabal" "v1-configure" "--enable-tests" 25 | if (!$?) {Exit 1} 26 | & "cabal" "v1-test" 27 | if (!$?) {Exit 1} 28 | & "cabal" "v1-haddock" 29 | if (!$?) {Exit 1} 30 | } 31 | Write-Output "OK" 32 | -------------------------------------------------------------------------------- /justfile: -------------------------------------------------------------------------------- 1 | default: build 2 | 3 | container-build: 4 | devcontainer build --workspace-folder . 5 | 6 | container-up: 7 | devcontainer up --workspace-folder . 8 | 9 | shell: container-up 10 | devcontainer exec --workspace-folder . bash 11 | 12 | format: container-up 13 | devcontainer exec --workspace-folder . format 14 | 15 | build: container-up 16 | devcontainer exec --workspace-folder . build-all 17 | 18 | fullbuild: container-build format build 19 | 20 | # to run this, your (classic) token must have "repo" and "read:packages" 21 | # to upload the container, it must have "write:packages" and you should be a member of the Haskell org. 22 | act: 23 | act -s GITHUB_TOKEN="$(gh auth token)" -j build-new 24 | -------------------------------------------------------------------------------- /lib/Data/Time.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | {-| 4 | 5 | = Quick Start 6 | 7 | Use these types for time regardless of location (not caring about leap-seconds): 8 | 9 | * 'UTCTime' for actual times 10 | * 'NominalDiffTime' for differences between times, i.e. durations 11 | 12 | Use these types for the ways people refer to time and time differences: 13 | 14 | * 'Day' for something like June 27th 2017 15 | * 'DayOfWeek' for something like Tuesday 16 | * 'Data.Time.Calendar.Month.Month' for something like August 2021 17 | * 'Data.Time.Calendar.Quarter.QuarterOfYear' for something like Q2 18 | * 'Data.Time.Calendar.Quarter.Quarter' for something like Q2 of 2023 19 | * 'TimeOfDay' for something like 5pm 20 | * 'LocalTime' for a 'Day' with a 'TimeOfDay' 21 | * 'TimeZone' for a time zone offset (not actually the time zone itself) like -0700 22 | * 'ZonedTime' for a 'LocalTime' with a 'TimeZone' 23 | * 'CalendarDiffDays' for something like 6 years, 1 month and 5 days 24 | * 'CalendarDiffTime' for something like 6 years, 1 month, 5 days, 3 hours, 7 minutes and 25.784 seconds 25 | 26 | Use this for low-latency timing: 27 | 28 | * 'Data.Time.Clock.System.SystemTime' 29 | 30 | These are less commonly needed: 31 | 32 | * 'Data.Time.Clock.TAI.AbsoluteTime' and 'DiffTime' if you do care about leap-seconds. 33 | * 'Data.Time.Clock.TAI.LeapSecondMap' for tracking the leap-seconds 34 | * 'UniversalTime' for time based on Earth rotation 35 | -} 36 | module Data.Time 37 | ( module Data.Time.Calendar 38 | , module Data.Time.Clock 39 | , module Data.Time.LocalTime 40 | , module Data.Time.Format 41 | ) where 42 | 43 | import Data.Time.Calendar 44 | import Data.Time.Clock 45 | import Data.Time.Format 46 | import Data.Time.LocalTime 47 | -------------------------------------------------------------------------------- /lib/Data/Time/Calendar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.Calendar ( 4 | module Data.Time.Calendar.Days, 5 | module Data.Time.Calendar.CalendarDiffDays, 6 | module Data.Time.Calendar.Gregorian, 7 | module Data.Time.Calendar.Week, 8 | ) where 9 | 10 | import Data.Time.Calendar.CalendarDiffDays 11 | import Data.Time.Calendar.Days 12 | import Data.Time.Calendar.Gregorian 13 | import Data.Time.Calendar.Week 14 | import Data.Time.Format () 15 | -------------------------------------------------------------------------------- /lib/Data/Time/Calendar/CalendarDiffDays.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.Calendar.CalendarDiffDays ( 4 | -- * Calendar Duration 5 | module Data.Time.Calendar.CalendarDiffDays, 6 | ) where 7 | 8 | import Control.DeepSeq 9 | import Data.Data 10 | import GHC.Generics 11 | import qualified Language.Haskell.TH.Syntax as TH 12 | 13 | data CalendarDiffDays = CalendarDiffDays 14 | { cdMonths :: Integer 15 | , cdDays :: Integer 16 | } 17 | deriving (Eq, Typeable, Data, Generic, TH.Lift) 18 | 19 | instance NFData CalendarDiffDays where 20 | rnf (CalendarDiffDays m d) = rnf m `seq` rnf d `seq` () 21 | 22 | -- | Additive 23 | instance Semigroup CalendarDiffDays where 24 | CalendarDiffDays m1 d1 <> CalendarDiffDays m2 d2 = CalendarDiffDays (m1 + m2) (d1 + d2) 25 | 26 | -- | Additive 27 | instance Monoid CalendarDiffDays where 28 | mempty = CalendarDiffDays 0 0 29 | mappend = (<>) 30 | 31 | calendarDay :: CalendarDiffDays 32 | calendarDay = CalendarDiffDays 0 1 33 | 34 | calendarWeek :: CalendarDiffDays 35 | calendarWeek = CalendarDiffDays 0 7 36 | 37 | calendarMonth :: CalendarDiffDays 38 | calendarMonth = CalendarDiffDays 1 0 39 | 40 | calendarYear :: CalendarDiffDays 41 | calendarYear = CalendarDiffDays 12 0 42 | 43 | -- | Scale by a factor. Note that @scaleCalendarDiffDays (-1)@ will not perfectly invert a duration, due to variable month lengths. 44 | scaleCalendarDiffDays :: Integer -> CalendarDiffDays -> CalendarDiffDays 45 | scaleCalendarDiffDays k (CalendarDiffDays m d) = CalendarDiffDays (k * m) (k * d) 46 | -------------------------------------------------------------------------------- /lib/Data/Time/Calendar/Days.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.Calendar.Days ( 4 | -- * Days 5 | Day (..), 6 | addDays, 7 | diffDays, 8 | 9 | -- * DayPeriod 10 | DayPeriod (..), 11 | periodAllDays, 12 | periodLength, 13 | periodFromDay, 14 | periodToDay, 15 | periodToDayValid, 16 | ) where 17 | 18 | import Control.DeepSeq 19 | import Data.Data 20 | import Data.Ix 21 | import GHC.Generics 22 | import qualified Language.Haskell.TH.Syntax as TH 23 | 24 | -- | The Modified Julian Day is a standard count of days, with zero being the day 1858-11-17. 25 | newtype Day = ModifiedJulianDay 26 | { toModifiedJulianDay :: Integer 27 | } 28 | deriving (Eq, Ord, Typeable, Data, Generic, TH.Lift) 29 | 30 | instance NFData Day where 31 | rnf (ModifiedJulianDay a) = rnf a 32 | 33 | instance Enum Day where 34 | succ (ModifiedJulianDay a) = ModifiedJulianDay (succ a) 35 | pred (ModifiedJulianDay a) = ModifiedJulianDay (pred a) 36 | toEnum = ModifiedJulianDay . toEnum 37 | fromEnum (ModifiedJulianDay a) = fromEnum a 38 | enumFrom (ModifiedJulianDay a) = fmap ModifiedJulianDay (enumFrom a) 39 | enumFromThen (ModifiedJulianDay a) (ModifiedJulianDay b) = fmap ModifiedJulianDay (enumFromThen a b) 40 | enumFromTo (ModifiedJulianDay a) (ModifiedJulianDay b) = fmap ModifiedJulianDay (enumFromTo a b) 41 | enumFromThenTo (ModifiedJulianDay a) (ModifiedJulianDay b) (ModifiedJulianDay c) = 42 | fmap ModifiedJulianDay (enumFromThenTo a b c) 43 | 44 | instance Ix Day where 45 | range (ModifiedJulianDay a, ModifiedJulianDay b) = fmap ModifiedJulianDay (range (a, b)) 46 | index (ModifiedJulianDay a, ModifiedJulianDay b) (ModifiedJulianDay c) = index (a, b) c 47 | inRange (ModifiedJulianDay a, ModifiedJulianDay b) (ModifiedJulianDay c) = inRange (a, b) c 48 | rangeSize (ModifiedJulianDay a, ModifiedJulianDay b) = rangeSize (a, b) 49 | 50 | addDays :: Integer -> Day -> Day 51 | addDays n (ModifiedJulianDay a) = ModifiedJulianDay (a + n) 52 | 53 | diffDays :: Day -> Day -> Integer 54 | diffDays (ModifiedJulianDay a) (ModifiedJulianDay b) = a - b 55 | 56 | -- | The class of types which can be represented as a period of days. 57 | -- 58 | -- @since 1.12.1 59 | class Ord p => DayPeriod p where 60 | -- | Returns the first 'Day' in a period of days. 61 | periodFirstDay :: p -> Day 62 | 63 | -- | Returns the last 'Day' in a period of days. 64 | periodLastDay :: p -> Day 65 | 66 | -- | Get the period this day is in. 67 | dayPeriod :: Day -> p 68 | 69 | -- | A list of all the days in this period. 70 | -- 71 | -- @since 1.12.1 72 | periodAllDays :: DayPeriod p => p -> [Day] 73 | periodAllDays p = [periodFirstDay p .. periodLastDay p] 74 | 75 | -- | The number of days in this period. 76 | -- 77 | -- @since 1.12.1 78 | periodLength :: DayPeriod p => p -> Int 79 | periodLength p = succ $ fromInteger $ diffDays (periodLastDay p) (periodFirstDay p) 80 | 81 | -- | Get the period this day is in, with the 1-based day number within the period. 82 | -- 83 | -- @periodFromDay (periodFirstDay p) = (p,1)@ 84 | -- 85 | -- @since 1.12.1 86 | periodFromDay :: DayPeriod p => Day -> (p, Int) 87 | periodFromDay d = 88 | let 89 | p = dayPeriod d 90 | dt = succ $ fromInteger $ diffDays d $ periodFirstDay p 91 | in 92 | (p, dt) 93 | 94 | -- | Inverse of 'periodFromDay'. 95 | -- 96 | -- @since 1.12.1 97 | periodToDay :: DayPeriod p => p -> Int -> Day 98 | periodToDay p i = addDays (toInteger $ pred i) $ periodFirstDay p 99 | 100 | -- | Validating inverse of 'periodFromDay'. 101 | -- 102 | -- @since 1.12.1 103 | periodToDayValid :: DayPeriod p => p -> Int -> Maybe Day 104 | periodToDayValid p i = 105 | let 106 | d = periodToDay p i 107 | in 108 | if fst (periodFromDay d) == p then Just d else Nothing 109 | 110 | instance DayPeriod Day where 111 | periodFirstDay = id 112 | periodLastDay = id 113 | dayPeriod = id 114 | -------------------------------------------------------------------------------- /lib/Data/Time/Calendar/Easter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.Calendar.Easter ( 4 | sundayAfter, 5 | orthodoxPaschalMoon, 6 | orthodoxEaster, 7 | gregorianPaschalMoon, 8 | gregorianEaster, 9 | ) where 10 | 11 | -- formulae from Reingold & Dershowitz, _Calendrical Calculations_, ch. 8. 12 | import Data.Time.Calendar 13 | import Data.Time.Calendar.Julian 14 | 15 | -- | The next Sunday strictly after a given day. 16 | sundayAfter :: Day -> Day 17 | sundayAfter day = addDays (7 - (mod (toModifiedJulianDay day + 3) 7)) day 18 | 19 | -- | Given a year, find the Paschal full moon according to Orthodox Christian tradition 20 | orthodoxPaschalMoon :: Year -> Day 21 | orthodoxPaschalMoon year = addDays (-shiftedEpact) (fromJulian jyear 4 19) 22 | where 23 | shiftedEpact = mod (14 + 11 * (mod year 19)) 30 24 | jyear = 25 | if year > 0 26 | then year 27 | else year - 1 28 | 29 | -- | Given a year, find Easter according to Orthodox Christian tradition 30 | orthodoxEaster :: Year -> Day 31 | orthodoxEaster = sundayAfter . orthodoxPaschalMoon 32 | 33 | -- | Given a year, find the Paschal full moon according to the Gregorian method 34 | gregorianPaschalMoon :: Year -> Day 35 | gregorianPaschalMoon year = addDays (-adjustedEpact) (fromGregorian year 4 19) 36 | where 37 | century = (div year 100) + 1 38 | shiftedEpact = mod (14 + 11 * (mod year 19) - (div (3 * century) 4) + (div (5 + 8 * century) 25)) 30 39 | adjustedEpact = 40 | if shiftedEpact == 0 || ((shiftedEpact == 1) && (mod year 19 < 10)) 41 | then shiftedEpact + 1 42 | else shiftedEpact 43 | 44 | -- | Given a year, find Easter according to the Gregorian method 45 | gregorianEaster :: Year -> Day 46 | gregorianEaster = sundayAfter . gregorianPaschalMoon 47 | -------------------------------------------------------------------------------- /lib/Data/Time/Calendar/Gregorian.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | {-# LANGUAGE TypeSynonymInstances #-} 3 | 4 | {-# OPTIONS -fno-warn-orphans #-} 5 | 6 | module Data.Time.Calendar.Gregorian ( 7 | -- * Year, month and day 8 | Year, 9 | pattern CommonEra, 10 | pattern BeforeCommonEra, 11 | MonthOfYear, 12 | pattern January, 13 | pattern February, 14 | pattern March, 15 | pattern April, 16 | pattern May, 17 | pattern June, 18 | pattern July, 19 | pattern August, 20 | pattern September, 21 | pattern October, 22 | pattern November, 23 | pattern December, 24 | DayOfMonth, 25 | 26 | -- * Gregorian calendar 27 | toGregorian, 28 | fromGregorian, 29 | pattern YearMonthDay, 30 | fromGregorianValid, 31 | showGregorian, 32 | gregorianMonthLength, 33 | -- calendrical arithmetic 34 | -- e.g. "one month after March 31st" 35 | addGregorianMonthsClip, 36 | addGregorianMonthsRollOver, 37 | addGregorianYearsClip, 38 | addGregorianYearsRollOver, 39 | addGregorianDurationClip, 40 | addGregorianDurationRollOver, 41 | diffGregorianDurationClip, 42 | diffGregorianDurationRollOver, 43 | -- re-exported from OrdinalDate 44 | isLeapYear, 45 | ) where 46 | 47 | import Data.Time.Calendar.CalendarDiffDays 48 | import Data.Time.Calendar.Days 49 | import Data.Time.Calendar.MonthDay 50 | import Data.Time.Calendar.OrdinalDate 51 | import Data.Time.Calendar.Private 52 | import Data.Time.Calendar.Types 53 | 54 | -- | Convert to proleptic Gregorian calendar. 55 | toGregorian :: Day -> (Year, MonthOfYear, DayOfMonth) 56 | toGregorian date = (year, month, day) 57 | where 58 | (year, yd) = toOrdinalDate date 59 | (month, day) = dayOfYearToMonthAndDay (isLeapYear year) yd 60 | 61 | -- | Convert from proleptic Gregorian calendar. 62 | -- Invalid values will be clipped to the correct range, month first, then day. 63 | fromGregorian :: Year -> MonthOfYear -> DayOfMonth -> Day 64 | fromGregorian year month day = fromOrdinalDate year (monthAndDayToDayOfYear (isLeapYear year) month day) 65 | 66 | -- | Bidirectional abstract constructor for the proleptic Gregorian calendar. 67 | -- Invalid values will be clipped to the correct range, month first, then day. 68 | pattern YearMonthDay :: Year -> MonthOfYear -> DayOfMonth -> Day 69 | pattern YearMonthDay y m d <- 70 | (toGregorian -> (y, m, d)) 71 | where 72 | YearMonthDay y m d = fromGregorian y m d 73 | 74 | {-# COMPLETE YearMonthDay #-} 75 | 76 | -- | Convert from proleptic Gregorian calendar. 77 | -- Invalid values will return Nothing 78 | fromGregorianValid :: Year -> MonthOfYear -> DayOfMonth -> Maybe Day 79 | fromGregorianValid year month day = do 80 | doy <- monthAndDayToDayOfYearValid (isLeapYear year) month day 81 | fromOrdinalDateValid year doy 82 | 83 | -- | Show in ISO 8601 format (yyyy-mm-dd) 84 | showGregorian :: Day -> String 85 | showGregorian date = (show4 y) ++ "-" ++ (show2 m) ++ "-" ++ (show2 d) 86 | where 87 | (y, m, d) = toGregorian date 88 | 89 | -- | The number of days in a given month according to the proleptic Gregorian calendar. 90 | gregorianMonthLength :: Year -> MonthOfYear -> DayOfMonth 91 | gregorianMonthLength year = monthLength (isLeapYear year) 92 | 93 | rolloverMonths :: (Year, Integer) -> (Year, MonthOfYear) 94 | rolloverMonths (y, m) = (y + (div (m - 1) 12), fromIntegral (mod (m - 1) 12) + 1) 95 | 96 | addGregorianMonths :: Integer -> Day -> (Year, MonthOfYear, DayOfMonth) 97 | addGregorianMonths n day = (y', m', d) 98 | where 99 | (y, m, d) = toGregorian day 100 | (y', m') = rolloverMonths (y, fromIntegral m + n) 101 | 102 | -- | Add months, with days past the last day of the month clipped to the last day. 103 | -- For instance, 2005-01-30 + 1 month = 2005-02-28. 104 | addGregorianMonthsClip :: Integer -> Day -> Day 105 | addGregorianMonthsClip n day = fromGregorian y m d 106 | where 107 | (y, m, d) = addGregorianMonths n day 108 | 109 | -- | Add months, with days past the last day of the month rolling over to the next month. 110 | -- For instance, 2005-01-30 + 1 month = 2005-03-02. 111 | addGregorianMonthsRollOver :: Integer -> Day -> Day 112 | addGregorianMonthsRollOver n day = addDays (fromIntegral d - 1) (fromGregorian y m 1) 113 | where 114 | (y, m, d) = addGregorianMonths n day 115 | 116 | -- | Add years, matching month and day, with Feb 29th clipped to Feb 28th if necessary. 117 | -- For instance, 2004-02-29 + 2 years = 2006-02-28. 118 | addGregorianYearsClip :: Integer -> Day -> Day 119 | addGregorianYearsClip n = addGregorianMonthsClip (n * 12) 120 | 121 | -- | Add years, matching month and day, with Feb 29th rolled over to Mar 1st if necessary. 122 | -- For instance, 2004-02-29 + 2 years = 2006-03-01. 123 | addGregorianYearsRollOver :: Integer -> Day -> Day 124 | addGregorianYearsRollOver n = addGregorianMonthsRollOver (n * 12) 125 | 126 | -- | Add months (clipped to last day), then add days 127 | addGregorianDurationClip :: CalendarDiffDays -> Day -> Day 128 | addGregorianDurationClip (CalendarDiffDays m d) day = addDays d $ addGregorianMonthsClip m day 129 | 130 | -- | Add months (rolling over to next month), then add days 131 | addGregorianDurationRollOver :: CalendarDiffDays -> Day -> Day 132 | addGregorianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addGregorianMonthsRollOver m day 133 | 134 | -- | Calendrical difference, with as many whole months as possible 135 | diffGregorianDurationClip :: Day -> Day -> CalendarDiffDays 136 | diffGregorianDurationClip day2 day1 = 137 | let 138 | (y1, m1, d1) = toGregorian day1 139 | (y2, m2, d2) = toGregorian day2 140 | ym1 = y1 * 12 + toInteger m1 141 | ym2 = y2 * 12 + toInteger m2 142 | ymdiff = ym2 - ym1 143 | ymAllowed = 144 | if day2 >= day1 145 | then 146 | if d2 >= d1 147 | then ymdiff 148 | else ymdiff - 1 149 | else 150 | if d2 <= d1 151 | then ymdiff 152 | else ymdiff + 1 153 | dayAllowed = addGregorianDurationClip (CalendarDiffDays ymAllowed 0) day1 154 | in 155 | CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed 156 | 157 | -- | Calendrical difference, with as many whole months as possible. 158 | diffGregorianDurationRollOver :: Day -> Day -> CalendarDiffDays 159 | diffGregorianDurationRollOver day2 day1 = 160 | let 161 | (y1, m1, _) = toGregorian day1 162 | (y2, m2, _) = toGregorian day2 163 | ym1 = y1 * 12 + toInteger m1 164 | ym2 = y2 * 12 + toInteger m2 165 | ymdiff = ym2 - ym1 166 | findpos mdiff = 167 | let 168 | dayAllowed = addGregorianDurationRollOver (CalendarDiffDays mdiff 0) day1 169 | dd = diffDays day2 dayAllowed 170 | in 171 | if dd >= 0 then CalendarDiffDays mdiff dd else findpos (pred mdiff) 172 | findneg mdiff = 173 | let 174 | dayAllowed = addGregorianDurationRollOver (CalendarDiffDays mdiff 0) day1 175 | dd = diffDays day2 dayAllowed 176 | in 177 | if dd <= 0 then CalendarDiffDays mdiff dd else findpos (succ mdiff) 178 | in 179 | if day2 >= day1 180 | then findpos ymdiff 181 | else findneg ymdiff 182 | 183 | -- orphan instance 184 | instance Show Day where 185 | show = showGregorian 186 | 187 | -- orphan instance 188 | instance DayPeriod Year where 189 | periodFirstDay y = YearMonthDay y January 1 190 | periodLastDay y = YearMonthDay y December 31 191 | dayPeriod (YearMonthDay y _ _) = y 192 | -------------------------------------------------------------------------------- /lib/Data/Time/Calendar/Julian.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.Calendar.Julian ( 4 | Year, 5 | MonthOfYear, 6 | pattern January, 7 | pattern February, 8 | pattern March, 9 | pattern April, 10 | pattern May, 11 | pattern June, 12 | pattern July, 13 | pattern August, 14 | pattern September, 15 | pattern October, 16 | pattern November, 17 | pattern December, 18 | DayOfMonth, 19 | DayOfYear, 20 | module Data.Time.Calendar.JulianYearDay, 21 | toJulian, 22 | fromJulian, 23 | pattern JulianYearMonthDay, 24 | fromJulianValid, 25 | showJulian, 26 | julianMonthLength, 27 | -- calendrical arithmetic 28 | -- e.g. "one month after March 31st" 29 | addJulianMonthsClip, 30 | addJulianMonthsRollOver, 31 | addJulianYearsClip, 32 | addJulianYearsRollOver, 33 | addJulianDurationClip, 34 | addJulianDurationRollOver, 35 | diffJulianDurationClip, 36 | diffJulianDurationRollOver, 37 | ) where 38 | 39 | import Data.Time.Calendar.CalendarDiffDays 40 | import Data.Time.Calendar.Days 41 | import Data.Time.Calendar.JulianYearDay 42 | import Data.Time.Calendar.MonthDay 43 | import Data.Time.Calendar.Private 44 | import Data.Time.Calendar.Types 45 | 46 | -- | Convert to proleptic Julian calendar. 47 | toJulian :: Day -> (Year, MonthOfYear, DayOfMonth) 48 | toJulian date = (year, month, day) 49 | where 50 | (year, yd) = toJulianYearAndDay date 51 | (month, day) = dayOfYearToMonthAndDay (isJulianLeapYear year) yd 52 | 53 | -- | Convert from proleptic Julian calendar. 54 | -- Invalid values will be clipped to the correct range, month first, then day. 55 | fromJulian :: Year -> MonthOfYear -> DayOfMonth -> Day 56 | fromJulian year month day = fromJulianYearAndDay year (monthAndDayToDayOfYear (isJulianLeapYear year) month day) 57 | 58 | -- | Bidirectional abstract constructor for the proleptic Julian calendar. 59 | -- Invalid values will be clipped to the correct range, month first, then day. 60 | pattern JulianYearMonthDay :: Year -> MonthOfYear -> DayOfMonth -> Day 61 | pattern JulianYearMonthDay y m d <- 62 | (toJulian -> (y, m, d)) 63 | where 64 | JulianYearMonthDay y m d = fromJulian y m d 65 | 66 | {-# COMPLETE JulianYearMonthDay #-} 67 | 68 | -- | Convert from proleptic Julian calendar. 69 | -- Invalid values will return Nothing. 70 | fromJulianValid :: Year -> MonthOfYear -> DayOfMonth -> Maybe Day 71 | fromJulianValid year month day = do 72 | doy <- monthAndDayToDayOfYearValid (isJulianLeapYear year) month day 73 | fromJulianYearAndDayValid year doy 74 | 75 | -- | Show in ISO 8601 format (yyyy-mm-dd) 76 | showJulian :: Day -> String 77 | showJulian date = (show4 y) ++ "-" ++ (show2 m) ++ "-" ++ (show2 d) 78 | where 79 | (y, m, d) = toJulian date 80 | 81 | -- | The number of days in a given month according to the proleptic Julian calendar. 82 | julianMonthLength :: Year -> MonthOfYear -> DayOfMonth 83 | julianMonthLength year = monthLength (isJulianLeapYear year) 84 | 85 | rolloverMonths :: (Year, Integer) -> (Year, MonthOfYear) 86 | rolloverMonths (y, m) = (y + (div (m - 1) 12), fromIntegral (mod (m - 1) 12) + 1) 87 | 88 | addJulianMonths :: Integer -> Day -> (Year, MonthOfYear, DayOfMonth) 89 | addJulianMonths n day = (y', m', d) 90 | where 91 | (y, m, d) = toJulian day 92 | (y', m') = rolloverMonths (y, fromIntegral m + n) 93 | 94 | -- | Add months, with days past the last day of the month clipped to the last day. 95 | -- For instance, 2005-01-30 + 1 month = 2005-02-28. 96 | addJulianMonthsClip :: Integer -> Day -> Day 97 | addJulianMonthsClip n day = fromJulian y m d 98 | where 99 | (y, m, d) = addJulianMonths n day 100 | 101 | -- | Add months, with days past the last day of the month rolling over to the next month. 102 | -- For instance, 2005-01-30 + 1 month = 2005-03-02. 103 | addJulianMonthsRollOver :: Integer -> Day -> Day 104 | addJulianMonthsRollOver n day = addDays (fromIntegral d - 1) (fromJulian y m 1) 105 | where 106 | (y, m, d) = addJulianMonths n day 107 | 108 | -- | Add years, matching month and day, with Feb 29th clipped to Feb 28th if necessary. 109 | -- For instance, 2004-02-29 + 2 years = 2006-02-28. 110 | addJulianYearsClip :: Integer -> Day -> Day 111 | addJulianYearsClip n = addJulianMonthsClip (n * 12) 112 | 113 | -- | Add years, matching month and day, with Feb 29th rolled over to Mar 1st if necessary. 114 | -- For instance, 2004-02-29 + 2 years = 2006-03-01. 115 | addJulianYearsRollOver :: Integer -> Day -> Day 116 | addJulianYearsRollOver n = addJulianMonthsRollOver (n * 12) 117 | 118 | -- | Add months (clipped to last day), then add days 119 | addJulianDurationClip :: CalendarDiffDays -> Day -> Day 120 | addJulianDurationClip (CalendarDiffDays m d) day = addDays d $ addJulianMonthsClip m day 121 | 122 | -- | Add months (rolling over to next month), then add days 123 | addJulianDurationRollOver :: CalendarDiffDays -> Day -> Day 124 | addJulianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addJulianMonthsRollOver m day 125 | 126 | -- | Calendrical difference, with as many whole months as possible 127 | diffJulianDurationClip :: Day -> Day -> CalendarDiffDays 128 | diffJulianDurationClip day2 day1 = 129 | let 130 | (y1, m1, d1) = toJulian day1 131 | (y2, m2, d2) = toJulian day2 132 | ym1 = y1 * 12 + toInteger m1 133 | ym2 = y2 * 12 + toInteger m2 134 | ymdiff = ym2 - ym1 135 | ymAllowed = 136 | if day2 >= day1 137 | then 138 | if d2 >= d1 139 | then ymdiff 140 | else ymdiff - 1 141 | else 142 | if d2 <= d1 143 | then ymdiff 144 | else ymdiff + 1 145 | dayAllowed = addJulianDurationClip (CalendarDiffDays ymAllowed 0) day1 146 | in 147 | CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed 148 | 149 | -- | Calendrical difference, with as many whole months as possible. 150 | diffJulianDurationRollOver :: Day -> Day -> CalendarDiffDays 151 | diffJulianDurationRollOver day2 day1 = 152 | let 153 | (y1, m1, _) = toJulian day1 154 | (y2, m2, _) = toJulian day2 155 | ym1 = y1 * 12 + toInteger m1 156 | ym2 = y2 * 12 + toInteger m2 157 | ymdiff = ym2 - ym1 158 | findpos mdiff = 159 | let 160 | dayAllowed = addJulianDurationRollOver (CalendarDiffDays mdiff 0) day1 161 | dd = diffDays day2 dayAllowed 162 | in 163 | if dd >= 0 then CalendarDiffDays mdiff dd else findpos (pred mdiff) 164 | findneg mdiff = 165 | let 166 | dayAllowed = addJulianDurationRollOver (CalendarDiffDays mdiff 0) day1 167 | dd = diffDays day2 dayAllowed 168 | in 169 | if dd <= 0 then CalendarDiffDays mdiff dd else findpos (succ mdiff) 170 | in 171 | if day2 >= day1 172 | then findpos ymdiff 173 | else findneg ymdiff 174 | -------------------------------------------------------------------------------- /lib/Data/Time/Calendar/JulianYearDay.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.Calendar.JulianYearDay ( 4 | -- * Year and day format 5 | module Data.Time.Calendar.JulianYearDay, 6 | ) where 7 | 8 | import Data.Time.Calendar.Days 9 | import Data.Time.Calendar.Private 10 | import Data.Time.Calendar.Types 11 | 12 | -- | Convert to proleptic Julian year and day format. 13 | toJulianYearAndDay :: Day -> (Year, DayOfYear) 14 | toJulianYearAndDay (ModifiedJulianDay mjd) = (year, yd) 15 | where 16 | a = mjd + 678577 17 | quad = div a 1461 18 | d = mod a 1461 19 | y = min (div d 365) 3 20 | yd = fromInteger (d - (y * 365) + 1) 21 | year = quad * 4 + y + 1 22 | 23 | -- | Convert from proleptic Julian year and day format. 24 | -- Invalid day numbers will be clipped to the correct range (1 to 365 or 366). 25 | fromJulianYearAndDay :: Year -> DayOfYear -> Day 26 | fromJulianYearAndDay year day = ModifiedJulianDay mjd 27 | where 28 | y = year - 1 29 | mjd = 30 | ( fromIntegral 31 | ( clip 32 | 1 33 | ( if isJulianLeapYear year 34 | then 366 35 | else 365 36 | ) 37 | day 38 | ) 39 | ) 40 | + (365 * y) 41 | + (div y 4) 42 | - 678578 43 | 44 | -- | Convert from proleptic Julian year and day format. 45 | -- Invalid day numbers will return Nothing 46 | fromJulianYearAndDayValid :: Year -> DayOfYear -> Maybe Day 47 | fromJulianYearAndDayValid year day = do 48 | day' <- 49 | clipValid 50 | 1 51 | ( if isJulianLeapYear year 52 | then 366 53 | else 365 54 | ) 55 | day 56 | let 57 | y = year - 1 58 | mjd = (fromIntegral day') + (365 * y) + (div y 4) - 678578 59 | return (ModifiedJulianDay mjd) 60 | 61 | -- | Show in proleptic Julian year and day format (yyyy-ddd) 62 | showJulianYearAndDay :: Day -> String 63 | showJulianYearAndDay date = (show4 y) ++ "-" ++ (show3 d) 64 | where 65 | (y, d) = toJulianYearAndDay date 66 | 67 | -- | Is this year a leap year according to the proleptic Julian calendar? 68 | isJulianLeapYear :: Year -> Bool 69 | isJulianLeapYear year = (mod year 4 == 0) 70 | -------------------------------------------------------------------------------- /lib/Data/Time/Calendar/Month.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | -- | An absolute count of common calendar months. 4 | module Data.Time.Calendar.Month ( 5 | Month (..), 6 | addMonths, 7 | diffMonths, 8 | pattern YearMonth, 9 | fromYearMonthValid, 10 | pattern MonthDay, 11 | fromMonthDayValid, 12 | ) where 13 | 14 | import Control.DeepSeq 15 | import Data.Data 16 | import Data.Fixed 17 | import Data.Ix 18 | import Data.Time.Calendar.Days 19 | import Data.Time.Calendar.Gregorian 20 | import Data.Time.Calendar.Private 21 | import GHC.Generics 22 | import qualified Language.Haskell.TH.Syntax as TH 23 | import Text.ParserCombinators.ReadP 24 | import Text.Read 25 | 26 | -- | An absolute count of common calendar months. 27 | -- Number is equal to @(year * 12) + (monthOfYear - 1)@. 28 | newtype Month = MkMonth Integer deriving (Eq, Ord, Typeable, Data, Generic, TH.Lift) 29 | 30 | instance NFData Month where 31 | rnf (MkMonth m) = rnf m 32 | 33 | instance Enum Month where 34 | succ (MkMonth a) = MkMonth (succ a) 35 | pred (MkMonth a) = MkMonth (pred a) 36 | toEnum = MkMonth . toEnum 37 | fromEnum (MkMonth a) = fromEnum a 38 | enumFrom (MkMonth a) = fmap MkMonth (enumFrom a) 39 | enumFromThen (MkMonth a) (MkMonth b) = fmap MkMonth (enumFromThen a b) 40 | enumFromTo (MkMonth a) (MkMonth b) = fmap MkMonth (enumFromTo a b) 41 | enumFromThenTo (MkMonth a) (MkMonth b) (MkMonth c) = 42 | fmap MkMonth (enumFromThenTo a b c) 43 | 44 | instance Ix Month where 45 | range (MkMonth a, MkMonth b) = fmap MkMonth (range (a, b)) 46 | index (MkMonth a, MkMonth b) (MkMonth c) = index (a, b) c 47 | inRange (MkMonth a, MkMonth b) (MkMonth c) = inRange (a, b) c 48 | rangeSize (MkMonth a, MkMonth b) = rangeSize (a, b) 49 | 50 | -- | Show as @yyyy-mm@. 51 | instance Show Month where 52 | show (YearMonth y m) = show4 y ++ "-" ++ show2 m 53 | 54 | -- | Read as @yyyy-mm@. 55 | instance Read Month where 56 | readPrec = do 57 | y <- readPrec 58 | _ <- lift $ char '-' 59 | m <- readPrec 60 | return $ YearMonth y m 61 | 62 | instance DayPeriod Month where 63 | periodFirstDay (YearMonth y m) = YearMonthDay y m 1 64 | periodLastDay (YearMonth y m) = YearMonthDay y m 31 -- clips to correct day 65 | dayPeriod (YearMonthDay y my _) = YearMonth y my 66 | 67 | addMonths :: Integer -> Month -> Month 68 | addMonths n (MkMonth a) = MkMonth $ a + n 69 | 70 | diffMonths :: Month -> Month -> Integer 71 | diffMonths (MkMonth a) (MkMonth b) = a - b 72 | 73 | -- | Bidirectional abstract constructor. 74 | -- Invalid months of year will be clipped to the correct range. 75 | pattern YearMonth :: Year -> MonthOfYear -> Month 76 | pattern YearMonth y my <- 77 | MkMonth ((\m -> divMod' m 12) -> (y, (succ . fromInteger -> my))) 78 | where 79 | YearMonth y my = MkMonth $ (y * 12) + toInteger (pred $ clip 1 12 my) 80 | 81 | fromYearMonthValid :: Year -> MonthOfYear -> Maybe Month 82 | fromYearMonthValid y my = do 83 | my' <- clipValid 1 12 my 84 | return $ YearMonth y my' 85 | 86 | {-# COMPLETE YearMonth #-} 87 | 88 | -- | Bidirectional abstract constructor. 89 | -- Invalid days of month will be clipped to the correct range. 90 | pattern MonthDay :: Month -> DayOfMonth -> Day 91 | pattern MonthDay m dm <- 92 | (periodFromDay -> (m, dm)) 93 | where 94 | MonthDay = periodToDay 95 | 96 | fromMonthDayValid :: Month -> DayOfMonth -> Maybe Day 97 | fromMonthDayValid = periodToDayValid 98 | 99 | {-# COMPLETE MonthDay #-} 100 | -------------------------------------------------------------------------------- /lib/Data/Time/Calendar/MonthDay.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.Calendar.MonthDay ( 4 | MonthOfYear, 5 | pattern January, 6 | pattern February, 7 | pattern March, 8 | pattern April, 9 | pattern May, 10 | pattern June, 11 | pattern July, 12 | pattern August, 13 | pattern September, 14 | pattern October, 15 | pattern November, 16 | pattern December, 17 | DayOfMonth, 18 | DayOfYear, 19 | monthAndDayToDayOfYear, 20 | monthAndDayToDayOfYearValid, 21 | dayOfYearToMonthAndDay, 22 | monthLength, 23 | ) where 24 | 25 | import Data.Time.Calendar.Private 26 | import Data.Time.Calendar.Types 27 | 28 | -- | Convert month and day in the Gregorian or Julian calendars to day of year. 29 | -- First arg is leap year flag. 30 | monthAndDayToDayOfYear :: Bool -> MonthOfYear -> DayOfMonth -> DayOfYear 31 | monthAndDayToDayOfYear isLeap month day = (div (367 * month'' - 362) 12) + k + day' 32 | where 33 | month' = clip 1 12 month 34 | day' = fromIntegral (clip 1 (monthLength' isLeap month') day) 35 | month'' = fromIntegral month' 36 | k = 37 | if month' <= 2 38 | then 0 39 | else 40 | if isLeap 41 | then -1 42 | else -2 43 | 44 | -- | Convert month and day in the Gregorian or Julian calendars to day of year. 45 | -- First arg is leap year flag. 46 | monthAndDayToDayOfYearValid :: Bool -> MonthOfYear -> DayOfMonth -> Maybe DayOfYear 47 | monthAndDayToDayOfYearValid isLeap month day = do 48 | month' <- clipValid 1 12 month 49 | day' <- clipValid 1 (monthLength' isLeap month') day 50 | let 51 | day'' = fromIntegral day' 52 | month'' = fromIntegral month' 53 | k = 54 | if month' <= 2 55 | then 0 56 | else 57 | if isLeap 58 | then -1 59 | else -2 60 | return ((div (367 * month'' - 362) 12) + k + day'') 61 | 62 | -- | Convert day of year in the Gregorian or Julian calendars to month and day. 63 | -- First arg is leap year flag. 64 | dayOfYearToMonthAndDay :: Bool -> DayOfYear -> (MonthOfYear, DayOfMonth) 65 | dayOfYearToMonthAndDay isLeap yd = 66 | findMonthDay 67 | (monthLengths isLeap) 68 | ( clip 69 | 1 70 | ( if isLeap 71 | then 366 72 | else 365 73 | ) 74 | yd 75 | ) 76 | 77 | findMonthDay :: [Int] -> Int -> (Int, Int) 78 | findMonthDay (n : ns) yd 79 | | yd > n = (\(m, d) -> (m + 1, d)) (findMonthDay ns (yd - n)) 80 | findMonthDay _ yd = (1, yd) 81 | 82 | -- | The length of a given month in the Gregorian or Julian calendars. 83 | -- First arg is leap year flag. 84 | monthLength :: Bool -> MonthOfYear -> DayOfMonth 85 | monthLength isLeap month' = monthLength' isLeap (clip 1 12 month') 86 | 87 | monthLength' :: Bool -> MonthOfYear -> DayOfMonth 88 | monthLength' isLeap month' = (monthLengths isLeap) !! (month' - 1) 89 | 90 | monthLengths :: Bool -> [DayOfMonth] 91 | monthLengths isleap = 92 | [ 31 93 | , if isleap 94 | then 29 95 | else 28 96 | , 31 97 | , 30 98 | , 31 99 | , 30 100 | , 31 101 | , 31 102 | , 30 103 | , 31 104 | , 30 105 | , 31 106 | ] 107 | 108 | -- J F M A M J J A S O N D 109 | -------------------------------------------------------------------------------- /lib/Data/Time/Calendar/OrdinalDate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | -- | ISO 8601 Ordinal Date format 4 | module Data.Time.Calendar.OrdinalDate (Day, Year, DayOfYear, WeekOfYear, module Data.Time.Calendar.OrdinalDate) where 5 | 6 | import Data.Time.Calendar.Days 7 | import Data.Time.Calendar.Private 8 | import Data.Time.Calendar.Types 9 | 10 | -- | Convert to ISO 8601 Ordinal Date format. 11 | toOrdinalDate :: Day -> (Year, DayOfYear) 12 | toOrdinalDate (ModifiedJulianDay mjd) = (year, yd) 13 | where 14 | a = mjd + 678575 15 | quadcent = div a 146097 16 | b = mod a 146097 17 | cent = min (div b 36524) 3 18 | c = b - (cent * 36524) 19 | quad = div c 1461 20 | d = mod c 1461 21 | y = min (div d 365) 3 22 | yd = fromInteger (d - (y * 365) + 1) 23 | year = quadcent * 400 + cent * 100 + quad * 4 + y + 1 24 | 25 | -- | Convert from ISO 8601 Ordinal Date format. 26 | -- Invalid day numbers will be clipped to the correct range (1 to 365 or 366). 27 | fromOrdinalDate :: Year -> DayOfYear -> Day 28 | fromOrdinalDate year day = ModifiedJulianDay mjd 29 | where 30 | y = year - 1 31 | mjd = 32 | ( fromIntegral 33 | ( clip 34 | 1 35 | ( if isLeapYear year 36 | then 366 37 | else 365 38 | ) 39 | day 40 | ) 41 | ) 42 | + (365 * y) 43 | + (div y 4) 44 | - (div y 100) 45 | + (div y 400) 46 | - 678576 47 | 48 | -- | Bidirectional abstract constructor for ISO 8601 Ordinal Date format. 49 | -- Invalid day numbers will be clipped to the correct range (1 to 365 or 366). 50 | pattern YearDay :: Year -> DayOfYear -> Day 51 | pattern YearDay y d <- 52 | (toOrdinalDate -> (y, d)) 53 | where 54 | YearDay y d = fromOrdinalDate y d 55 | 56 | {-# COMPLETE YearDay #-} 57 | 58 | -- | Convert from ISO 8601 Ordinal Date format. 59 | -- Invalid day numbers return 'Nothing' 60 | fromOrdinalDateValid :: Year -> DayOfYear -> Maybe Day 61 | fromOrdinalDateValid year day = do 62 | day' <- 63 | clipValid 64 | 1 65 | ( if isLeapYear year 66 | then 366 67 | else 365 68 | ) 69 | day 70 | let 71 | y = year - 1 72 | mjd = (fromIntegral day') + (365 * y) + (div y 4) - (div y 100) + (div y 400) - 678576 73 | return (ModifiedJulianDay mjd) 74 | 75 | -- | Show in ISO 8601 Ordinal Date format (yyyy-ddd) 76 | showOrdinalDate :: Day -> String 77 | showOrdinalDate date = (show4 y) ++ "-" ++ (show3 d) 78 | where 79 | (y, d) = toOrdinalDate date 80 | 81 | -- | Is this year a leap year according to the proleptic Gregorian calendar? 82 | isLeapYear :: Year -> Bool 83 | isLeapYear year = (mod year 4 == 0) && ((mod year 400 == 0) || not (mod year 100 == 0)) 84 | 85 | -- | Get the number of the Monday-starting week in the year and the day of the week. 86 | -- The first Monday is the first day of week 1, any earlier days in the year are week 0 (as @%W@ in 'Data.Time.Format.formatTime'). 87 | -- Monday is 1, Sunday is 7 (as @%u@ in 'Data.Time.Format.formatTime'). 88 | mondayStartWeek :: Day -> (WeekOfYear, Int) 89 | mondayStartWeek date = (fromInteger ((div d 7) - (div k 7)), fromInteger (mod d 7) + 1) 90 | where 91 | yd = snd (toOrdinalDate date) 92 | d = (toModifiedJulianDay date) + 2 93 | k = d - (toInteger yd) 94 | 95 | -- | Get the number of the Sunday-starting week in the year and the day of the week. 96 | -- The first Sunday is the first day of week 1, any earlier days in the year are week 0 (as @%U@ in 'Data.Time.Format.formatTime'). 97 | -- Sunday is 0, Saturday is 6 (as @%w@ in 'Data.Time.Format.formatTime'). 98 | sundayStartWeek :: Day -> (WeekOfYear, Int) 99 | sundayStartWeek date = (fromInteger ((div d 7) - (div k 7)), fromInteger (mod d 7)) 100 | where 101 | yd = snd (toOrdinalDate date) 102 | d = (toModifiedJulianDay date) + 3 103 | k = d - (toInteger yd) 104 | 105 | -- | The inverse of 'mondayStartWeek'. Get a 'Day' given the year, 106 | -- the number of the Monday-starting week, and the day of the week. 107 | -- The first Monday is the first day of week 1, any earlier days in the year 108 | -- are week 0 (as @%W@ in 'Data.Time.Format.formatTime'). 109 | fromMondayStartWeek :: 110 | -- | Year. 111 | Year -> 112 | -- | Monday-starting week number (as @%W@ in 'Data.Time.Format.formatTime'). 113 | WeekOfYear -> 114 | -- | Day of week. 115 | -- Monday is 1, Sunday is 7 (as @%u@ in 'Data.Time.Format.formatTime'). 116 | Int -> 117 | Day 118 | fromMondayStartWeek year w d = 119 | let 120 | -- first day of the year 121 | firstDay = fromOrdinalDate year 1 122 | -- 0-based year day of first monday of the year 123 | zbFirstMonday = (5 - toModifiedJulianDay firstDay) `mod` 7 124 | -- 0-based week of year 125 | zbWeek = w - 1 126 | -- 0-based day of week 127 | zbDay = d - 1 128 | -- 0-based day in year 129 | zbYearDay = zbFirstMonday + 7 * toInteger zbWeek + toInteger zbDay 130 | in 131 | addDays zbYearDay firstDay 132 | 133 | fromMondayStartWeekValid :: 134 | -- | Year. 135 | Year -> 136 | -- | Monday-starting week number (as @%W@ in 'Data.Time.Format.formatTime'). 137 | WeekOfYear -> 138 | -- | Day of week. 139 | -- Monday is 1, Sunday is 7 (as @%u@ in 'Data.Time.Format.formatTime'). 140 | Int -> 141 | Maybe Day 142 | fromMondayStartWeekValid year w d = do 143 | d' <- clipValid 1 7 d 144 | let 145 | -- first day of the year 146 | firstDay = fromOrdinalDate year 1 147 | -- 0-based week of year 148 | zbFirstMonday = (5 - toModifiedJulianDay firstDay) `mod` 7 149 | -- 0-based week number 150 | zbWeek = w - 1 151 | -- 0-based day of week 152 | zbDay = d' - 1 153 | -- 0-based day in year 154 | zbYearDay = zbFirstMonday + 7 * toInteger zbWeek + toInteger zbDay 155 | zbYearDay' <- 156 | clipValid 157 | 0 158 | ( if isLeapYear year 159 | then 365 160 | else 364 161 | ) 162 | zbYearDay 163 | return $ addDays zbYearDay' firstDay 164 | 165 | -- | The inverse of 'sundayStartWeek'. Get a 'Day' given the year and 166 | -- the number of the day of a Sunday-starting week. 167 | -- The first Sunday is the first day of week 1, any earlier days in the 168 | -- year are week 0 (as @%U@ in 'Data.Time.Format.formatTime'). 169 | fromSundayStartWeek :: 170 | -- | Year. 171 | Year -> 172 | -- | Sunday-starting week number (as @%U@ in 'Data.Time.Format.formatTime'). 173 | WeekOfYear -> 174 | -- | Day of week 175 | -- Sunday is 0, Saturday is 6 (as @%w@ in 'Data.Time.Format.formatTime'). 176 | Int -> 177 | Day 178 | fromSundayStartWeek year w d = 179 | let 180 | -- first day of the year 181 | firstDay = fromOrdinalDate year 1 182 | -- 0-based year day of first monday of the year 183 | zbFirstSunday = (4 - toModifiedJulianDay firstDay) `mod` 7 184 | -- 0-based week of year 185 | zbWeek = w - 1 186 | -- 0-based day of week 187 | zbDay = d 188 | -- 0-based day in year 189 | zbYearDay = zbFirstSunday + 7 * toInteger zbWeek + toInteger zbDay 190 | in 191 | addDays zbYearDay firstDay 192 | 193 | fromSundayStartWeekValid :: 194 | -- | Year. 195 | Year -> 196 | -- | Sunday-starting week number (as @%U@ in 'Data.Time.Format.formatTime'). 197 | WeekOfYear -> 198 | -- | Day of week. 199 | -- Sunday is 0, Saturday is 6 (as @%w@ in 'Data.Time.Format.formatTime'). 200 | Int -> 201 | Maybe Day 202 | fromSundayStartWeekValid year w d = do 203 | d' <- clipValid 0 6 d 204 | let 205 | -- first day of the year 206 | firstDay = fromOrdinalDate year 1 207 | -- 0-based week of year 208 | zbFirstSunday = (4 - toModifiedJulianDay firstDay) `mod` 7 209 | -- 0-based week number 210 | zbWeek = w - 1 211 | -- 0-based day of week 212 | zbDay = d' 213 | -- 0-based day in year 214 | zbYearDay = zbFirstSunday + 7 * toInteger zbWeek + toInteger zbDay 215 | zbYearDay' <- 216 | clipValid 217 | 0 218 | ( if isLeapYear year 219 | then 365 220 | else 364 221 | ) 222 | zbYearDay 223 | return $ addDays zbYearDay' firstDay 224 | -------------------------------------------------------------------------------- /lib/Data/Time/Calendar/Private.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.Calendar.Private where 4 | 5 | import Data.Fixed 6 | 7 | data PadOption 8 | = Pad 9 | Int 10 | Char 11 | | NoPad 12 | 13 | showPadded :: PadOption -> String -> String 14 | showPadded NoPad s = s 15 | showPadded (Pad i c) s = replicate (i - length s) c ++ s 16 | 17 | class (Num t, Ord t, Show t) => ShowPadded t where 18 | showPaddedNum :: PadOption -> t -> String 19 | 20 | instance ShowPadded Integer where 21 | showPaddedNum NoPad i = show i 22 | showPaddedNum pad i 23 | | i < 0 = '-' : (showPaddedNum pad (negate i)) 24 | showPaddedNum pad i = showPadded pad $ show i 25 | 26 | instance ShowPadded Int where 27 | showPaddedNum NoPad i = show i 28 | showPaddedNum _pad i 29 | | i == minBound = show i 30 | showPaddedNum pad i 31 | | i < 0 = '-' : (showPaddedNum pad (negate i)) 32 | showPaddedNum pad i = showPadded pad $ show i 33 | 34 | show2Fixed :: Pico -> String 35 | show2Fixed x 36 | | x < 10 = '0' : (showFixed True x) 37 | show2Fixed x = showFixed True x 38 | 39 | show2 :: ShowPadded t => t -> String 40 | show2 = showPaddedNum $ Pad 2 '0' 41 | 42 | show3 :: ShowPadded t => t -> String 43 | show3 = showPaddedNum $ Pad 3 '0' 44 | 45 | show4 :: ShowPadded t => t -> String 46 | show4 = showPaddedNum $ Pad 4 '0' 47 | 48 | mod100 :: Integral i => i -> i 49 | mod100 x = mod x 100 50 | 51 | div100 :: Integral i => i -> i 52 | div100 x = div x 100 53 | 54 | clip :: Ord t => t -> t -> t -> t 55 | clip a _ x 56 | | x < a = a 57 | clip _ b x 58 | | x > b = b 59 | clip _ _ x = x 60 | 61 | clipValid :: Ord t => t -> t -> t -> Maybe t 62 | clipValid a _ x 63 | | x < a = Nothing 64 | clipValid _ b x 65 | | x > b = Nothing 66 | clipValid _ _ x = Just x 67 | 68 | quotBy :: (Real a, Integral b) => a -> a -> b 69 | quotBy d n = truncate ((toRational n) / (toRational d)) 70 | 71 | remBy :: Real a => a -> a -> a 72 | remBy d n = n - (fromInteger f) * d 73 | where 74 | f = quotBy d n 75 | 76 | quotRemBy :: (Real a, Integral b) => a -> a -> (b, a) 77 | quotRemBy d n = 78 | let 79 | f = quotBy d n 80 | in 81 | (f, n - (fromIntegral f) * d) 82 | -------------------------------------------------------------------------------- /lib/Data/Time/Calendar/Quarter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | -- | Year quarters. 4 | module Data.Time.Calendar.Quarter ( 5 | QuarterOfYear (..), 6 | addQuarters, 7 | diffQuarters, 8 | Quarter (..), 9 | pattern YearQuarter, 10 | monthOfYearQuarter, 11 | monthQuarter, 12 | dayQuarter, 13 | DayOfQuarter, 14 | pattern QuarterDay, 15 | ) where 16 | 17 | import Control.DeepSeq 18 | import Data.Data 19 | import Data.Fixed 20 | import Data.Ix 21 | import Data.Time.Calendar.Days 22 | import Data.Time.Calendar.Month 23 | import Data.Time.Calendar.Private 24 | import Data.Time.Calendar.Types 25 | import GHC.Generics 26 | import qualified Language.Haskell.TH.Syntax as TH 27 | import Text.ParserCombinators.ReadP 28 | import Text.Read 29 | 30 | -- | Quarters of each year. Each quarter corresponds to three months. 31 | data QuarterOfYear = Q1 | Q2 | Q3 | Q4 deriving (Eq, Ord, Read, Show, Ix, Typeable, Data, Generic, TH.Lift) 32 | 33 | -- | maps Q1..Q4 to 1..4 34 | instance Enum QuarterOfYear where 35 | toEnum i = 36 | case mod' i 4 of 37 | 1 -> Q1 38 | 2 -> Q2 39 | 3 -> Q3 40 | _ -> Q4 41 | fromEnum Q1 = 1 42 | fromEnum Q2 = 2 43 | fromEnum Q3 = 3 44 | fromEnum Q4 = 4 45 | 46 | instance Bounded QuarterOfYear where 47 | minBound = Q1 48 | maxBound = Q4 49 | 50 | instance NFData QuarterOfYear where 51 | rnf Q1 = () 52 | rnf Q2 = () 53 | rnf Q3 = () 54 | rnf Q4 = () 55 | 56 | -- | An absolute count of year quarters. 57 | -- Number is equal to @(year * 4) + (quarterOfYear - 1)@. 58 | newtype Quarter = MkQuarter Integer deriving (Eq, Ord, Typeable, Data, Generic, TH.Lift) 59 | 60 | instance NFData Quarter where 61 | rnf (MkQuarter m) = rnf m 62 | 63 | instance Enum Quarter where 64 | succ (MkQuarter a) = MkQuarter (succ a) 65 | pred (MkQuarter a) = MkQuarter (pred a) 66 | toEnum = MkQuarter . toEnum 67 | fromEnum (MkQuarter a) = fromEnum a 68 | enumFrom (MkQuarter a) = fmap MkQuarter (enumFrom a) 69 | enumFromThen (MkQuarter a) (MkQuarter b) = fmap MkQuarter (enumFromThen a b) 70 | enumFromTo (MkQuarter a) (MkQuarter b) = fmap MkQuarter (enumFromTo a b) 71 | enumFromThenTo (MkQuarter a) (MkQuarter b) (MkQuarter c) = 72 | fmap MkQuarter (enumFromThenTo a b c) 73 | 74 | instance Ix Quarter where 75 | range (MkQuarter a, MkQuarter b) = fmap MkQuarter (range (a, b)) 76 | index (MkQuarter a, MkQuarter b) (MkQuarter c) = index (a, b) c 77 | inRange (MkQuarter a, MkQuarter b) (MkQuarter c) = inRange (a, b) c 78 | rangeSize (MkQuarter a, MkQuarter b) = rangeSize (a, b) 79 | 80 | -- | Show as @yyyy-Qn@. 81 | instance Show Quarter where 82 | show (YearQuarter y qy) = show4 y ++ "-" ++ show qy 83 | 84 | -- | Read as @yyyy-Qn@. 85 | instance Read Quarter where 86 | readPrec = do 87 | y <- readPrec 88 | _ <- lift $ char '-' 89 | m <- readPrec 90 | return $ YearQuarter y m 91 | 92 | instance DayPeriod Quarter where 93 | periodFirstDay (YearQuarter y q) = 94 | case q of 95 | Q1 -> periodFirstDay $ YearMonth y January 96 | Q2 -> periodFirstDay $ YearMonth y April 97 | Q3 -> periodFirstDay $ YearMonth y July 98 | Q4 -> periodFirstDay $ YearMonth y October 99 | periodLastDay (YearQuarter y q) = 100 | case q of 101 | Q1 -> periodLastDay $ YearMonth y March 102 | Q2 -> periodLastDay $ YearMonth y June 103 | Q3 -> periodLastDay $ YearMonth y September 104 | Q4 -> periodLastDay $ YearMonth y December 105 | dayPeriod (MonthDay m _) = monthQuarter m 106 | 107 | addQuarters :: Integer -> Quarter -> Quarter 108 | addQuarters n (MkQuarter a) = MkQuarter $ a + n 109 | 110 | diffQuarters :: Quarter -> Quarter -> Integer 111 | diffQuarters (MkQuarter a) (MkQuarter b) = a - b 112 | 113 | -- | Bidirectional abstract constructor. 114 | pattern YearQuarter :: Year -> QuarterOfYear -> Quarter 115 | pattern YearQuarter y qy <- 116 | MkQuarter ((\q -> divMod' q 4) -> (y, (toEnum . succ . fromInteger -> qy))) 117 | where 118 | YearQuarter y qy = MkQuarter $ (y * 4) + toInteger (pred $ fromEnum qy) 119 | 120 | {-# COMPLETE YearQuarter #-} 121 | 122 | -- | The 'QuarterOfYear' this 'MonthOfYear' is in. 123 | monthOfYearQuarter :: MonthOfYear -> QuarterOfYear 124 | monthOfYearQuarter my | my <= 3 = Q1 125 | monthOfYearQuarter my | my <= 6 = Q2 126 | monthOfYearQuarter my | my <= 9 = Q3 127 | monthOfYearQuarter _ = Q4 128 | 129 | -- | The 'Quarter' this 'Month' is in. 130 | monthQuarter :: Month -> Quarter 131 | monthQuarter (YearMonth y my) = YearQuarter y $ monthOfYearQuarter my 132 | 133 | -- | The 'Quarter' this 'Day' is in. 134 | dayQuarter :: Day -> Quarter 135 | dayQuarter = dayPeriod 136 | 137 | -- | Bidirectional abstract constructor. 138 | -- Invalid days of quarter will be clipped to the correct range. 139 | -- 140 | -- @since 1.12.1 141 | pattern QuarterDay :: Quarter -> DayOfQuarter -> Day 142 | pattern QuarterDay q dq <- 143 | (periodFromDay -> (q, dq)) 144 | where 145 | QuarterDay = periodToDay 146 | 147 | {-# COMPLETE QuarterDay #-} 148 | -------------------------------------------------------------------------------- /lib/Data/Time/Calendar/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.Calendar.Types where 4 | 5 | -- | Year of Common Era (when positive). 6 | type Year = Integer 7 | 8 | -- | Also known as Anno Domini. 9 | pattern CommonEra :: Integer -> Year 10 | pattern CommonEra n <- 11 | ((\y -> if y > 0 then Just y else Nothing) -> Just n) 12 | where 13 | CommonEra n = n 14 | 15 | -- | Also known as Before Christ. 16 | -- Note that Year 1 = 1 CE, and the previous Year 0 = 1 BCE. 17 | -- 'CommonEra' and 'BeforeCommonEra' form a @COMPLETE@ set. 18 | pattern BeforeCommonEra :: Integer -> Year 19 | pattern BeforeCommonEra n <- 20 | ((\y -> if y <= 0 then Just (1 - y) else Nothing) -> Just n) 21 | where 22 | BeforeCommonEra n = 1 - n 23 | 24 | {-# COMPLETE CommonEra, BeforeCommonEra #-} 25 | 26 | -- | Month of year, in range 1 (January) to 12 (December). 27 | type MonthOfYear = Int 28 | 29 | pattern January :: MonthOfYear 30 | pattern January = 1 31 | 32 | pattern February :: MonthOfYear 33 | pattern February = 2 34 | 35 | pattern March :: MonthOfYear 36 | pattern March = 3 37 | 38 | pattern April :: MonthOfYear 39 | pattern April = 4 40 | 41 | pattern May :: MonthOfYear 42 | pattern May = 5 43 | 44 | pattern June :: MonthOfYear 45 | pattern June = 6 46 | 47 | pattern July :: MonthOfYear 48 | pattern July = 7 49 | 50 | pattern August :: MonthOfYear 51 | pattern August = 8 52 | 53 | pattern September :: MonthOfYear 54 | pattern September = 9 55 | 56 | pattern October :: MonthOfYear 57 | pattern October = 10 58 | 59 | pattern November :: MonthOfYear 60 | pattern November = 11 61 | 62 | -- | The twelve 'MonthOfYear' patterns form a @COMPLETE@ set. 63 | pattern December :: MonthOfYear 64 | pattern December = 12 65 | 66 | {-# COMPLETE January, February, March, April, May, June, July, August, September, October, November, December #-} 67 | 68 | -- | Day of month, in range 1 to 31. 69 | type DayOfMonth = Int 70 | 71 | -- | Day of quarter, in range 1 to 92. 72 | type DayOfQuarter = Int 73 | 74 | -- | Day of year, in range 1 (January 1st) to 366. 75 | -- December 31st is 365 in a common year, 366 in a leap year. 76 | type DayOfYear = Int 77 | 78 | -- | Week of year, by various reckonings, generally in range 0-53 depending on reckoning. 79 | type WeekOfYear = Int 80 | -------------------------------------------------------------------------------- /lib/Data/Time/Calendar/Week.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.Calendar.Week ( 4 | -- * Week 5 | DayOfWeek (..), 6 | dayOfWeek, 7 | dayOfWeekDiff, 8 | firstDayOfWeekOnAfter, 9 | weekAllDays, 10 | weekFirstDay, 11 | weekLastDay, 12 | ) where 13 | 14 | import Control.DeepSeq 15 | import Data.Data 16 | import Data.Fixed 17 | import Data.Ix 18 | import Data.Time.Calendar.Days 19 | import GHC.Generics 20 | import qualified Language.Haskell.TH.Syntax as TH 21 | 22 | data DayOfWeek 23 | = Monday 24 | | Tuesday 25 | | Wednesday 26 | | Thursday 27 | | Friday 28 | | Saturday 29 | | Sunday 30 | deriving (Eq, Ord, Ix, Show, Read, Typeable, Data, Generic, TH.Lift) 31 | 32 | instance NFData DayOfWeek where 33 | rnf Monday = () 34 | rnf Tuesday = () 35 | rnf Wednesday = () 36 | rnf Thursday = () 37 | rnf Friday = () 38 | rnf Saturday = () 39 | rnf Sunday = () 40 | 41 | -- | \"Circular\", so for example @[Tuesday ..]@ gives an endless sequence. 42 | -- Also: 'fromEnum' gives [1 .. 7] for [Monday .. Sunday], and 'toEnum' performs mod 7 to give a cycle of days. 43 | instance Enum DayOfWeek where 44 | toEnum i = case mod i 7 of 45 | 0 -> Sunday 46 | 1 -> Monday 47 | 2 -> Tuesday 48 | 3 -> Wednesday 49 | 4 -> Thursday 50 | 5 -> Friday 51 | _ -> Saturday 52 | fromEnum Monday = 1 53 | fromEnum Tuesday = 2 54 | fromEnum Wednesday = 3 55 | fromEnum Thursday = 4 56 | fromEnum Friday = 5 57 | fromEnum Saturday = 6 58 | fromEnum Sunday = 7 59 | enumFromTo wd1 wd2 60 | | wd1 == wd2 = [wd1] 61 | enumFromTo wd1 wd2 = wd1 : enumFromTo (succ wd1) wd2 62 | enumFromThenTo wd1 wd2 wd3 63 | | wd2 == wd3 = [wd1, wd2] 64 | enumFromThenTo wd1 wd2 wd3 = wd1 : enumFromThenTo wd2 (toEnum $ (2 * fromEnum wd2) - (fromEnum wd1)) wd3 65 | 66 | dayOfWeek :: Day -> DayOfWeek 67 | dayOfWeek (ModifiedJulianDay d) = toEnum $ fromInteger $ d + 3 68 | 69 | -- | @dayOfWeekDiff a b = a - b@ in range 0 to 6. 70 | -- The number of days from b to the next a. 71 | dayOfWeekDiff :: DayOfWeek -> DayOfWeek -> Int 72 | dayOfWeekDiff a b = mod' (fromEnum a - fromEnum b) 7 73 | 74 | -- | The first day-of-week on or after some day 75 | firstDayOfWeekOnAfter :: DayOfWeek -> Day -> Day 76 | firstDayOfWeekOnAfter dw d = addDays (toInteger $ dayOfWeekDiff dw $ dayOfWeek d) d 77 | 78 | -- | Returns a week containing the given 'Day' where the first day is the 79 | -- 'DayOfWeek' specified. 80 | -- 81 | -- Examples: 82 | -- 83 | -- >>> weekAllDays Sunday (YearMonthDay 2022 02 21) 84 | -- [YearMonthDay 2022 2 20 .. YearMonthDay 2022 2 26] 85 | -- 86 | -- >>> weekAllDays Monday (YearMonthDay 2022 02 21) 87 | -- [YearMonthDay 2022 2 21 .. YearMonthDay 2022 2 27] 88 | -- 89 | -- >>> weekAllDays Tuesday (YearMonthDay 2022 02 21) 90 | -- [YearMonthDay 2022 2 15 .. YearMonthDay 2022 2 21] 91 | -- 92 | -- @since 1.12.2 93 | weekAllDays :: DayOfWeek -> Day -> [Day] 94 | weekAllDays firstDay day = [weekFirstDay firstDay day .. weekLastDay firstDay day] 95 | 96 | -- | Returns the first day of a week containing the given 'Day'. 97 | -- 98 | -- Examples: 99 | -- 100 | -- >>> weekFirstDay Sunday (YearMonthDay 2022 02 21) 101 | -- YearMonthDay 2022 2 20 102 | -- 103 | -- >>> weekFirstDay Monday (YearMonthDay 2022 02 21) 104 | -- YearMonthDay 2022 2 21 105 | -- 106 | -- >>> weekFirstDay Tuesday (YearMonthDay 2022 02 21) 107 | -- YearMonthDay 2022 2 15 108 | -- 109 | -- @since 1.12.2 110 | weekFirstDay :: DayOfWeek -> Day -> Day 111 | weekFirstDay firstDay day = addDays (negate 7) $ firstDayOfWeekOnAfter firstDay $ succ day 112 | 113 | -- | Returns the last day of a week containing the given 'Day'. 114 | -- 115 | -- Examples: 116 | -- 117 | -- >>> weekLastDay Sunday (YearMonthDay 2022 02 21) 118 | -- YearMonthDay 2022 2 26 119 | -- 120 | -- >>> weekLastDay Monday (YearMonthDay 2022 02 21) 121 | -- YearMonthDay 2022 2 27 122 | -- 123 | -- >>> weekLastDay Tuesday (YearMonthDay 2022 02 21) 124 | -- YearMonthDay 2022 2 21 125 | -- 126 | -- @since 1.12.2 127 | weekLastDay :: DayOfWeek -> Day -> Day 128 | weekLastDay firstDay day = pred $ firstDayOfWeekOnAfter firstDay $ succ day 129 | -------------------------------------------------------------------------------- /lib/Data/Time/Calendar/WeekDate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | -- | Week-based calendars 4 | module Data.Time.Calendar.WeekDate ( 5 | Year, 6 | WeekOfYear, 7 | DayOfWeek (..), 8 | dayOfWeek, 9 | FirstWeekType (..), 10 | toWeekCalendar, 11 | fromWeekCalendar, 12 | fromWeekCalendarValid, 13 | 14 | -- * ISO 8601 Week Date format 15 | toWeekDate, 16 | fromWeekDate, 17 | pattern YearWeekDay, 18 | fromWeekDateValid, 19 | showWeekDate, 20 | ) where 21 | 22 | import Data.Time.Calendar.Days 23 | import Data.Time.Calendar.OrdinalDate 24 | import Data.Time.Calendar.Private 25 | import Data.Time.Calendar.Week 26 | import qualified Language.Haskell.TH.Syntax as TH 27 | 28 | data FirstWeekType 29 | = -- | first week is the first whole week of the year 30 | FirstWholeWeek 31 | | -- | first week is the first week with four days in the year 32 | FirstMostWeek 33 | deriving (Eq, TH.Lift) 34 | 35 | firstDayOfWeekCalendar :: FirstWeekType -> DayOfWeek -> Year -> Day 36 | firstDayOfWeekCalendar wt dow year = 37 | let 38 | jan1st = fromOrdinalDate year 1 39 | in 40 | case wt of 41 | FirstWholeWeek -> firstDayOfWeekOnAfter dow jan1st 42 | FirstMostWeek -> firstDayOfWeekOnAfter dow $ addDays (-3) jan1st 43 | 44 | -- | Convert to the given kind of "week calendar". 45 | -- Note that the year number matches the weeks, and so is not always the same as the Gregorian year number. 46 | toWeekCalendar :: 47 | -- | how to reckon the first week of the year 48 | FirstWeekType -> 49 | -- | the first day of each week 50 | DayOfWeek -> 51 | Day -> 52 | (Year, WeekOfYear, DayOfWeek) 53 | toWeekCalendar wt ws d = 54 | let 55 | dw = dayOfWeek d 56 | (y0, _) = toOrdinalDate d 57 | j1p = firstDayOfWeekCalendar wt ws $ pred y0 58 | j1 = firstDayOfWeekCalendar wt ws y0 59 | j1s = firstDayOfWeekCalendar wt ws $ succ y0 60 | in 61 | if d < j1 62 | then (pred y0, succ $ div (fromInteger $ diffDays d j1p) 7, dw) 63 | else 64 | if d < j1s 65 | then (y0, succ $ div (fromInteger $ diffDays d j1) 7, dw) 66 | else (succ y0, succ $ div (fromInteger $ diffDays d j1s) 7, dw) 67 | 68 | -- | Convert from the given kind of "week calendar". 69 | -- Invalid week and day values will be clipped to the correct range. 70 | fromWeekCalendar :: 71 | -- | how to reckon the first week of the year 72 | FirstWeekType -> 73 | -- | the first day of each week 74 | DayOfWeek -> 75 | Year -> 76 | WeekOfYear -> 77 | DayOfWeek -> 78 | Day 79 | fromWeekCalendar wt ws y wy dw = 80 | let 81 | d1 :: Day 82 | d1 = firstDayOfWeekCalendar wt ws y 83 | wy' = clip 1 53 wy 84 | getday :: WeekOfYear -> Day 85 | getday wy'' = addDays (toInteger $ (pred wy'' * 7) + (dayOfWeekDiff dw ws)) d1 86 | d1s = firstDayOfWeekCalendar wt ws $ succ y 87 | day = getday wy' 88 | in 89 | if wy' == 53 then if day >= d1s then getday 52 else day else day 90 | 91 | -- | Convert from the given kind of "week calendar". 92 | -- Invalid week and day values will return Nothing. 93 | fromWeekCalendarValid :: 94 | -- | how to reckon the first week of the year 95 | FirstWeekType -> 96 | -- | the first day of each week 97 | DayOfWeek -> 98 | Year -> 99 | WeekOfYear -> 100 | DayOfWeek -> 101 | Maybe Day 102 | fromWeekCalendarValid wt ws y wy dw = 103 | let 104 | d = fromWeekCalendar wt ws y wy dw 105 | in 106 | if toWeekCalendar wt ws d == (y, wy, dw) then Just d else Nothing 107 | 108 | -- | Convert to ISO 8601 Week Date format. First element of result is year, second week number (1-53), third day of week (1 for Monday to 7 for Sunday). 109 | -- Note that \"Week\" years are not quite the same as Gregorian years, as the first day of the year is always a Monday. 110 | -- The first week of a year is the first week to contain at least four days in the corresponding Gregorian year. 111 | toWeekDate :: Day -> (Year, WeekOfYear, Int) 112 | toWeekDate d = 113 | let 114 | (y, wy, dw) = toWeekCalendar FirstMostWeek Monday d 115 | in 116 | (y, wy, fromEnum dw) 117 | 118 | -- | Convert from ISO 8601 Week Date format. First argument is year, second week number (1-52 or 53), third day of week (1 for Monday to 7 for Sunday). 119 | -- Invalid week and day values will be clipped to the correct range. 120 | fromWeekDate :: Year -> WeekOfYear -> Int -> Day 121 | fromWeekDate y wy dw = fromWeekCalendar FirstMostWeek Monday y wy (toEnum $ clip 1 7 dw) 122 | 123 | -- | Bidirectional abstract constructor for ISO 8601 Week Date format. 124 | -- Invalid week values will be clipped to the correct range. 125 | pattern YearWeekDay :: Year -> WeekOfYear -> DayOfWeek -> Day 126 | pattern YearWeekDay y wy dw <- 127 | (toWeekDate -> (y, wy, (toEnum -> dw))) 128 | where 129 | YearWeekDay y wy dw = fromWeekDate y wy (fromEnum dw) 130 | 131 | {-# COMPLETE YearWeekDay #-} 132 | 133 | -- | Convert from ISO 8601 Week Date format. First argument is year, second week number (1-52 or 53), third day of week (1 for Monday to 7 for Sunday). 134 | -- Invalid week and day values will return Nothing. 135 | fromWeekDateValid :: Year -> WeekOfYear -> Int -> Maybe Day 136 | fromWeekDateValid y wy dwr = do 137 | dw <- clipValid 1 7 dwr 138 | fromWeekCalendarValid FirstMostWeek Monday y wy (toEnum dw) 139 | 140 | -- | Show in ISO 8601 Week Date format as yyyy-Www-d (e.g. \"2006-W46-3\"). 141 | showWeekDate :: Day -> String 142 | showWeekDate date = (show4 y) ++ "-W" ++ (show2 w) ++ "-" ++ (show d) 143 | where 144 | (y, w, d) = toWeekDate date 145 | -------------------------------------------------------------------------------- /lib/Data/Time/Clock.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | -- | Types and functions for UTC and UT1 4 | module Data.Time.Clock ( 5 | module Data.Time.Clock.Internal.UniversalTime, 6 | module Data.Time.Clock.Internal.DiffTime, 7 | module Data.Time.Clock.Internal.UTCTime, 8 | module Data.Time.Clock.Internal.NominalDiffTime, 9 | module Data.Time.Clock.Internal.UTCDiff, 10 | getCurrentTime, 11 | getTime_resolution, 12 | ) where 13 | 14 | import Data.Time.Clock.Internal.DiffTime 15 | import Data.Time.Clock.Internal.NominalDiffTime 16 | import Data.Time.Clock.Internal.SystemTime 17 | import Data.Time.Clock.Internal.UTCDiff 18 | import Data.Time.Clock.Internal.UTCTime 19 | import Data.Time.Clock.Internal.UniversalTime 20 | import Data.Time.Clock.POSIX 21 | import Data.Time.Format.Parse () 22 | import Data.Time.LocalTime () 23 | -------------------------------------------------------------------------------- /lib/Data/Time/Clock/Internal/AbsoluteTime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | -- | TAI and leap-second maps for converting to UTC: most people won't need this module. 4 | module Data.Time.Clock.Internal.AbsoluteTime ( 5 | -- TAI arithmetic 6 | AbsoluteTime, 7 | taiEpoch, 8 | addAbsoluteTime, 9 | diffAbsoluteTime, 10 | taiNominalDayStart, 11 | ) where 12 | 13 | import Control.DeepSeq 14 | import Data.Data 15 | import Data.Time.Calendar.Days 16 | import Data.Time.Clock.Internal.DiffTime 17 | import qualified Language.Haskell.TH.Syntax as TH 18 | 19 | -- | AbsoluteTime is TAI, time as measured by a clock. 20 | newtype AbsoluteTime 21 | = MkAbsoluteTime DiffTime 22 | deriving (Eq, Ord, Typeable, Data, TH.Lift) 23 | 24 | instance NFData AbsoluteTime where 25 | rnf (MkAbsoluteTime a) = rnf a 26 | 27 | -- | The epoch of TAI, which is 1858-11-17 00:00:00 TAI. 28 | taiEpoch :: AbsoluteTime 29 | taiEpoch = MkAbsoluteTime 0 30 | 31 | taiNominalDayStart :: Day -> AbsoluteTime 32 | taiNominalDayStart day = MkAbsoluteTime $ realToFrac $ (toModifiedJulianDay day) * 86400 33 | 34 | -- | addAbsoluteTime a b = a + b 35 | addAbsoluteTime :: DiffTime -> AbsoluteTime -> AbsoluteTime 36 | addAbsoluteTime t (MkAbsoluteTime a) = MkAbsoluteTime (a + t) 37 | 38 | -- | diffAbsoluteTime a b = a - b 39 | diffAbsoluteTime :: AbsoluteTime -> AbsoluteTime -> DiffTime 40 | diffAbsoluteTime (MkAbsoluteTime a) (MkAbsoluteTime b) = a - b 41 | -------------------------------------------------------------------------------- /lib/Data/Time/Clock/Internal/CTimespec.hsc: -------------------------------------------------------------------------------- 1 | #if !defined(javascript_HOST_ARCH) 2 | {-# LANGUAGE CApiFFI #-} 3 | #endif 4 | 5 | module Data.Time.Clock.Internal.CTimespec where 6 | 7 | #include "HsTimeConfig.h" 8 | 9 | #if !defined(mingw32_HOST_OS) && HAVE_CLOCK_GETTIME && !defined(__MHS__) 10 | 11 | import Foreign 12 | import Foreign.C 13 | import System.IO.Unsafe 14 | import System.Posix.Types 15 | 16 | #include 17 | 18 | type ClockID = CClockId 19 | 20 | data CTimespec = MkCTimespec CTime CLong 21 | 22 | instance Storable CTimespec where 23 | sizeOf _ = #{size struct timespec} 24 | alignment _ = alignment (undefined :: CLong) 25 | peek p = do 26 | s <- #{peek struct timespec, tv_sec } p 27 | ns <- #{peek struct timespec, tv_nsec} p 28 | return (MkCTimespec s ns) 29 | poke p (MkCTimespec s ns) = do 30 | #{poke struct timespec, tv_sec } p s 31 | #{poke struct timespec, tv_nsec} p ns 32 | 33 | #if defined(javascript_HOST_ARCH) 34 | 35 | foreign import ccall unsafe "time.h clock_gettime" 36 | clock_gettime :: ClockID -> Ptr CTimespec -> IO CInt 37 | 38 | #else /* defined(javascript_HOST_ARCH) */ 39 | 40 | foreign import capi unsafe "time.h clock_gettime" 41 | clock_gettime :: ClockID -> Ptr CTimespec -> IO CInt 42 | 43 | #endif /* defined(javascript_HOST_ARCH) */ 44 | 45 | -- | Get the current time from the given clock. 46 | clockGetTime :: ClockID -> IO CTimespec 47 | clockGetTime clockid = alloca (\ptspec -> do 48 | throwErrnoIfMinus1_ "clock_gettime" $ clock_gettime clockid ptspec 49 | peek ptspec 50 | ) 51 | 52 | #if defined(javascript_HOST_ARCH) 53 | 54 | clockGetRes :: ClockID -> IO (Either Errno CTimespec) 55 | clockGetRes _ = return $ Right $ MkCTimespec 0 0 56 | 57 | #else /* defined(javascript_HOST_ARCH) */ 58 | 59 | foreign import capi unsafe "time.h clock_getres" 60 | clock_getres :: ClockID -> Ptr CTimespec -> IO CInt 61 | 62 | -- | Get the resolution of the given clock. 63 | clockGetRes :: ClockID -> IO (Either Errno CTimespec) 64 | clockGetRes clockid = alloca $ \ptspec -> do 65 | rc <- clock_getres clockid ptspec 66 | case rc of 67 | 0 -> do 68 | res <- peek ptspec 69 | return $ Right res 70 | _ -> do 71 | errno <- getErrno 72 | return $ Left errno 73 | 74 | #endif /* defined(javascript_HOST_ARCH) */ 75 | 76 | #if defined(javascript_HOST_ARCH) 77 | -- JS backend doesn't support foreign imports with capi convention 78 | clock_REALTIME :: ClockID 79 | clock_REALTIME = #{const CLOCK_REALTIME} 80 | #else /* defined(javascript_HOST_ARCH) */ 81 | foreign import capi unsafe "HsTime.h value HS_CLOCK_REALTIME" clock_REALTIME :: ClockID 82 | #endif /* defined(javascript_HOST_ARCH) */ 83 | 84 | clock_TAI :: Maybe ClockID 85 | clock_TAI = 86 | #if defined(CLOCK_TAI) 87 | Just #{const CLOCK_TAI} 88 | #else /* defined(CLOCK_TAI) */ 89 | Nothing 90 | #endif /* defined(CLOCK_TAI) */ 91 | 92 | realtimeRes :: CTimespec 93 | realtimeRes = unsafePerformIO $ do 94 | mres <- clockGetRes clock_REALTIME 95 | case mres of 96 | Left errno -> ioError (errnoToIOError "clock_getres" errno Nothing Nothing) 97 | Right res -> return res 98 | 99 | clockResolution :: ClockID -> Maybe CTimespec 100 | clockResolution clockid = unsafePerformIO $ do 101 | mres <- clockGetRes clockid 102 | case mres of 103 | Left _ -> return Nothing 104 | Right res -> return $ Just res 105 | 106 | #endif /* !defined(mingw32_HOST_OS) && HAVE_CLOCK_GETTIME */ 107 | 108 | -------------------------------------------------------------------------------- /lib/Data/Time/Clock/Internal/CTimeval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Safe #-} 3 | #if !defined(javascript_HOST_ARCH) 4 | {-# LANGUAGE CApiFFI #-} 5 | #endif 6 | 7 | module Data.Time.Clock.Internal.CTimeval where 8 | 9 | #ifndef mingw32_HOST_OS 10 | -- All Unix-specific, this 11 | import Foreign 12 | import Foreign.C 13 | 14 | data CTimeval = 15 | MkCTimeval CLong 16 | CLong 17 | 18 | instance Storable CTimeval where 19 | sizeOf _ = (sizeOf (undefined :: CLong)) * 2 20 | alignment _ = alignment (undefined :: CLong) 21 | peek p = do 22 | s <- peekElemOff (castPtr p) 0 23 | mus <- peekElemOff (castPtr p) 1 24 | return (MkCTimeval s mus) 25 | poke p (MkCTimeval s mus) = do 26 | pokeElemOff (castPtr p) 0 s 27 | pokeElemOff (castPtr p) 1 mus 28 | 29 | #if defined(javascript_HOST_ARCH) || defined(__MHS__) 30 | 31 | foreign import ccall unsafe "sys/time.h gettimeofday" gettimeofday :: Ptr CTimeval -> Ptr () -> IO CInt 32 | 33 | #else 34 | 35 | foreign import capi unsafe "sys/time.h gettimeofday" gettimeofday :: Ptr CTimeval -> Ptr () -> IO CInt 36 | 37 | #endif 38 | 39 | -- | Get the current POSIX time from the system clock. 40 | getCTimeval :: IO CTimeval 41 | getCTimeval = 42 | with 43 | (MkCTimeval 0 0) 44 | (\ptval -> do 45 | throwErrnoIfMinus1_ "gettimeofday" $ gettimeofday ptval nullPtr 46 | peek ptval) 47 | #endif 48 | -------------------------------------------------------------------------------- /lib/Data/Time/Clock/Internal/DiffTime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE InstanceSigs #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE Trustworthy #-} 6 | 7 | module Data.Time.Clock.Internal.DiffTime ( 8 | -- * Absolute intervals 9 | DiffTime, 10 | secondsToDiffTime, 11 | picosecondsToDiffTime, 12 | diffTimeToPicoseconds, 13 | ) where 14 | 15 | import Control.DeepSeq 16 | import Data.Data 17 | import Data.Fixed 18 | #ifdef __GLASGOW_HASKELL__ 19 | import GHC.Read 20 | #endif 21 | import qualified Language.Haskell.TH.Syntax as TH 22 | import Text.ParserCombinators.ReadP 23 | import Text.Read 24 | 25 | -- | This is a length of time, as measured by a clock. 26 | -- Conversion functions such as 'fromInteger' and 'realToFrac' will treat it as seconds. 27 | -- For example, @(0.010 :: DiffTime)@ corresponds to 10 milliseconds. 28 | -- 29 | -- It has a precision of one picosecond (= 10^-12 s). Enumeration functions will treat it as picoseconds. 30 | newtype DiffTime 31 | = MkDiffTime Pico 32 | deriving (Eq, Ord, Typeable, Data, TH.Lift) 33 | 34 | instance NFData DiffTime where 35 | rnf (MkDiffTime t) = rnf t 36 | 37 | instance Enum DiffTime where 38 | succ (MkDiffTime a) = MkDiffTime (succ a) 39 | pred (MkDiffTime a) = MkDiffTime (pred a) 40 | toEnum = MkDiffTime . toEnum 41 | fromEnum (MkDiffTime a) = fromEnum a 42 | enumFrom (MkDiffTime a) = fmap MkDiffTime (enumFrom a) 43 | enumFromThen (MkDiffTime a) (MkDiffTime b) = fmap MkDiffTime (enumFromThen a b) 44 | enumFromTo (MkDiffTime a) (MkDiffTime b) = fmap MkDiffTime (enumFromTo a b) 45 | enumFromThenTo (MkDiffTime a) (MkDiffTime b) (MkDiffTime c) = fmap MkDiffTime (enumFromThenTo a b c) 46 | 47 | instance Show DiffTime where 48 | show (MkDiffTime t) = (showFixed True t) ++ "s" 49 | 50 | instance Read DiffTime where 51 | readPrec = do 52 | t <- readPrec 53 | _ <- lift $ char 's' 54 | return $ MkDiffTime t 55 | 56 | instance Num DiffTime where 57 | (MkDiffTime a) + (MkDiffTime b) = MkDiffTime (a + b) 58 | (MkDiffTime a) - (MkDiffTime b) = MkDiffTime (a - b) 59 | (MkDiffTime a) * (MkDiffTime b) = MkDiffTime (a * b) 60 | negate (MkDiffTime a) = MkDiffTime (negate a) 61 | abs (MkDiffTime a) = MkDiffTime (abs a) 62 | signum (MkDiffTime a) = MkDiffTime (signum a) 63 | fromInteger i = MkDiffTime (fromInteger i) 64 | 65 | instance Real DiffTime where 66 | toRational (MkDiffTime a) = toRational a 67 | 68 | instance Fractional DiffTime where 69 | (MkDiffTime a) / (MkDiffTime b) = MkDiffTime (a / b) 70 | recip (MkDiffTime a) = MkDiffTime (recip a) 71 | fromRational r = MkDiffTime (fromRational r) 72 | 73 | instance RealFrac DiffTime where 74 | properFraction (MkDiffTime a) = 75 | let 76 | (b', a') = properFraction a 77 | in 78 | (b', MkDiffTime a') 79 | truncate (MkDiffTime a) = truncate a 80 | round (MkDiffTime a) = round a 81 | ceiling (MkDiffTime a) = ceiling a 82 | floor (MkDiffTime a) = floor a 83 | 84 | -- | Create a 'DiffTime' which represents an integral number of seconds. 85 | secondsToDiffTime :: Integer -> DiffTime 86 | secondsToDiffTime = fromInteger 87 | 88 | -- | Create a 'DiffTime' from a number of picoseconds. 89 | picosecondsToDiffTime :: Integer -> DiffTime 90 | picosecondsToDiffTime x = MkDiffTime (MkFixed x) 91 | 92 | -- | Get the number of picoseconds in a 'DiffTime'. 93 | diffTimeToPicoseconds :: DiffTime -> Integer 94 | diffTimeToPicoseconds (MkDiffTime (MkFixed x)) = x 95 | 96 | {-# RULES 97 | "realToFrac/DiffTime->Pico" realToFrac = \(MkDiffTime ps) -> ps 98 | "realToFrac/Pico->DiffTime" realToFrac = MkDiffTime 99 | #-} 100 | -------------------------------------------------------------------------------- /lib/Data/Time/Clock/Internal/NominalDiffTime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE InstanceSigs #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE Trustworthy #-} 6 | 7 | module Data.Time.Clock.Internal.NominalDiffTime ( 8 | NominalDiffTime, 9 | secondsToNominalDiffTime, 10 | nominalDiffTimeToSeconds, 11 | nominalDay, 12 | ) where 13 | 14 | import Control.DeepSeq 15 | import Data.Data 16 | import Data.Fixed 17 | #ifdef __GLASGOW_HASKELL__ 18 | import GHC.Read 19 | #endif 20 | import qualified Language.Haskell.TH.Syntax as TH 21 | import Text.ParserCombinators.ReadP 22 | import Text.ParserCombinators.ReadPrec 23 | 24 | -- | This is a length of time, as measured by UTC. 25 | -- It has a precision of one picosecond (10^-12 s). 26 | -- 27 | -- Conversion functions such as 'fromInteger' and 'realToFrac' will treat it as seconds. 28 | -- For example, @(0.010 :: NominalDiffTime)@ corresponds to 10 milliseconds. 29 | -- 30 | -- Enumeration functions will treat it as picoseconds. 31 | -- 32 | -- It ignores leap-seconds, so it's not necessarily a fixed amount of clock time. 33 | -- For instance, 23:00 UTC + 2 hours of NominalDiffTime = 01:00 UTC (+ 1 day), 34 | -- regardless of whether a leap-second intervened. 35 | newtype NominalDiffTime 36 | = MkNominalDiffTime Pico 37 | deriving (Eq, Ord, Typeable, Data, TH.Lift) 38 | 39 | -- | Create a 'NominalDiffTime' from a number of seconds. 40 | -- 41 | -- @since 1.9.1 42 | secondsToNominalDiffTime :: Pico -> NominalDiffTime 43 | secondsToNominalDiffTime = MkNominalDiffTime 44 | 45 | -- | Get the seconds in a 'NominalDiffTime'. 46 | -- 47 | -- @since 1.9.1 48 | nominalDiffTimeToSeconds :: NominalDiffTime -> Pico 49 | nominalDiffTimeToSeconds (MkNominalDiffTime t) = t 50 | 51 | instance NFData NominalDiffTime where 52 | rnf (MkNominalDiffTime t) = rnf t 53 | 54 | instance Enum NominalDiffTime where 55 | succ (MkNominalDiffTime a) = MkNominalDiffTime (succ a) 56 | pred (MkNominalDiffTime a) = MkNominalDiffTime (pred a) 57 | toEnum = MkNominalDiffTime . toEnum 58 | fromEnum (MkNominalDiffTime a) = fromEnum a 59 | enumFrom (MkNominalDiffTime a) = fmap MkNominalDiffTime (enumFrom a) 60 | enumFromThen (MkNominalDiffTime a) (MkNominalDiffTime b) = fmap MkNominalDiffTime (enumFromThen a b) 61 | enumFromTo (MkNominalDiffTime a) (MkNominalDiffTime b) = fmap MkNominalDiffTime (enumFromTo a b) 62 | enumFromThenTo (MkNominalDiffTime a) (MkNominalDiffTime b) (MkNominalDiffTime c) = 63 | fmap MkNominalDiffTime (enumFromThenTo a b c) 64 | 65 | instance Show NominalDiffTime where 66 | show (MkNominalDiffTime t) = (showFixed True t) ++ "s" 67 | 68 | instance Read NominalDiffTime where 69 | readPrec = do 70 | t <- readPrec 71 | _ <- lift $ char 's' 72 | return $ MkNominalDiffTime t 73 | 74 | instance Num NominalDiffTime where 75 | (MkNominalDiffTime a) + (MkNominalDiffTime b) = MkNominalDiffTime (a + b) 76 | (MkNominalDiffTime a) - (MkNominalDiffTime b) = MkNominalDiffTime (a - b) 77 | (MkNominalDiffTime a) * (MkNominalDiffTime b) = MkNominalDiffTime (a * b) 78 | negate (MkNominalDiffTime a) = MkNominalDiffTime (negate a) 79 | abs (MkNominalDiffTime a) = MkNominalDiffTime (abs a) 80 | signum (MkNominalDiffTime a) = MkNominalDiffTime (signum a) 81 | fromInteger i = MkNominalDiffTime (fromInteger i) 82 | 83 | instance Real NominalDiffTime where 84 | toRational (MkNominalDiffTime a) = toRational a 85 | 86 | instance Fractional NominalDiffTime where 87 | (MkNominalDiffTime a) / (MkNominalDiffTime b) = MkNominalDiffTime (a / b) 88 | recip (MkNominalDiffTime a) = MkNominalDiffTime (recip a) 89 | fromRational r = MkNominalDiffTime (fromRational r) 90 | 91 | instance RealFrac NominalDiffTime where 92 | properFraction (MkNominalDiffTime a) = (i, MkNominalDiffTime f) 93 | where 94 | (i, f) = properFraction a 95 | truncate (MkNominalDiffTime a) = truncate a 96 | round (MkNominalDiffTime a) = round a 97 | ceiling (MkNominalDiffTime a) = ceiling a 98 | floor (MkNominalDiffTime a) = floor a 99 | 100 | {-# RULES 101 | "realToFrac/DiffTime->NominalDiffTime" 102 | realToFrac = 103 | \dt -> MkNominalDiffTime (realToFrac dt) 104 | "realToFrac/NominalDiffTime->DiffTime" 105 | realToFrac = 106 | \(MkNominalDiffTime ps) -> realToFrac ps 107 | "realToFrac/NominalDiffTime->Pico" 108 | realToFrac = 109 | \(MkNominalDiffTime ps) -> ps 110 | "realToFrac/Pico->NominalDiffTime" realToFrac = MkNominalDiffTime 111 | #-} 112 | 113 | -- | One day in 'NominalDiffTime'. 114 | nominalDay :: NominalDiffTime 115 | nominalDay = 86400 116 | -------------------------------------------------------------------------------- /lib/Data/Time/Clock/Internal/POSIXTime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.Clock.Internal.POSIXTime where 4 | 5 | import Data.Time.Clock.Internal.NominalDiffTime 6 | 7 | -- | 86400 nominal seconds in every day 8 | posixDayLength :: NominalDiffTime 9 | posixDayLength = nominalDay 10 | 11 | -- | POSIX time is the nominal time since 1970-01-01 00:00 UTC 12 | -- 13 | -- To convert from a 'Foreign.C.Types.CTime' or @System.Posix.EpochTime@, use 'realToFrac'. 14 | type POSIXTime = NominalDiffTime 15 | -------------------------------------------------------------------------------- /lib/Data/Time/Clock/Internal/SystemTime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | #if !defined(__MHS__) 4 | #include "HsTimeConfig.h" 5 | #endif 6 | 7 | #if defined(mingw32_HOST_OS) || !defined(HAVE_CLOCK_GETTIME) 8 | {-# LANGUAGE Safe #-} 9 | #else 10 | {-# LANGUAGE Trustworthy #-} 11 | #endif 12 | 13 | module Data.Time.Clock.Internal.SystemTime ( 14 | SystemTime (..), 15 | getSystemTime, 16 | getTime_resolution, 17 | getTAISystemTime, 18 | ) where 19 | 20 | import Control.DeepSeq 21 | import Data.Data 22 | import Data.Int (Int64) 23 | import Data.Time.Clock.Internal.DiffTime 24 | import Data.Word 25 | import GHC.Generics 26 | import qualified Language.Haskell.TH.Syntax as TH 27 | 28 | #ifdef mingw32_HOST_OS 29 | import qualified System.Win32.Time as Win32 30 | #elif defined(HAVE_CLOCK_GETTIME) && !defined(__MHS__) 31 | import Data.Time.Clock.Internal.CTimespec 32 | import Foreign.C.Types (CLong(..), CTime(..)) 33 | #else 34 | import Data.Time.Clock.Internal.CTimeval 35 | import Foreign.C.Types (CLong(..)) 36 | #endif 37 | -------------------------------------------------------------------------------- 38 | 39 | -- | 'SystemTime' is time returned by system clock functions. 40 | -- Its semantics depends on the clock function, but the epoch is typically the beginning of 1970. 41 | -- Note that 'systemNanoseconds' of 1E9 to 2E9-1 can be used to represent leap seconds. 42 | data SystemTime = MkSystemTime 43 | { systemSeconds :: {-# UNPACK #-} !Int64 44 | , systemNanoseconds :: {-# UNPACK #-} !Word32 45 | } 46 | deriving (Eq, Ord, Show, Typeable, Data, Generic, TH.Lift) 47 | 48 | instance NFData SystemTime where 49 | rnf a = a `seq` () 50 | 51 | -- | Get the system time, epoch start of 1970 UTC, leap-seconds ignored. 52 | -- 'getSystemTime' is typically much faster than 'getCurrentTime'. 53 | getSystemTime :: IO SystemTime 54 | 55 | -- | The resolution of 'getSystemTime', 'getCurrentTime', 'getPOSIXTime'. 56 | -- On UNIX systems this uses @clock_getres@, which may be . 57 | getTime_resolution :: DiffTime 58 | 59 | -- | If supported, get TAI time, epoch start of 1970 TAI, with resolution. 60 | -- This is supported only on UNIX systems, and only those with CLOCK_TAI available at run-time. 61 | getTAISystemTime :: Maybe (DiffTime, IO SystemTime) 62 | 63 | #ifdef mingw32_HOST_OS 64 | -- On Windows, the equivalent of POSIX time is "file time", defined as 65 | -- the number of 100-nanosecond intervals that have elapsed since 66 | -- 12:00 A.M. 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 | getSystemTime = do 69 | Win32.FILETIME ft <- Win32.getSystemTimeAsFileTime 70 | let (s, us) = (ft - win32_epoch_adjust) `divMod` 10000000 71 | return (MkSystemTime (fromIntegral s) (fromIntegral us * 100)) 72 | where 73 | win32_epoch_adjust :: Word64 74 | win32_epoch_adjust = 116444736000000000 75 | 76 | getTime_resolution = 100E-9 -- 100ns 77 | 78 | getTAISystemTime = Nothing 79 | #elif defined(HAVE_CLOCK_GETTIME) && !defined(__MHS__) 80 | -- Use hi-res clock_gettime 81 | timespecToSystemTime :: CTimespec -> SystemTime 82 | timespecToSystemTime (MkCTimespec (CTime s) (CLong ns)) = (MkSystemTime (fromIntegral s) (fromIntegral ns)) 83 | 84 | timespecToDiffTime :: CTimespec -> DiffTime 85 | timespecToDiffTime (MkCTimespec (CTime s) ns) = (fromIntegral s) + (fromIntegral ns) * 1E-9 86 | 87 | clockGetSystemTime :: ClockID -> IO SystemTime 88 | clockGetSystemTime clock = fmap timespecToSystemTime $ clockGetTime clock 89 | 90 | getSystemTime = clockGetSystemTime clock_REALTIME 91 | 92 | getTime_resolution = timespecToDiffTime realtimeRes 93 | 94 | getTAISystemTime = do 95 | clockID <- clock_TAI 96 | resolution <- clockResolution clockID 97 | return $ (timespecToDiffTime resolution, clockGetSystemTime clockID) 98 | #else 99 | -- Use gettimeofday 100 | getSystemTime = do 101 | MkCTimeval (CLong s) (CLong us) <- getCTimeval 102 | return (MkSystemTime (fromIntegral s) (fromIntegral us * 1000)) 103 | 104 | getTime_resolution = 1E-6 -- microsecond 105 | 106 | getTAISystemTime = Nothing 107 | #endif 108 | -------------------------------------------------------------------------------- /lib/Data/Time/Clock/Internal/UTCDiff.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.Clock.Internal.UTCDiff where 4 | 5 | import Data.Time.Clock.Internal.NominalDiffTime 6 | import Data.Time.Clock.Internal.UTCTime 7 | import Data.Time.Clock.POSIX 8 | 9 | -- | addUTCTime a b = a + b 10 | addUTCTime :: NominalDiffTime -> UTCTime -> UTCTime 11 | addUTCTime x t = posixSecondsToUTCTime (x + (utcTimeToPOSIXSeconds t)) 12 | 13 | -- | diffUTCTime a b = a - b 14 | diffUTCTime :: UTCTime -> UTCTime -> NominalDiffTime 15 | diffUTCTime a b = (utcTimeToPOSIXSeconds a) - (utcTimeToPOSIXSeconds b) 16 | -------------------------------------------------------------------------------- /lib/Data/Time/Clock/Internal/UTCTime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.Clock.Internal.UTCTime ( 4 | -- * UTC 5 | 6 | -- | UTC is time as measured by a clock, corrected to keep pace with the earth by adding or removing 7 | -- occasional seconds, known as \"leap seconds\". 8 | -- These corrections are not predictable and are announced with six month's notice. 9 | -- No table of these corrections is provided, as any program compiled with it would become 10 | -- out of date in six months. 11 | -- 12 | -- If you don't care about leap seconds, use 'UTCTime' and 'NominalDiffTime' for your clock calculations, 13 | -- and you'll be fine. 14 | UTCTime (..), 15 | ) where 16 | 17 | import Control.DeepSeq 18 | import Data.Data 19 | import Data.Time.Calendar.Days 20 | import Data.Time.Clock.Internal.DiffTime 21 | import GHC.Generics 22 | import qualified Language.Haskell.TH.Syntax as TH 23 | 24 | -- | This is the simplest representation of UTC. 25 | -- It consists of the day number, and a time offset from midnight. 26 | -- Note that if a day has a leap second added to it, it will have 86401 seconds. 27 | data UTCTime = UTCTime 28 | { utctDay :: Day 29 | -- ^ the day 30 | , utctDayTime :: DiffTime 31 | -- ^ the time from midnight, 0 <= t < 86401s (because of leap-seconds) 32 | } 33 | deriving (Eq, Ord, Typeable, Data, Generic, TH.Lift) 34 | 35 | instance NFData UTCTime where 36 | rnf (UTCTime d t) = rnf d `seq` rnf t `seq` () 37 | -------------------------------------------------------------------------------- /lib/Data/Time/Clock/Internal/UniversalTime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.Clock.Internal.UniversalTime ( 4 | -- * Universal Time 5 | 6 | -- | Time as measured by the Earth. 7 | UniversalTime (..), 8 | ) where 9 | 10 | import Control.DeepSeq 11 | import Data.Data 12 | import GHC.Generics 13 | import qualified Language.Haskell.TH.Syntax as TH 14 | 15 | -- | The Modified Julian Date is the day with the fraction of the day, measured from UT midnight. 16 | -- It's used to represent UT1, which is time as measured by the earth's rotation, adjusted for various wobbles. 17 | newtype UniversalTime = ModJulianDate 18 | { getModJulianDate :: Rational 19 | } 20 | deriving (Eq, Ord, Typeable, Data, Generic, TH.Lift) 21 | 22 | instance NFData UniversalTime where 23 | rnf (ModJulianDate a) = rnf a 24 | -------------------------------------------------------------------------------- /lib/Data/Time/Clock/POSIX.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | -- | POSIX time, if you need to deal with timestamps and the like. 4 | -- Most people won't need this module. 5 | -- 6 | -- You can use 'POSIXTime' to obtain integer/word timestamps. For example: 7 | -- 8 | -- > import Data.Time 9 | -- > import Data.Time.Clock.POSIX 10 | -- > import Data.Int 11 | -- > 12 | -- > nanosSinceEpoch :: UTCTime -> Int64 13 | -- > nanosSinceEpoch = 14 | -- > floor . (1e9 *) . nominalDiffTimeToSeconds . utcTimeToPOSIXSeconds 15 | -- > 16 | -- > main :: IO () 17 | -- > main = do 18 | -- > u <- getCurrentTime 19 | -- > print $ nanosSinceEpoch u 20 | module Data.Time.Clock.POSIX ( 21 | posixDayLength, 22 | POSIXTime, 23 | posixSecondsToUTCTime, 24 | utcTimeToPOSIXSeconds, 25 | getPOSIXTime, 26 | getCurrentTime, 27 | systemToPOSIXTime, 28 | ) where 29 | 30 | import Data.Fixed 31 | import Data.Time.Calendar.Days 32 | import Data.Time.Clock.Internal.POSIXTime 33 | import Data.Time.Clock.Internal.UTCTime 34 | import Data.Time.Clock.System 35 | 36 | posixSecondsToUTCTime :: POSIXTime -> UTCTime 37 | posixSecondsToUTCTime i = 38 | let 39 | (d, t) = divMod' i posixDayLength 40 | in 41 | UTCTime (addDays d systemEpochDay) (realToFrac t) 42 | 43 | utcTimeToPOSIXSeconds :: UTCTime -> POSIXTime 44 | utcTimeToPOSIXSeconds (UTCTime d t) = 45 | (fromInteger (diffDays d systemEpochDay) * posixDayLength) + min posixDayLength (realToFrac t) 46 | 47 | systemToPOSIXTime :: SystemTime -> POSIXTime 48 | systemToPOSIXTime (MkSystemTime s ns) = (fromIntegral s) + (fromIntegral ns) * 1E-9 49 | 50 | -- | Get the current POSIX time from the system clock. 51 | getPOSIXTime :: IO POSIXTime 52 | getPOSIXTime = fmap systemToPOSIXTime getSystemTime 53 | 54 | -- | Get the current 'UTCTime' from the system clock. 55 | getCurrentTime :: IO UTCTime 56 | getCurrentTime = systemToUTCTime `fmap` getSystemTime 57 | -------------------------------------------------------------------------------- /lib/Data/Time/Clock/System.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | -- | Fast access to the system clock. 4 | module Data.Time.Clock.System ( 5 | systemEpochDay, 6 | SystemTime (..), 7 | truncateSystemTimeLeapSecond, 8 | getSystemTime, 9 | systemToUTCTime, 10 | utcToSystemTime, 11 | systemToTAITime, 12 | ) where 13 | 14 | import Data.Int (Int64) 15 | import Data.Time.Calendar.Days 16 | import Data.Time.Clock.Internal.AbsoluteTime 17 | import Data.Time.Clock.Internal.DiffTime 18 | import Data.Time.Clock.Internal.SystemTime 19 | import Data.Time.Clock.Internal.UTCTime 20 | 21 | -- | Map leap-second values to the start of the following second. 22 | -- The resulting 'systemNanoseconds' will always be in the range 0 to 1E9-1. 23 | truncateSystemTimeLeapSecond :: SystemTime -> SystemTime 24 | truncateSystemTimeLeapSecond (MkSystemTime seconds nanoseconds) 25 | | nanoseconds >= 1000000000 = MkSystemTime (succ seconds) 0 26 | truncateSystemTimeLeapSecond t = t 27 | 28 | -- | Convert 'SystemTime' to 'UTCTime', matching zero 'SystemTime' to midnight of 'systemEpochDay' UTC. 29 | systemToUTCTime :: SystemTime -> UTCTime 30 | systemToUTCTime (MkSystemTime seconds nanoseconds) = 31 | let 32 | days :: Int64 33 | timeSeconds :: Int64 34 | (days, timeSeconds) = seconds `divMod` 86400 35 | day :: Day 36 | day = addDays (fromIntegral days) systemEpochDay 37 | timeNanoseconds :: Int64 38 | timeNanoseconds = timeSeconds * 1000000000 + (fromIntegral nanoseconds) 39 | timePicoseconds :: Int64 40 | timePicoseconds = timeNanoseconds * 1000 41 | time :: DiffTime 42 | time = picosecondsToDiffTime $ fromIntegral timePicoseconds 43 | in 44 | UTCTime day time 45 | 46 | -- | Convert 'UTCTime' to 'SystemTime', matching zero 'SystemTime' to midnight of 'systemEpochDay' UTC. 47 | utcToSystemTime :: UTCTime -> SystemTime 48 | utcToSystemTime (UTCTime day time) = 49 | let 50 | days :: Int64 51 | days = fromIntegral $ diffDays day systemEpochDay 52 | timePicoseconds :: Int64 53 | timePicoseconds = fromIntegral $ diffTimeToPicoseconds time 54 | timeNanoseconds :: Int64 55 | timeNanoseconds = timePicoseconds `div` 1000 56 | timeSeconds :: Int64 57 | nanoseconds :: Int64 58 | (timeSeconds, nanoseconds) = 59 | if timeNanoseconds >= 86400000000000 60 | then (86399, timeNanoseconds - 86399000000000) 61 | else timeNanoseconds `divMod` 1000000000 62 | seconds :: Int64 63 | seconds = days * 86400 + timeSeconds 64 | in 65 | MkSystemTime seconds $ fromIntegral nanoseconds 66 | 67 | systemEpochAbsolute :: AbsoluteTime 68 | systemEpochAbsolute = taiNominalDayStart systemEpochDay 69 | 70 | -- | Convert 'SystemTime' to 'AbsoluteTime', matching zero 'SystemTime' to midnight of 'systemEpochDay' TAI. 71 | systemToTAITime :: SystemTime -> AbsoluteTime 72 | systemToTAITime (MkSystemTime s ns) = 73 | let 74 | diff :: DiffTime 75 | diff = (fromIntegral s) + (fromIntegral ns) * 1E-9 76 | in 77 | addAbsoluteTime diff systemEpochAbsolute 78 | 79 | -- | The day of the epoch of 'SystemTime', 1970-01-01 80 | systemEpochDay :: Day 81 | systemEpochDay = ModifiedJulianDay 40587 82 | -------------------------------------------------------------------------------- /lib/Data/Time/Clock/TAI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE Safe #-} 3 | 4 | {-# OPTIONS -fno-warn-orphans #-} 5 | 6 | -- | TAI and leap-second maps for converting to UTC: most people won't need this module. 7 | module Data.Time.Clock.TAI ( 8 | -- TAI arithmetic 9 | module Data.Time.Clock.Internal.AbsoluteTime, 10 | -- leap-second map type 11 | LeapSecondMap, 12 | -- conversion between UTC and TAI with map 13 | utcDayLength, 14 | utcToTAITime, 15 | taiToUTCTime, 16 | taiClock, 17 | ) where 18 | 19 | import Data.Fixed 20 | import Data.Maybe 21 | import Data.Time.Calendar.Days 22 | import Data.Time.Clock 23 | import Data.Time.Clock.Internal.AbsoluteTime 24 | import Data.Time.Clock.Internal.SystemTime 25 | import Data.Time.Clock.System 26 | import Data.Time.LocalTime 27 | #ifdef __MHS__ 28 | import Data.Tuple.Instances 29 | #endif 30 | 31 | instance Show AbsoluteTime where 32 | show t = show (utcToLocalTime utc (fromJust (taiToUTCTime (const (Just 0)) t))) ++ " TAI" -- ugly, but standard apparently 33 | 34 | -- | TAI - UTC during this day. 35 | -- No table is provided, as any program compiled with it would become 36 | -- out of date in six months. 37 | type LeapSecondMap = Day -> Maybe Int 38 | 39 | utcDayLength :: LeapSecondMap -> Day -> Maybe DiffTime 40 | utcDayLength lsmap day = do 41 | i0 <- lsmap day 42 | i1 <- lsmap $ addDays 1 day 43 | return $ realToFrac (86400 + i1 - i0) 44 | 45 | dayStart :: LeapSecondMap -> Day -> Maybe AbsoluteTime 46 | dayStart lsmap day = do 47 | i <- lsmap day 48 | return $ addAbsoluteTime (realToFrac $ (toModifiedJulianDay day) * 86400 + toInteger i) taiEpoch 49 | 50 | utcToTAITime :: LeapSecondMap -> UTCTime -> Maybe AbsoluteTime 51 | utcToTAITime lsmap (UTCTime day dtime) = do 52 | t <- dayStart lsmap day 53 | return $ addAbsoluteTime dtime t 54 | 55 | taiToUTCTime :: LeapSecondMap -> AbsoluteTime -> Maybe UTCTime 56 | taiToUTCTime lsmap abstime = 57 | let 58 | stable day = do 59 | dayt <- dayStart lsmap day 60 | len <- utcDayLength lsmap day 61 | let 62 | dtime = diffAbsoluteTime abstime dayt 63 | day' = addDays (div' dtime len) day 64 | if day == day' 65 | then return (UTCTime day dtime) 66 | else stable day' 67 | in 68 | stable $ ModifiedJulianDay $ div' (diffAbsoluteTime abstime taiEpoch) 86400 69 | 70 | -- | TAI clock, if it exists. Note that it is unlikely to be set correctly, without due care and attention. 71 | taiClock :: Maybe (DiffTime, IO AbsoluteTime) 72 | taiClock = fmap (fmap (fmap systemToTAITime)) getTAISystemTime 73 | -------------------------------------------------------------------------------- /lib/Data/Time/Format.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.Format ( 4 | -- * UNIX-style formatting 5 | FormatTime (), 6 | formatTime, 7 | module Data.Time.Format.Parse, 8 | ) where 9 | 10 | import Data.Time.Format.Format.Class 11 | import Data.Time.Format.Format.Instances () 12 | import Data.Time.Format.ISO8601 () 13 | import Data.Time.Format.Parse 14 | -------------------------------------------------------------------------------- /lib/Data/Time/Format/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | -- | 4 | -- The contents of this module is liable to change, or disappear entirely. 5 | -- Please if you depend on anything here. 6 | module Data.Time.Format.Internal ( 7 | -- * ISO8601 formatting 8 | Format (..), 9 | module Data.Time.Format.Format.Class, 10 | module Data.Time.Format.Parse.Class, 11 | ) where 12 | 13 | import Data.Format 14 | import Data.Time.Format.Format.Class 15 | import Data.Time.Format.Parse.Class 16 | -------------------------------------------------------------------------------- /lib/Data/Time/Format/Locale.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | -- Note: this file derives from old-locale:System.Locale.hs, which is copyright (c) The University of Glasgow 2001 4 | module Data.Time.Format.Locale ( 5 | TimeLocale (..), 6 | defaultTimeLocale, 7 | iso8601DateFormat, 8 | rfc822DateFormat, 9 | ) where 10 | 11 | import Data.Time.LocalTime.Internal.TimeZone 12 | 13 | data TimeLocale = TimeLocale 14 | { -- | full and abbreviated week days, starting with Sunday 15 | wDays :: [(String, String)] 16 | , -- | full and abbreviated months 17 | months :: [(String, String)] 18 | , -- | AM\/PM symbols 19 | amPm :: (String, String) 20 | , -- | formatting strings 21 | dateTimeFmt, dateFmt, timeFmt, time12Fmt :: String 22 | , -- | time zones known by name 23 | knownTimeZones :: [TimeZone] 24 | } 25 | deriving (Eq, Ord, Show) 26 | 27 | -- | Locale representing American usage. 28 | -- 29 | -- 'knownTimeZones' contains only the ten time-zones mentioned in RFC 822 sec. 5: 30 | -- \"UT\", \"GMT\", \"EST\", \"EDT\", \"CST\", \"CDT\", \"MST\", \"MDT\", \"PST\", \"PDT\". 31 | -- Note that the parsing functions will regardless parse \"UTC\", single-letter military time-zones, and +HHMM format. 32 | defaultTimeLocale :: TimeLocale 33 | defaultTimeLocale = 34 | TimeLocale 35 | { wDays = 36 | [ ("Sunday", "Sun") 37 | , ("Monday", "Mon") 38 | , ("Tuesday", "Tue") 39 | , ("Wednesday", "Wed") 40 | , ("Thursday", "Thu") 41 | , ("Friday", "Fri") 42 | , ("Saturday", "Sat") 43 | ] 44 | , months = 45 | [ ("January", "Jan") 46 | , ("February", "Feb") 47 | , ("March", "Mar") 48 | , ("April", "Apr") 49 | , ("May", "May") 50 | , ("June", "Jun") 51 | , ("July", "Jul") 52 | , ("August", "Aug") 53 | , ("September", "Sep") 54 | , ("October", "Oct") 55 | , ("November", "Nov") 56 | , ("December", "Dec") 57 | ] 58 | , amPm = ("AM", "PM") 59 | , dateTimeFmt = "%a %b %e %H:%M:%S %Z %Y" 60 | , dateFmt = "%m/%d/%y" 61 | , timeFmt = "%H:%M:%S" 62 | , time12Fmt = "%I:%M:%S %p" 63 | , knownTimeZones = 64 | [ TimeZone 0 False "UT" 65 | , TimeZone 0 False "GMT" 66 | , TimeZone (-5 * 60) False "EST" 67 | , TimeZone (-4 * 60) True "EDT" 68 | , TimeZone (-6 * 60) False "CST" 69 | , TimeZone (-5 * 60) True "CDT" 70 | , TimeZone (-7 * 60) False "MST" 71 | , TimeZone (-6 * 60) True "MDT" 72 | , TimeZone (-8 * 60) False "PST" 73 | , TimeZone (-7 * 60) True "PDT" 74 | ] 75 | } 76 | 77 | {-# DEPRECATED iso8601DateFormat "use \"Data.Time.Format.ISO8601\" functions instead" #-} 78 | 79 | {- | Construct format string according to . 80 | 81 | The @Maybe String@ argument allows to supply an optional time specification. E.g.: 82 | 83 | @ 84 | 'iso8601DateFormat' Nothing == "%Y-%m-%d" -- i.e. @/YYYY-MM-DD/@ 85 | 'iso8601DateFormat' (Just "%H:%M:%S") == "%Y-%m-%dT%H:%M:%S" -- i.e. @/YYYY-MM-DD/T/HH:MM:SS/@ 86 | @ 87 | -} 88 | iso8601DateFormat :: Maybe String -> String 89 | iso8601DateFormat mTimeFmt = 90 | "%Y-%m-%d" 91 | ++ case mTimeFmt of 92 | Nothing -> "" 93 | Just fmt -> 'T' : fmt 94 | 95 | -- | Format string according to . 96 | rfc822DateFormat :: String 97 | rfc822DateFormat = "%a, %_d %b %Y %H:%M:%S %Z" 98 | -------------------------------------------------------------------------------- /lib/Data/Time/LocalTime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.LocalTime ( 4 | -- * Time zones 5 | TimeZone (..), 6 | timeZoneOffsetString, 7 | timeZoneOffsetString', 8 | minutesToTimeZone, 9 | hoursToTimeZone, 10 | utc, 11 | -- getting the locale time zone 12 | getTimeZone, 13 | getCurrentTimeZone, 14 | module Data.Time.LocalTime.Internal.TimeOfDay, 15 | module Data.Time.LocalTime.Internal.CalendarDiffTime, 16 | module Data.Time.LocalTime.Internal.LocalTime, 17 | module Data.Time.LocalTime.Internal.ZonedTime, 18 | ) where 19 | 20 | import Data.Time.Format () 21 | import Data.Time.LocalTime.Internal.CalendarDiffTime 22 | import Data.Time.LocalTime.Internal.Foreign 23 | import Data.Time.LocalTime.Internal.LocalTime 24 | import Data.Time.LocalTime.Internal.TimeOfDay 25 | import Data.Time.LocalTime.Internal.TimeZone hiding (timeZoneOffsetString'') 26 | import Data.Time.LocalTime.Internal.ZonedTime 27 | -------------------------------------------------------------------------------- /lib/Data/Time/LocalTime/Internal/CalendarDiffTime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.LocalTime.Internal.CalendarDiffTime ( 4 | -- * Calendar Duration 5 | module Data.Time.LocalTime.Internal.CalendarDiffTime, 6 | ) where 7 | 8 | import Control.DeepSeq 9 | import Data.Data 10 | import Data.Time.Calendar.CalendarDiffDays 11 | import Data.Time.Clock.Internal.NominalDiffTime 12 | import GHC.Generics 13 | import qualified Language.Haskell.TH.Syntax as TH 14 | 15 | data CalendarDiffTime = CalendarDiffTime 16 | { ctMonths :: Integer 17 | , ctTime :: NominalDiffTime 18 | } 19 | deriving (Eq, Typeable, Data, Generic, TH.Lift) 20 | 21 | instance NFData CalendarDiffTime where 22 | rnf (CalendarDiffTime m t) = rnf m `seq` rnf t `seq` () 23 | 24 | -- | Additive 25 | instance Semigroup CalendarDiffTime where 26 | CalendarDiffTime m1 d1 <> CalendarDiffTime m2 d2 = CalendarDiffTime (m1 + m2) (d1 + d2) 27 | 28 | -- | Additive 29 | instance Monoid CalendarDiffTime where 30 | mempty = CalendarDiffTime 0 0 31 | mappend = (<>) 32 | 33 | calendarTimeDays :: CalendarDiffDays -> CalendarDiffTime 34 | calendarTimeDays (CalendarDiffDays m d) = CalendarDiffTime m $ fromInteger d * nominalDay 35 | 36 | calendarTimeTime :: NominalDiffTime -> CalendarDiffTime 37 | calendarTimeTime dt = CalendarDiffTime 0 dt 38 | 39 | -- | Scale by a factor. Note that @scaleCalendarDiffTime (-1)@ will not perfectly invert a duration, due to variable month lengths. 40 | scaleCalendarDiffTime :: Integer -> CalendarDiffTime -> CalendarDiffTime 41 | scaleCalendarDiffTime k (CalendarDiffTime m d) = CalendarDiffTime (k * m) (fromInteger k * d) 42 | -------------------------------------------------------------------------------- /lib/Data/Time/LocalTime/Internal/Foreign.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ForeignFunctionInterface #-} 3 | {-# LANGUAGE Safe #-} 4 | 5 | module Data.Time.LocalTime.Internal.Foreign ( 6 | getTimeZone, 7 | getCurrentTimeZone, 8 | ) where 9 | 10 | import Data.Time.Clock.Internal.UTCTime 11 | import Data.Time.Clock.POSIX 12 | import Data.Time.Clock.System 13 | import Data.Time.LocalTime.Internal.TimeZone 14 | import Foreign 15 | import Foreign.C 16 | #if defined(javascript_HOST_ARCH) 17 | import Data.Time.Calendar.Gregorian 18 | import Data.Time.Clock.Internal.NominalDiffTime 19 | import Data.Time.LocalTime.Internal.LocalTime 20 | import Data.Time.LocalTime.Internal.TimeOfDay 21 | #endif 22 | 23 | #if defined(javascript_HOST_ARCH) 24 | 25 | foreign import javascript "((dy,dm,dd,th,tm,ts) => { new Date(dy,dm,dd,th,tm,ts).getTimezoneOffset(); })" 26 | js_get_timezone_minutes :: Int -> Int -> Int -> Int -> Int -> Int -> IO Int 27 | 28 | get_timezone_minutes :: UTCTime -> IO Int 29 | get_timezone_minutes ut = let 30 | lt :: LocalTime 31 | lt = utcToLocalTime utc ut 32 | in case lt of 33 | LocalTime (YearMonthDay dy dm dd) (TimeOfDay th tm ts) -> 34 | js_get_timezone_minutes (fromInteger dy) (pred dm) dd th tm (floor ts) 35 | 36 | getTimeZoneCTime :: CTime -> IO TimeZone 37 | getTimeZoneCTime ct = do 38 | let 39 | ut :: UTCTime 40 | ut = posixSecondsToUTCTime $ secondsToNominalDiffTime $ fromIntegral $ fromCTime ct 41 | mins <- get_timezone_minutes ut 42 | return $ TimeZone mins False "" 43 | 44 | fromCTime :: CTime -> Int64 45 | fromCTime (CTime tt) = fromIntegral tt 46 | 47 | #else 48 | {-# CFILES cbits/HsTime.c #-} 49 | foreign import ccall unsafe "HsTime.h get_current_timezone_seconds" 50 | get_current_timezone_seconds :: 51 | CTime -> Ptr CInt -> Ptr CString -> IO CLong 52 | 53 | getTimeZoneCTime :: CTime -> IO TimeZone 54 | getTimeZoneCTime ctime = 55 | with 0 $ \pdst -> 56 | with nullPtr $ \pcname -> do 57 | secs <- get_current_timezone_seconds ctime pdst pcname 58 | case secs of 59 | 0x80000000 -> fail "localtime_r failed" 60 | _ -> do 61 | dst <- peek pdst 62 | cname <- peek pcname 63 | name <- peekCString cname 64 | return (TimeZone (div (fromIntegral secs) 60) (dst == 1) name) 65 | #endif 66 | 67 | -- there's no instance Bounded CTime, so this is the easiest way to check for overflow 68 | toCTime :: Int64 -> IO CTime 69 | toCTime t = 70 | let 71 | tt = fromIntegral t 72 | t' = fromIntegral tt 73 | in 74 | if t' == t 75 | then return $ CTime tt 76 | else fail "Data.Time.LocalTime.Internal.TimeZone.toCTime: Overflow" 77 | 78 | -- | Get the configured time-zone for a given time (varying as per summertime adjustments). 79 | getTimeZoneSystem :: SystemTime -> IO TimeZone 80 | getTimeZoneSystem t = do 81 | ctime <- toCTime $ systemSeconds t 82 | getTimeZoneCTime ctime 83 | 84 | -- | Get the configured time-zone for a given time (varying as per summertime adjustments). 85 | -- 86 | -- On Unix systems the output of this function depends on: 87 | -- 88 | -- 1. The value of @TZ@ environment variable (if set) 89 | -- 90 | -- 2. The system time zone (usually configured by @\/etc\/localtime@ symlink) 91 | -- 92 | -- For details see tzset(3) and localtime(3). 93 | -- 94 | -- Example: 95 | -- 96 | -- @ 97 | -- > let t = `UTCTime` (`Data.Time.Calendar.fromGregorian` 2021 7 1) 0 98 | -- > `getTimeZone` t 99 | -- CEST 100 | -- > `System.Environment.setEnv` \"TZ\" \"America/New_York\" >> `getTimeZone` t 101 | -- EDT 102 | -- > `System.Environment.setEnv` \"TZ\" \"Europe/Berlin\" >> `getTimeZone` t 103 | -- CEST 104 | -- @ 105 | -- 106 | -- On Windows systems the output of this function depends on: 107 | -- 108 | -- 1. The value of @TZ@ environment variable (if set). 109 | -- See [here](https://docs.microsoft.com/en-us/cpp/c-runtime-library/reference/tzset) for how Windows interprets this variable. 110 | -- 111 | -- 2. The system time zone, configured in Settings 112 | getTimeZone :: UTCTime -> IO TimeZone 113 | getTimeZone t = do 114 | ctime <- toCTime $ floor $ utcTimeToPOSIXSeconds t 115 | getTimeZoneCTime ctime 116 | 117 | -- | Get the configured time-zone for the current time. 118 | getCurrentTimeZone :: IO TimeZone 119 | getCurrentTimeZone = getSystemTime >>= getTimeZoneSystem 120 | -------------------------------------------------------------------------------- /lib/Data/Time/LocalTime/Internal/LocalTime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | {-# OPTIONS -fno-warn-orphans #-} 4 | 5 | module Data.Time.LocalTime.Internal.LocalTime ( 6 | -- * Local Time 7 | LocalTime (..), 8 | addLocalTime, 9 | diffLocalTime, 10 | -- converting UTC and UT1 times to LocalTime 11 | utcToLocalTime, 12 | localTimeToUTC, 13 | ut1ToLocalTime, 14 | localTimeToUT1, 15 | ) where 16 | 17 | import Control.DeepSeq 18 | import Data.Data 19 | import Data.Time.Calendar.Days 20 | import Data.Time.Calendar.Gregorian 21 | import Data.Time.Clock.Internal.NominalDiffTime 22 | import Data.Time.Clock.Internal.UTCDiff 23 | import Data.Time.Clock.Internal.UTCTime 24 | import Data.Time.Clock.Internal.UniversalTime 25 | import Data.Time.LocalTime.Internal.TimeOfDay 26 | import Data.Time.LocalTime.Internal.TimeZone 27 | import GHC.Generics 28 | import qualified Language.Haskell.TH.Syntax as TH 29 | 30 | -- | A simple day and time aggregate, where the day is of the specified parameter, 31 | -- and the time is a TimeOfDay. 32 | -- Conversion of this (as local civil time) to UTC depends on the time zone. 33 | -- Conversion of this (as local mean time) to UT1 depends on the longitude. 34 | data LocalTime = LocalTime 35 | { localDay :: Day 36 | , localTimeOfDay :: TimeOfDay 37 | } 38 | deriving (Eq, Ord, Typeable, Data, Generic, TH.Lift) 39 | 40 | instance NFData LocalTime where 41 | rnf (LocalTime d t) = rnf d `seq` rnf t `seq` () 42 | 43 | instance Show LocalTime where 44 | show (LocalTime d t) = (showGregorian d) ++ " " ++ (show t) 45 | 46 | -- | addLocalTime a b = a + b 47 | addLocalTime :: NominalDiffTime -> LocalTime -> LocalTime 48 | addLocalTime x = utcToLocalTime utc . addUTCTime x . localTimeToUTC utc 49 | 50 | -- | diffLocalTime a b = a - b 51 | diffLocalTime :: LocalTime -> LocalTime -> NominalDiffTime 52 | diffLocalTime a b = diffUTCTime (localTimeToUTC utc a) (localTimeToUTC utc b) 53 | 54 | -- | Get the local time of a UTC time in a time zone. 55 | utcToLocalTime :: TimeZone -> UTCTime -> LocalTime 56 | utcToLocalTime tz (UTCTime day dt) = LocalTime (addDays i day) tod 57 | where 58 | (i, tod) = utcToLocalTimeOfDay tz (timeToTimeOfDay dt) 59 | 60 | -- | Get the UTC time of a local time in a time zone. 61 | localTimeToUTC :: TimeZone -> LocalTime -> UTCTime 62 | localTimeToUTC tz (LocalTime day tod) = UTCTime (addDays i day) (timeOfDayToTime todUTC) 63 | where 64 | (i, todUTC) = localToUTCTimeOfDay tz tod 65 | 66 | -- | Get the local time of a UT1 time on a particular meridian (in degrees, positive is East). 67 | ut1ToLocalTime :: Rational -> UniversalTime -> LocalTime 68 | ut1ToLocalTime long (ModJulianDate date) = 69 | LocalTime (ModifiedJulianDay localMJD) (dayFractionToTimeOfDay localToDOffset) 70 | where 71 | localTime = date + long / 360 :: Rational 72 | localMJD = floor localTime 73 | localToDOffset = localTime - (fromIntegral localMJD) 74 | 75 | -- | Get the UT1 time of a local time on a particular meridian (in degrees, positive is East). 76 | localTimeToUT1 :: Rational -> LocalTime -> UniversalTime 77 | localTimeToUT1 long (LocalTime (ModifiedJulianDay localMJD) tod) = 78 | ModJulianDate ((fromIntegral localMJD) + (timeOfDayToDayFraction tod) - (long / 360)) 79 | 80 | -- orphan instance 81 | instance Show UniversalTime where 82 | show t = show (ut1ToLocalTime 0 t) 83 | -------------------------------------------------------------------------------- /lib/Data/Time/LocalTime/Internal/TimeOfDay.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.LocalTime.Internal.TimeOfDay ( 4 | -- * Time of day 5 | TimeOfDay (..), 6 | midnight, 7 | midday, 8 | makeTimeOfDayValid, 9 | timeToDaysAndTimeOfDay, 10 | daysAndTimeOfDayToTime, 11 | utcToLocalTimeOfDay, 12 | localToUTCTimeOfDay, 13 | timeToTimeOfDay, 14 | pastMidnight, 15 | timeOfDayToTime, 16 | sinceMidnight, 17 | dayFractionToTimeOfDay, 18 | timeOfDayToDayFraction, 19 | ) where 20 | 21 | import Control.DeepSeq 22 | import Data.Data 23 | import Data.Fixed 24 | import Data.Time.Calendar.Private 25 | import Data.Time.Clock.Internal.DiffTime 26 | import Data.Time.Clock.Internal.NominalDiffTime 27 | import Data.Time.LocalTime.Internal.TimeZone 28 | import GHC.Generics 29 | import qualified Language.Haskell.TH.Syntax as TH 30 | 31 | -- | Time of day as represented in hour, minute and second (with picoseconds), typically used to express local time of day. 32 | -- 33 | -- @TimeOfDay 24 0 0@ is considered invalid for the purposes of 'makeTimeOfDayValid', as well as reading and parsing, 34 | -- but valid for ISO 8601 parsing in "Data.Time.Format.ISO8601". 35 | data TimeOfDay = TimeOfDay 36 | { todHour :: Int 37 | -- ^ range 0 - 23 38 | , todMin :: Int 39 | -- ^ range 0 - 59 40 | , todSec :: Pico 41 | -- ^ Note that 0 <= 'todSec' < 61, accomodating leap seconds. 42 | -- Any local minute may have a leap second, since leap seconds happen in all zones simultaneously 43 | } 44 | deriving (Eq, Ord, Typeable, Data, Generic, TH.Lift) 45 | 46 | instance NFData TimeOfDay where 47 | rnf (TimeOfDay h m s) = rnf h `seq` rnf m `seq` rnf s `seq` () 48 | 49 | -- | Hour zero 50 | midnight :: TimeOfDay 51 | midnight = TimeOfDay 0 0 0 52 | 53 | -- | Hour twelve 54 | midday :: TimeOfDay 55 | midday = TimeOfDay 12 0 0 56 | 57 | instance Show TimeOfDay where 58 | show (TimeOfDay h m s) = (show2 h) ++ ":" ++ (show2 m) ++ ":" ++ (show2Fixed s) 59 | 60 | makeTimeOfDayValid :: Int -> Int -> Pico -> Maybe TimeOfDay 61 | makeTimeOfDayValid h m s = do 62 | _ <- clipValid 0 23 h 63 | _ <- clipValid 0 59 m 64 | _ <- clipValid 0 60.999999999999 s 65 | return (TimeOfDay h m s) 66 | 67 | -- | Convert a period of time into a count of days and a time of day since midnight. 68 | -- The time of day will never have a leap second. 69 | timeToDaysAndTimeOfDay :: NominalDiffTime -> (Integer, TimeOfDay) 70 | timeToDaysAndTimeOfDay dt = 71 | let 72 | s = realToFrac dt 73 | (m, ms) = divMod' s 60 74 | (h, hm) = divMod' m 60 75 | (d, dh) = divMod' h 24 76 | in 77 | (d, TimeOfDay dh hm ms) 78 | 79 | -- | Convert a count of days and a time of day since midnight into a period of time. 80 | daysAndTimeOfDayToTime :: Integer -> TimeOfDay -> NominalDiffTime 81 | daysAndTimeOfDayToTime d (TimeOfDay dh hm ms) = 82 | (+) (realToFrac ms) $ (*) 60 $ (+) (realToFrac hm) $ (*) 60 $ (+) (realToFrac dh) $ (*) 24 $ realToFrac d 83 | 84 | -- | Convert a time of day in UTC to a time of day in some timezone, together with a day adjustment. 85 | utcToLocalTimeOfDay :: TimeZone -> TimeOfDay -> (Integer, TimeOfDay) 86 | utcToLocalTimeOfDay zone (TimeOfDay h m s) = (fromIntegral (div h' 24), TimeOfDay (mod h' 24) (mod m' 60) s) 87 | where 88 | m' = m + timeZoneMinutes zone 89 | h' = h + (div m' 60) 90 | 91 | -- | Convert a time of day in some timezone to a time of day in UTC, together with a day adjustment. 92 | localToUTCTimeOfDay :: TimeZone -> TimeOfDay -> (Integer, TimeOfDay) 93 | localToUTCTimeOfDay zone = utcToLocalTimeOfDay (minutesToTimeZone (negate (timeZoneMinutes zone))) 94 | 95 | posixDayLength :: DiffTime 96 | posixDayLength = fromInteger 86400 97 | 98 | -- | Get the time of day given a time since midnight. 99 | -- Time more than 24h will be converted to leap-seconds. 100 | timeToTimeOfDay :: DiffTime -> TimeOfDay 101 | timeToTimeOfDay dt 102 | | dt >= posixDayLength = TimeOfDay 23 59 (60 + (realToFrac (dt - posixDayLength))) 103 | timeToTimeOfDay dt = TimeOfDay (fromInteger h) (fromInteger m) s 104 | where 105 | s' = realToFrac dt 106 | s = mod' s' 60 107 | m' = div' s' 60 108 | m = mod' m' 60 109 | h = div' m' 60 110 | 111 | -- | Same as 'timeToTimeOfDay'. 112 | pastMidnight :: DiffTime -> TimeOfDay 113 | pastMidnight = timeToTimeOfDay 114 | 115 | -- | Get the time since midnight for a given time of day. 116 | timeOfDayToTime :: TimeOfDay -> DiffTime 117 | timeOfDayToTime (TimeOfDay h m s) = ((fromIntegral h) * 60 + (fromIntegral m)) * 60 + (realToFrac s) 118 | 119 | -- | Same as 'timeOfDayToTime'. 120 | sinceMidnight :: TimeOfDay -> DiffTime 121 | sinceMidnight = timeOfDayToTime 122 | 123 | -- | Get the time of day given the fraction of a day since midnight. 124 | dayFractionToTimeOfDay :: Rational -> TimeOfDay 125 | dayFractionToTimeOfDay df = timeToTimeOfDay (realToFrac (df * 86400)) 126 | 127 | -- | Get the fraction of a day since midnight given a time of day. 128 | timeOfDayToDayFraction :: TimeOfDay -> Rational 129 | timeOfDayToDayFraction tod = realToFrac (timeOfDayToTime tod) / realToFrac posixDayLength 130 | -------------------------------------------------------------------------------- /lib/Data/Time/LocalTime/Internal/TimeZone.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | module Data.Time.LocalTime.Internal.TimeZone ( 4 | -- * Time zones 5 | TimeZone (..), 6 | timeZoneOffsetString, 7 | timeZoneOffsetString', 8 | timeZoneOffsetString'', 9 | minutesToTimeZone, 10 | hoursToTimeZone, 11 | utc, 12 | ) where 13 | 14 | import Control.DeepSeq 15 | import Data.Data 16 | import Data.Time.Calendar.Private 17 | import GHC.Generics 18 | import qualified Language.Haskell.TH.Syntax as TH 19 | 20 | -- | A TimeZone is a whole number of minutes offset from UTC, together with a name and a \"just for summer\" flag. 21 | data TimeZone = TimeZone 22 | { timeZoneMinutes :: Int 23 | -- ^ The number of minutes offset from UTC. Positive means local time will be later in the day than UTC. 24 | , timeZoneSummerOnly :: Bool 25 | -- ^ Is this time zone just persisting for the summer? 26 | , timeZoneName :: String 27 | -- ^ The name of the zone, typically a three- or four-letter acronym. 28 | } 29 | deriving (Eq, Ord, Typeable, Data, Generic, TH.Lift) 30 | 31 | instance NFData TimeZone where 32 | rnf (TimeZone m so n) = rnf m `seq` rnf so `seq` rnf n `seq` () 33 | 34 | -- | Create a nameless non-summer timezone for this number of minutes. 35 | minutesToTimeZone :: Int -> TimeZone 36 | minutesToTimeZone m = TimeZone m False "" 37 | 38 | -- | Create a nameless non-summer timezone for this number of hours. 39 | hoursToTimeZone :: Int -> TimeZone 40 | hoursToTimeZone i = minutesToTimeZone (60 * i) 41 | 42 | showT :: Bool -> PadOption -> Int -> String 43 | showT False opt t = showPaddedNum opt ((div t 60) * 100 + (mod t 60)) 44 | showT True opt t = 45 | let 46 | opt' = case opt of 47 | NoPad -> NoPad 48 | Pad i c -> Pad (max 0 $ i - 3) c 49 | in 50 | showPaddedNum opt' (div t 60) ++ ":" ++ show2 (mod t 60) 51 | 52 | timeZoneOffsetString'' :: Bool -> PadOption -> TimeZone -> String 53 | timeZoneOffsetString'' colon opt (TimeZone t _ _) 54 | | t < 0 = '-' : (showT colon opt (negate t)) 55 | timeZoneOffsetString'' colon opt (TimeZone t _ _) = '+' : (showT colon opt t) 56 | 57 | -- | Text representing the offset of this timezone, such as \"-0800\" or \"+0400\" (like @%z@ in formatTime), with arbitrary padding. 58 | timeZoneOffsetString' :: Maybe Char -> TimeZone -> String 59 | timeZoneOffsetString' Nothing = timeZoneOffsetString'' False NoPad 60 | timeZoneOffsetString' (Just c) = timeZoneOffsetString'' False $ Pad 4 c 61 | 62 | -- | Text representing the offset of this timezone, such as \"-0800\" or \"+0400\" (like @%z@ in formatTime). 63 | timeZoneOffsetString :: TimeZone -> String 64 | timeZoneOffsetString = timeZoneOffsetString'' False (Pad 4 '0') 65 | 66 | -- | This only shows the time zone name, or offset if the name is empty. 67 | instance Show TimeZone where 68 | show zone@(TimeZone _ _ "") = timeZoneOffsetString zone 69 | show (TimeZone _ _ name) = name 70 | 71 | -- | The UTC time zone. 72 | utc :: TimeZone 73 | utc = TimeZone 0 False "UTC" 74 | -------------------------------------------------------------------------------- /lib/Data/Time/LocalTime/Internal/ZonedTime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | 3 | {-# OPTIONS -fno-warn-orphans #-} 4 | 5 | module Data.Time.LocalTime.Internal.ZonedTime ( 6 | ZonedTime (..), 7 | utcToZonedTime, 8 | zonedTimeToUTC, 9 | getZonedTime, 10 | utcToLocalZonedTime, 11 | ) where 12 | 13 | import Control.DeepSeq 14 | import Data.Data 15 | import Data.Time.Clock.Internal.UTCTime 16 | import Data.Time.Clock.POSIX 17 | import Data.Time.LocalTime.Internal.Foreign 18 | import Data.Time.LocalTime.Internal.LocalTime 19 | import Data.Time.LocalTime.Internal.TimeZone 20 | import GHC.Generics 21 | import qualified Language.Haskell.TH.Syntax as TH 22 | 23 | -- | A local time together with a time zone. 24 | -- 25 | -- There is no 'Eq' instance for @ZonedTime@. 26 | -- If you want to compare local times, use 'zonedTimeToLocalTime'. 27 | -- If you want to compare absolute times, use 'zonedTimeToUTC'. 28 | data ZonedTime = ZonedTime 29 | { zonedTimeToLocalTime :: LocalTime 30 | , zonedTimeZone :: TimeZone 31 | } 32 | deriving (Typeable, Data, Generic, TH.Lift) 33 | 34 | instance NFData ZonedTime where 35 | rnf (ZonedTime lt z) = rnf lt `seq` rnf z `seq` () 36 | 37 | utcToZonedTime :: TimeZone -> UTCTime -> ZonedTime 38 | utcToZonedTime zone time = ZonedTime (utcToLocalTime zone time) zone 39 | 40 | zonedTimeToUTC :: ZonedTime -> UTCTime 41 | zonedTimeToUTC (ZonedTime t zone) = localTimeToUTC zone t 42 | 43 | -- | For the time zone, this only shows the name, or offset if the name is empty. 44 | instance Show ZonedTime where 45 | show (ZonedTime t zone) = show t ++ " " ++ show zone 46 | 47 | -- orphan instance 48 | instance Show UTCTime where 49 | show t = show (utcToZonedTime utc t) 50 | 51 | getZonedTime :: IO ZonedTime 52 | getZonedTime = do 53 | t <- getCurrentTime 54 | zone <- getTimeZone t 55 | return (utcToZonedTime zone t) 56 | 57 | utcToLocalZonedTime :: UTCTime -> IO ZonedTime 58 | utcToLocalZonedTime t = do 59 | zone <- getTimeZone t 60 | return (utcToZonedTime zone t) 61 | -------------------------------------------------------------------------------- /lib/cbits/HsTime.c: -------------------------------------------------------------------------------- 1 | #include "HsTime.h" 2 | #include 3 | 4 | long int get_current_timezone_seconds (time_t t,int* pdst,char const* * pname) 5 | { 6 | #if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) 7 | // When compiling with MinGW (which does not provide a full POSIX 8 | // layer as opposed to Cygwin) it's better to use the CRT's 9 | // underscore-prefixed `_tzset()` variant to avoid linker issues 10 | // as Microsoft considers the POSIX named `tzset()` function 11 | // deprecated (see http://msdn.microsoft.com/en-us/library/ms235384.aspx) 12 | _tzset(); 13 | #elif defined(HAVE_TZSET) 14 | tzset(); 15 | #endif 16 | 17 | #if HAVE_LOCALTIME_R 18 | struct tm tmd; 19 | struct tm* ptm = localtime_r(&t,&tmd); 20 | #else 21 | struct tm* ptm = localtime(&t); 22 | #endif 23 | if (ptm) 24 | { 25 | int dst = ptm -> tm_isdst; 26 | *pdst = dst; 27 | #if HAVE_TM_ZONE 28 | *pname = ptm -> tm_zone; 29 | return ptm -> tm_gmtoff; 30 | #elif defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) 31 | // We don't have a better API to use on Windows, the logic to 32 | // decide whether a given date/time falls within DST is 33 | // implemented as part of localtime() in the CRT. This is_dst 34 | // flag is all we need here. 35 | *pname = dst ? _tzname[1] : _tzname[0]; 36 | return - (dst ? _timezone - 3600 : _timezone); 37 | #else 38 | # if HAVE_TZNAME || defined(__MHS__) 39 | *pname = *tzname; 40 | # else 41 | # error "Don't know how to get timezone name on your OS" 42 | # endif 43 | # if HAVE_DECL_ALTZONE 44 | return dst ? altzone : timezone; 45 | # else 46 | return dst ? timezone - 3600 : timezone; 47 | # endif 48 | #endif // HAVE_TM_ZONE 49 | } 50 | else return 0x80000000; 51 | } 52 | -------------------------------------------------------------------------------- /lib/include/HsTime.h: -------------------------------------------------------------------------------- 1 | #ifndef __HSTIME_H__ 2 | #define __HSTIME_H__ 3 | 4 | #if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) || defined(__MHS__) 5 | #define HAVE_TIME_H 1 6 | #else 7 | 8 | #include "HsTimeConfig.h" 9 | // Otherwise these clash with similar definitions from other packages: 10 | #undef PACKAGE_BUGREPORT 11 | #undef PACKAGE_NAME 12 | #undef PACKAGE_STRING 13 | #undef PACKAGE_TARNAME 14 | #undef PACKAGE_VERSION 15 | #endif 16 | 17 | #if HAVE_TIME_H 18 | #include 19 | #endif 20 | 21 | #define HS_CLOCK_REALTIME (uintptr_t)(CLOCK_REALTIME) 22 | 23 | long int get_current_timezone_seconds (time_t,int* pdst,char const* * pname); 24 | 25 | #endif 26 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-23.19 2 | packages: 3 | - '.' 4 | allow-newer: true 5 | 6 | build: 7 | keep-going: true 8 | haddock: true 9 | haddock-deps: false 10 | test: true 11 | test-arguments: 12 | additional-args: [--hide-successes] 13 | 14 | extra-deps: 15 | - process-1.6.18.0 16 | - unix-2.8.5.0 17 | - directory-1.3.8.3 18 | 19 | ghc-options: 20 | "$locals": -Werror -Wincomplete-uni-patterns -Wincomplete-record-updates -Wredundant-constraints -Wcompat -Wnoncanonical-monad-instances 21 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: process-1.6.18.0@sha256:8b4bce2749e4f61a440049e6088487003e8023c720e2019345e399d50888594f,3148 9 | pantry-tree: 10 | sha256: 8ea7f21f2cd49da719521c37c551e7827f4e5eee0a5edcf185c5f1619e9151c4 11 | size: 1675 12 | original: 13 | hackage: process-1.6.18.0 14 | - completed: 15 | hackage: unix-2.8.5.0@sha256:633f15ef0bd50a16a7b5c5e86e6659fee6e4e211e098cc8bd0029f452bfcfddc,9808 16 | pantry-tree: 17 | sha256: d02b6227c6717f58c6f6ef1923f70af11b1a88987917010c3819c433344f4e3a 18 | size: 5821 19 | original: 20 | hackage: unix-2.8.5.0 21 | - completed: 22 | hackage: directory-1.3.8.3@sha256:7bae5a1b4c78247eb1bb89171cd63021e40a44231e93268e1745d055d3c208d5,3168 23 | pantry-tree: 24 | sha256: a470d40c00a8e6d3445407128ca5d34c281e6b43851163599b210e1225da9ce3 25 | size: 3519 26 | original: 27 | hackage: directory-1.3.8.3 28 | snapshots: 29 | - completed: 30 | sha256: 296a7960c37efa382432ab497161a092684191815eb92a608c5d6ea5f894ace3 31 | size: 683835 32 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/23/19.yaml 33 | original: lts-23.19 34 | -------------------------------------------------------------------------------- /test/CurrentTime.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Time 4 | 5 | main :: IO () 6 | main = do 7 | now <- getCurrentTime 8 | putStrLn (show (utctDay now) ++ "," ++ show (utctDayTime now)) 9 | putStrLn (show (utcToZonedTime utc now :: ZonedTime)) 10 | myzone <- getCurrentTimeZone 11 | putStrLn (show (utcToZonedTime myzone now :: ZonedTime)) 12 | -------------------------------------------------------------------------------- /test/ForeignCalls.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Control.Exception 4 | import Control.Monad 5 | import Data.Foldable 6 | import Data.Monoid 7 | import Data.Time 8 | import Data.Time.Clock.POSIX 9 | import Data.Time.Clock.System 10 | import Data.Time.Clock.TAI 11 | import Data.Traversable 12 | import System.Exit 13 | import System.IO 14 | 15 | data Test = MkTest String (IO ()) 16 | 17 | tests :: [Test] 18 | tests = 19 | [ MkTest "getCurrentTime" $ void $ getCurrentTime 20 | , MkTest "getZonedTime" $ void $ getZonedTime 21 | , MkTest "getCurrentTimeZone" $ void $ getCurrentTimeZone 22 | , MkTest "getTimeZone" $ void $ getCurrentTime >>= getTimeZone 23 | , MkTest "getPOSIXTime" $ void $ getPOSIXTime 24 | , MkTest "getSystemTime" $ void $ getSystemTime 25 | , MkTest "getTime_resolution" $ void $ evaluate getTime_resolution 26 | , MkTest "taiClock time" $ for_ taiClock $ \(_, getTime) -> void $ getTime 27 | , MkTest "taiClock resolution" $ for_ taiClock $ \(res, _) -> void $ evaluate res 28 | ] 29 | 30 | runTest :: Test -> IO Bool 31 | runTest (MkTest name action) = do 32 | hPutStr stderr $ name <> ": " 33 | result <- try action 34 | case result of 35 | Left err -> do 36 | hPutStrLn stderr $ "FAILED: " <> show (err :: SomeException) 37 | return False 38 | Right () -> do 39 | hPutStrLn stderr "PASSED" 40 | return True 41 | 42 | main :: IO () 43 | main = do 44 | results <- for tests $ \test -> do 45 | passed <- runTest test 46 | return (Sum $ if passed then 1 else 0 :: Int, Sum 1) 47 | let 48 | (Sum i, Sum n) = mconcat results 49 | hPutStrLn stderr $ show i <> " out of " <> show n <> " tests passed" 50 | exitWith $ if i == n then ExitSuccess else ExitFailure 1 51 | -------------------------------------------------------------------------------- /test/RealToFracBenchmark.hs: -------------------------------------------------------------------------------- 1 | {- Contributed by Liyang HU -} 2 | module Main where 3 | 4 | import Control.Applicative 5 | import Control.DeepSeq 6 | import Control.Monad 7 | import Data.Time 8 | import Data.Time.Clock.POSIX 9 | import System.Random 10 | import Prelude 11 | 12 | main :: IO () 13 | main = do 14 | ts <- 15 | replicateM 100000 $ do 16 | t <- 17 | posixSecondsToUTCTime . realToFrac 18 | <$> ((*) . fromInteger <$> randomRIO (-15 * 10 ^ 21, 15 * 10 ^ 21) <*> randomIO :: IO Double) :: 19 | IO UTCTime 20 | rnf t `seq` return t 21 | now <- getCurrentTime 22 | print . sum $ map (diffUTCTime now) ts 23 | print =<< flip diffUTCTime now <$> getCurrentTime 24 | -------------------------------------------------------------------------------- /test/ShowDST.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Time 4 | 5 | monthBeginning :: TimeZone -> Integer -> Int -> UTCTime 6 | monthBeginning zone year month = localTimeToUTC zone (LocalTime (fromGregorian year month 1) midnight) 7 | 8 | findTransition :: UTCTime -> UTCTime -> IO [(UTCTime, TimeZone, TimeZone)] 9 | findTransition a b = do 10 | za <- getTimeZone a 11 | zb <- getTimeZone b 12 | if za == zb 13 | then return [] 14 | else do 15 | let 16 | c = addUTCTime ((diffUTCTime b a) / 2) a 17 | if a == c 18 | then return [(b, za, zb)] 19 | else do 20 | tp <- findTransition a c 21 | tq <- findTransition c b 22 | return (tp ++ tq) 23 | 24 | showZoneTime :: TimeZone -> UTCTime -> String 25 | showZoneTime zone time = show (utcToZonedTime zone time) 26 | 27 | showTransition :: (UTCTime, TimeZone, TimeZone) -> String 28 | showTransition (time, zone1, zone2) = (showZoneTime zone1 time) ++ " => " ++ (showZoneTime zone2 time) 29 | 30 | main :: IO () 31 | main = do 32 | now <- getCurrentTime 33 | zone <- getTimeZone now 34 | let 35 | (year, _, _) = toGregorian (localDay (utcToLocalTime zone now)) 36 | putStrLn ("DST adjustments for " ++ show year ++ ":") 37 | let 38 | t0 = monthBeginning zone year 1 39 | let 40 | t1 = monthBeginning zone year 4 41 | let 42 | t2 = monthBeginning zone year 7 43 | let 44 | t3 = monthBeginning zone year 10 45 | let 46 | t4 = monthBeginning zone (year + 1) 1 47 | tr1 <- findTransition t0 t1 48 | tr2 <- findTransition t1 t2 49 | tr3 <- findTransition t2 t3 50 | tr4 <- findTransition t3 t4 51 | mapM_ (putStrLn . showTransition) (tr1 ++ tr2 ++ tr3 ++ tr4) 52 | -------------------------------------------------------------------------------- /test/ShowDefaultTZAbbreviations.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Time 4 | 5 | showTZ :: TimeZone -> String 6 | showTZ tz = 7 | (formatTime defaultTimeLocale "%Z %z" tz) 8 | ++ ( if timeZoneSummerOnly tz 9 | then " DST" 10 | else "" 11 | ) 12 | 13 | main :: IO () 14 | main = mapM_ (\tz -> putStrLn (showTZ tz)) (knownTimeZones defaultTimeLocale) 15 | -------------------------------------------------------------------------------- /test/ShowTime.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Data.Time 4 | 5 | main :: IO () 6 | main = do 7 | now <- getZonedTime 8 | putStrLn $ show now 9 | -------------------------------------------------------------------------------- /test/TimeZone.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Time 4 | 5 | main :: IO () 6 | main = do 7 | zone <- getCurrentTimeZone 8 | putStrLn (timeZoneOffsetString zone) 9 | -------------------------------------------------------------------------------- /test/UseCases.lhs: -------------------------------------------------------------------------------- 1 | > module UseCases where 2 | > import Data.Time.Calendar.OrdinalDate 3 | > import Data.Time 4 | > import System.Locale 5 | 6 | 7 | From Brian Smith: 8 | 9 | 10 | Use cases (primarily taken from real-world corporate IT applications I have 11 | developed) : 12 | 13 | * What is the equivalent (or closest aproximation) of the SQL DateTime type 14 | (date and time without any timezone information)? What is the equivalent of 15 | the SQL Date type (date without any timezone information)? 16 | 17 | > type SQLDateTime = LocalTime 18 | > type SQLDate = Day 19 | 20 | * The user enters a date as "7/4/2005." How do I determine if this date is 21 | before or after July 1st of this year? 22 | 23 | TODO: Parsing 24 | 25 | * How do I present the date "July 1st of this year" to the user in M/D/YYYY 26 | format? 27 | 28 | > july1st = do 29 | > now <- getZonedTime 30 | > let (thisYear,_,_) = toGregorian (localDay (zonedTimeToLocalTime now)) 31 | > let day = fromGregorian thisYear 7 1 32 | > return (formatTime defaultTimeLocale "%m/%d/%Y" day) 33 | 34 | This actually gives "07/01/2005" rather than "7/1/2005". 35 | ISSUE: Should I make additional %-codes for this? 36 | 37 | 38 | * How do I truncate a datetime to midnight of the same day? How do I 39 | truncate a date to the first of the month? How do I truncate a date to the 40 | first day of the year it occurred in? 41 | 42 | > truncateToMidnight (LocalTime day _) = (LocalTime day midnight) 43 | 44 | > truncateToFirstOfMonth day = fromGregorian y m 1 where 45 | > (y,m,_) = toGregorian day 46 | 47 | > truncateToJan1st day = fromOrdinalDate y 1 where 48 | > (y,_) = toOrdinalDate day 49 | 50 | * Given a date X, how do I find the last day of the month that X occurs in. 51 | For example, If X is July 4th, 2005, then I want the result to be July 31st, 52 | 2005. If X is February 5, then I want the result to be February 28 for 53 | non-leap-years and February 29 for leap years. 54 | 55 | > lastDayOfMonth day = fromGregorian y m (gregorianMonthLength y m) where 56 | > (y,m,_) = toGregorian day 57 | 58 | * The user enters a time T with no date, e.g. "17:30". How do I merge this 59 | time onto a date D (e.g. July 4, 2005), so that the result has is a datetime 60 | with date D and the time T (July 4, 2005 at 17:30). 61 | 62 | > mergeDateAndTime = LocalTime 63 | 64 | * Given two datetimes T1, T2, how do I determine if they are on the same 65 | date? 66 | 67 | > sameDay (LocalTime d1 _) (LocalTime d2 _) = d1 == d2 68 | 69 | 70 | From Simon Marlow: 71 | 72 | 73 | I just had a little look around, mainly at System.Time.Calendar. I 74 | think the structure is rather complicated - I wanted to find out how to 75 | get a CalendarTime for "this time tomorrow", and ended up with this: 76 | 77 | *System.Time.Calendar> let c' = 78 | c{ztTime=zttime{dtDay=dtday{gregDay=day+1}}} where { zttime = ztTime c; 79 | dtday = dtDay zttime; day = gregDay dtday } 80 | 81 | > thisTimeTomorrow (ZonedTime (LocalTime day tod) zone) = (ZonedTime (LocalTime (addDays 1 day) tod) zone) 82 | 83 | 84 | -------------------------------------------------------------------------------- /test/main/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Calendar.AddDays 4 | import Test.Calendar.CalendarProps 5 | import Test.Calendar.Calendars 6 | import Test.Calendar.ClipDates 7 | import Test.Calendar.ConvertBack 8 | import Test.Calendar.DayPeriod 9 | import Test.Calendar.Duration 10 | import Test.Calendar.Easter 11 | import Test.Calendar.LongWeekYears 12 | import Test.Calendar.MonthDay 13 | import Test.Calendar.MonthOfYear 14 | import Test.Calendar.Valid 15 | import Test.Calendar.Week 16 | import Test.Calendar.Year 17 | import Test.Clock.Conversion 18 | import Test.Clock.Lift (testLift) 19 | import Test.Clock.Resolution 20 | import Test.Clock.TAI 21 | import Test.Format.Compile () 22 | import Test.Format.Format 23 | import Test.Format.ISO8601 24 | import Test.Format.ParseTime 25 | import Test.LocalTime.CalendarDiffTime 26 | import Test.LocalTime.Time 27 | import Test.LocalTime.TimeOfDay 28 | import Test.Tasty 29 | import Test.Types () 30 | 31 | tests :: TestTree 32 | tests = 33 | testGroup 34 | "Time" 35 | [ testGroup 36 | "Calendar" 37 | [ addDaysTest 38 | , testCalendarProps 39 | , testCalendars 40 | , clipDates 41 | , convertBack 42 | , longWeekYears 43 | , testDayPeriod 44 | , testMonthDay 45 | , testMonthOfYear 46 | , testEaster 47 | , testValid 48 | , testWeek 49 | , testYear 50 | , testDuration 51 | ] 52 | , testGroup "Clock" [testClockConversion, testResolutions, testTAI, testLift] 53 | , testGroup "Format" [testFormat, testParseTime, testISO8601] 54 | , testGroup "LocalTime" [testTime, testTimeOfDay, testCalendarDiffTime] 55 | ] 56 | 57 | main :: IO () 58 | main = defaultMain tests 59 | -------------------------------------------------------------------------------- /test/main/Test/Arbitrary.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -fno-warn-orphans #-} 2 | 3 | module Test.Arbitrary where 4 | 5 | import Control.Monad 6 | import Data.Fixed 7 | import Data.Ratio 8 | import Data.Time 9 | import Data.Time.Calendar.Month 10 | import Data.Time.Calendar.Quarter 11 | import Data.Time.Calendar.WeekDate 12 | import Data.Time.Clock.POSIX 13 | import System.Random 14 | import Test.Tasty.QuickCheck hiding (reason) 15 | 16 | instance Arbitrary DayOfWeek where 17 | arbitrary = fmap toEnum $ choose (1, 7) 18 | 19 | instance Arbitrary FirstWeekType where 20 | arbitrary = do 21 | b <- arbitrary 22 | return $ if b then FirstWholeWeek else FirstMostWeek 23 | 24 | deriving instance Show FirstWeekType 25 | 26 | deriving instance Random Month 27 | 28 | supportedMonthRange :: (Month, Month) 29 | supportedMonthRange = (YearMonth (-9899) 1, YearMonth 9999 12) 30 | 31 | instance Arbitrary Month where 32 | arbitrary = choose supportedMonthRange 33 | 34 | instance Arbitrary Quarter where 35 | arbitrary = liftM MkQuarter $ choose (-30000, 200000) 36 | 37 | instance Arbitrary QuarterOfYear where 38 | arbitrary = liftM toEnum $ choose (1, 4) 39 | 40 | deriving instance Random Day 41 | 42 | supportedDayRange :: (Day, Day) 43 | supportedDayRange = (fromGregorian (-9899) 1 1, fromGregorian 9999 12 31) 44 | 45 | instance Arbitrary Day where 46 | arbitrary = choose supportedDayRange 47 | shrink day = 48 | let 49 | (y, m, d) = toGregorian day 50 | dayShrink = 51 | if d > 1 52 | then [fromGregorian y m (d - 1)] 53 | else [] 54 | monthShrink = 55 | if m > 1 56 | then [fromGregorian y (m - 1) d] 57 | else [] 58 | yearShrink = 59 | if y > 2000 60 | then [fromGregorian (y - 1) m d] 61 | else 62 | if y < 2000 63 | then [fromGregorian (y + 1) m d] 64 | else [] 65 | in 66 | dayShrink ++ monthShrink ++ yearShrink 67 | 68 | instance CoArbitrary Day where 69 | coarbitrary (ModifiedJulianDay d) = coarbitrary d 70 | 71 | instance Arbitrary CalendarDiffDays where 72 | arbitrary = liftM2 CalendarDiffDays arbitrary arbitrary 73 | 74 | instance Arbitrary DiffTime where 75 | arbitrary = oneof [intSecs, fracSecs] -- up to 1 leap second 76 | where 77 | intSecs = liftM secondsToDiffTime' $ choose (0, 86400) 78 | fracSecs = liftM picosecondsToDiffTime' $ choose (0, 86400 * 10 ^ (12 :: Int)) 79 | secondsToDiffTime' :: Integer -> DiffTime 80 | secondsToDiffTime' = fromInteger 81 | picosecondsToDiffTime' :: Integer -> DiffTime 82 | picosecondsToDiffTime' x = fromRational (x % 10 ^ (12 :: Int)) 83 | 84 | instance CoArbitrary DiffTime where 85 | coarbitrary t = coarbitrary (fromEnum t) 86 | 87 | instance Arbitrary NominalDiffTime where 88 | arbitrary = oneof [intSecs, fracSecs] 89 | where 90 | limit = 1000 * 86400 91 | picofactor = 10 ^ (12 :: Int) 92 | intSecs = liftM secondsToDiffTime' $ choose (negate limit, limit) 93 | fracSecs = liftM picosecondsToDiffTime' $ choose (negate limit * picofactor, limit * picofactor) 94 | secondsToDiffTime' :: Integer -> NominalDiffTime 95 | secondsToDiffTime' = fromInteger 96 | picosecondsToDiffTime' :: Integer -> NominalDiffTime 97 | picosecondsToDiffTime' x = fromRational (x % 10 ^ (12 :: Int)) 98 | 99 | instance CoArbitrary NominalDiffTime where 100 | coarbitrary t = coarbitrary (fromEnum t) 101 | 102 | instance Arbitrary CalendarDiffTime where 103 | arbitrary = liftM2 CalendarDiffTime arbitrary arbitrary 104 | 105 | reduceDigits :: Int -> Pico -> Maybe Pico 106 | reduceDigits (-1) _ = Nothing 107 | reduceDigits n x = 108 | let 109 | d :: Pico 110 | d = 10 ^^ (negate n) 111 | r = mod' x d 112 | in 113 | case r of 114 | 0 -> reduceDigits (n - 1) x 115 | _ -> Just $ x - r 116 | 117 | instance Arbitrary TimeOfDay where 118 | arbitrary = liftM timeToTimeOfDay arbitrary 119 | shrink (TimeOfDay h m s) = 120 | let 121 | shrinkInt 0 = [] 122 | shrinkInt 1 = [0] 123 | shrinkInt _ = [0, 1] 124 | shrinkPico 0 = [] 125 | shrinkPico 1 = [0] 126 | shrinkPico p = case reduceDigits 12 p of 127 | Just p' -> [0, 1, p'] 128 | Nothing -> [0, 1] 129 | in 130 | [TimeOfDay h' m s | h' <- shrinkInt h] 131 | ++ [TimeOfDay h m' s | m' <- shrinkInt m] 132 | ++ [TimeOfDay h m s' | s' <- shrinkPico s] 133 | 134 | instance CoArbitrary TimeOfDay where 135 | coarbitrary t = coarbitrary (timeOfDayToTime t) 136 | 137 | instance Arbitrary LocalTime where 138 | arbitrary = liftM2 LocalTime arbitrary arbitrary 139 | shrink (LocalTime d tod) = [LocalTime d' tod | d' <- shrink d] ++ [LocalTime d tod' | tod' <- shrink tod] 140 | 141 | instance CoArbitrary LocalTime where 142 | coarbitrary t = coarbitrary (floor (utcTimeToPOSIXSeconds (localTimeToUTC utc t)) :: Integer) 143 | 144 | instance Arbitrary TimeZone where 145 | arbitrary = liftM minutesToTimeZone $ choose (-720, 720) 146 | shrink (TimeZone 0 _ _) = [] 147 | shrink (TimeZone _ s n) = [TimeZone 0 s n] 148 | 149 | instance CoArbitrary TimeZone where 150 | coarbitrary tz = coarbitrary (timeZoneMinutes tz) 151 | 152 | instance Arbitrary ZonedTime where 153 | arbitrary = liftM2 ZonedTime arbitrary arbitrary 154 | shrink (ZonedTime d tz) = [ZonedTime d' tz | d' <- shrink d] ++ [ZonedTime d tz' | tz' <- shrink tz] 155 | 156 | instance CoArbitrary ZonedTime where 157 | coarbitrary t = coarbitrary (floor (utcTimeToPOSIXSeconds (zonedTimeToUTC t)) :: Integer) 158 | 159 | instance Arbitrary UTCTime where 160 | arbitrary = liftM2 UTCTime arbitrary arbitrary 161 | shrink t = fmap (localTimeToUTC utc) $ shrink $ utcToLocalTime utc t 162 | 163 | instance CoArbitrary UTCTime where 164 | coarbitrary t = coarbitrary (floor (utcTimeToPOSIXSeconds t) :: Integer) 165 | 166 | instance Arbitrary UniversalTime where 167 | arbitrary = liftM (\n -> ModJulianDate $ n % k) $ choose (-313698 * k, 2973483 * k) -- 1000-01-1 to 9999-12-31 168 | where 169 | k = 86400 170 | shrink t = fmap (localTimeToUT1 0) $ shrink $ ut1ToLocalTime 0 t 171 | 172 | instance CoArbitrary UniversalTime where 173 | coarbitrary (ModJulianDate d) = coarbitrary d 174 | -------------------------------------------------------------------------------- /test/main/Test/Calendar/AddDays.hs: -------------------------------------------------------------------------------- 1 | module Test.Calendar.AddDays ( 2 | addDaysTest, 3 | ) where 4 | 5 | import Data.Time.Calendar 6 | import Test.Calendar.AddDaysRef 7 | import Test.Tasty 8 | import Test.Tasty.HUnit 9 | 10 | days :: [Day] 11 | days = 12 | [ fromGregorian 2005 2 28 13 | , fromGregorian 2004 2 29 14 | , fromGregorian 2004 1 31 15 | , fromGregorian 2004 12 31 16 | , fromGregorian 2005 7 1 17 | , fromGregorian 2005 4 21 18 | , fromGregorian 2005 6 30 19 | ] 20 | 21 | increments :: [Integer] 22 | increments = [-10, -4, -1, 0, 1, 7, 83] 23 | 24 | adders :: [(String, Integer -> Day -> Day)] 25 | adders = 26 | [ ("day", addDays) 27 | , ("month (clip)", addGregorianMonthsClip) 28 | , ("month (roll over)", addGregorianMonthsRollOver) 29 | , ("year (clip)", addGregorianYearsClip) 30 | , ("year (roll over)", addGregorianYearsRollOver) 31 | ] 32 | 33 | resultDays :: [String] 34 | resultDays = do 35 | (aname, adder) <- adders 36 | increment <- increments 37 | day <- days 38 | return 39 | ( (showGregorian day) 40 | ++ " + " 41 | ++ (show increment) 42 | ++ " * " 43 | ++ aname 44 | ++ " = " 45 | ++ showGregorian (adder increment day) 46 | ) 47 | 48 | addDaysTest :: TestTree 49 | addDaysTest = testCase "addDays" $ assertEqual "" addDaysRef $ unlines resultDays 50 | -------------------------------------------------------------------------------- /test/main/Test/Calendar/CalendarProps.hs: -------------------------------------------------------------------------------- 1 | module Test.Calendar.CalendarProps ( 2 | testCalendarProps, 3 | ) where 4 | 5 | import Data.Time.Calendar.Month 6 | import Data.Time.Calendar.Quarter 7 | import Test.Arbitrary () 8 | import Test.Tasty 9 | import Test.TestUtil 10 | 11 | testYearMonth :: TestTree 12 | testYearMonth = nameTest "YearMonth" $ \m -> case m of 13 | YearMonth y my -> m == YearMonth y my 14 | 15 | testMonthDay :: TestTree 16 | testMonthDay = nameTest "MonthDay" $ \d -> case d of 17 | MonthDay m dm -> d == MonthDay m dm 18 | 19 | testYearQuarter :: TestTree 20 | testYearQuarter = nameTest "YearQuarter" $ \q -> case q of 21 | YearQuarter y qy -> q == YearQuarter y qy 22 | 23 | testCalendarProps :: TestTree 24 | testCalendarProps = nameTest "calender-props" [testYearMonth, testMonthDay, testYearQuarter] 25 | -------------------------------------------------------------------------------- /test/main/Test/Calendar/Calendars.hs: -------------------------------------------------------------------------------- 1 | module Test.Calendar.Calendars ( 2 | testCalendars, 3 | ) where 4 | 5 | import Data.Time.Calendar 6 | import Data.Time.Calendar.Julian 7 | import Data.Time.Calendar.WeekDate 8 | import Test.Calendar.CalendarsRef 9 | import Test.Tasty 10 | import Test.Tasty.HUnit 11 | 12 | showers :: [(String, Day -> String)] 13 | showers = 14 | [ ("MJD", show . toModifiedJulianDay) 15 | , ("Gregorian", showGregorian) 16 | , ("Julian", showJulian) 17 | , ("ISO 8601", showWeekDate) 18 | ] 19 | 20 | days :: [Day] 21 | days = [fromGregorian 0 12 31, fromJulian 1752 9 2, fromGregorian 1752 9 14, fromGregorian 2005 1 23] 22 | 23 | testCalendars :: TestTree 24 | testCalendars = testCase "testCalendars" $ assertEqual "" testCalendarsRef $ unlines $ map (\d -> showShowers d) days 25 | where 26 | showShowers day = concatMap (\(nm, shower) -> unwords [" ==", nm, shower day]) showers 27 | -------------------------------------------------------------------------------- /test/main/Test/Calendar/CalendarsRef.hs: -------------------------------------------------------------------------------- 1 | module Test.Calendar.CalendarsRef where 2 | 3 | testCalendarsRef :: String 4 | testCalendarsRef = 5 | unlines 6 | [ " == MJD -678576 == Gregorian 0000-12-31 == Julian 0001-01-02 == ISO 8601 0000-W52-7" 7 | , " == MJD -38780 == Gregorian 1752-09-13 == Julian 1752-09-02 == ISO 8601 1752-W37-3" 8 | , " == MJD -38779 == Gregorian 1752-09-14 == Julian 1752-09-03 == ISO 8601 1752-W37-4" 9 | , " == MJD 53393 == Gregorian 2005-01-23 == Julian 2005-01-10 == ISO 8601 2005-W03-7" 10 | ] 11 | -------------------------------------------------------------------------------- /test/main/Test/Calendar/ClipDates.hs: -------------------------------------------------------------------------------- 1 | module Test.Calendar.ClipDates ( 2 | clipDates, 3 | ) where 4 | 5 | import Data.Time.Calendar 6 | import Data.Time.Calendar.OrdinalDate 7 | import Data.Time.Calendar.WeekDate 8 | import Test.Calendar.ClipDatesRef 9 | import Test.Tasty 10 | import Test.Tasty.HUnit 11 | 12 | yearAndDay :: (Integer, Int) -> String 13 | yearAndDay (y, d) = (show y) ++ "-" ++ (show d) ++ " = " ++ (showOrdinalDate (fromOrdinalDate y d)) 14 | 15 | gregorian :: (Integer, Int, Int) -> String 16 | gregorian (y, m, d) = (show y) ++ "-" ++ (show m) ++ "-" ++ (show d) ++ " = " ++ (showGregorian (fromGregorian y m d)) 17 | 18 | iSOWeekDay :: (Integer, Int, Int) -> String 19 | iSOWeekDay (y, w, d) = (show y) ++ "-W" ++ (show w) ++ "-" ++ (show d) ++ " = " ++ (showWeekDate (fromWeekDate y w d)) 20 | 21 | -- 22 | tupleUp2 :: [a] -> [b] -> [(a, b)] 23 | tupleUp2 l1 l2 = concatMap (\e -> map (e,) l2) l1 24 | 25 | tupleUp3 :: [a] -> [b] -> [c] -> [(a, b, c)] 26 | tupleUp3 l1 l2 l3 = 27 | let 28 | ts = tupleUp2 l2 l3 29 | in 30 | concatMap (\e -> map (\(f, g) -> (e, f, g)) ts) l1 31 | 32 | testPairs :: String -> [String] -> [String] -> TestTree 33 | testPairs name expected found = testGroup name $ fmap (\(e, f) -> testCase e $ assertEqual "" e f) $ zip expected found 34 | 35 | -- 36 | clipDates :: TestTree 37 | clipDates = 38 | testGroup 39 | "clipDates" 40 | [ testPairs "YearAndDay" clipDatesYearAndDayRef $ map yearAndDay $ tupleUp2 [1968, 1969, 1971] [-4, 0, 1, 200, 364, 365, 366, 367, 700] 41 | , testPairs "Gregorian" clipDatesGregorianDayRef $ 42 | map gregorian $ 43 | tupleUp3 [1968, 1969, 1971] [-20, -1, 0, 1, 2, 12, 13, 17] [-7, -1, 0, 1, 2, 27, 28, 29, 30, 31, 32, 40] 44 | , testPairs "ISOWeekDay" clipDatesISOWeekDayRef $ 45 | map iSOWeekDay $ 46 | tupleUp3 [1968, 1969, 2004] [-20, -1, 0, 1, 20, 51, 52, 53, 54] [-2, -1, 0, 1, 4, 6, 7, 8, 9] 47 | ] 48 | -------------------------------------------------------------------------------- /test/main/Test/Calendar/ConvertBack.hs: -------------------------------------------------------------------------------- 1 | module Test.Calendar.ConvertBack ( 2 | convertBack, 3 | ) where 4 | 5 | import Data.Time.Calendar 6 | import Data.Time.Calendar.Julian 7 | import Data.Time.Calendar.OrdinalDate 8 | import Data.Time.Calendar.WeekDate 9 | import Test.Tasty 10 | import Test.Tasty.HUnit 11 | 12 | checkDay :: Show t => (Day -> t) -> (t -> Day) -> (t -> Maybe Day) -> Day -> String 13 | checkDay encodeDay decodeDay decodeDayValid day = 14 | let 15 | st = encodeDay day 16 | day' = decodeDay st 17 | mday' = decodeDayValid st 18 | a = 19 | if day /= day' 20 | then unwords [show day, "-> ", show st, "-> ", show day', "(diff", show (diffDays day' day) ++ ")"] 21 | else "" 22 | b = 23 | if Just day /= mday' 24 | then unwords [show day, "->", show st, "->", show mday'] 25 | else "" 26 | in 27 | a ++ b 28 | 29 | checkers :: [Day -> String] 30 | checkers = 31 | [ checkDay toOrdinalDate (\(y, d) -> fromOrdinalDate y d) (\(y, d) -> fromOrdinalDateValid y d) 32 | , checkDay toWeekDate (\(y, w, d) -> fromWeekDate y w d) (\(y, w, d) -> fromWeekDateValid y w d) 33 | , checkDay toGregorian (\(y, m, d) -> fromGregorian y m d) (\(y, m, d) -> fromGregorianValid y m d) 34 | , checkDay toJulian (\(y, m, d) -> fromJulian y m d) (\(y, m, d) -> fromJulianValid y m d) 35 | ] 36 | 37 | days :: [Day] 38 | days = [ModifiedJulianDay 50000 .. ModifiedJulianDay 50200] ++ (fmap (\year -> (fromGregorian year 1 4)) [1980 .. 2000]) 39 | 40 | convertBack :: TestTree 41 | convertBack = testCase "convertBack" $ assertEqual "" "" $ concatMap (\ch -> concatMap ch days) checkers 42 | -------------------------------------------------------------------------------- /test/main/Test/Calendar/DayPeriod.hs: -------------------------------------------------------------------------------- 1 | module Test.Calendar.DayPeriod ( 2 | testDayPeriod, 3 | ) where 4 | 5 | import Data.Time.Calendar 6 | import Data.Time.Calendar.Month 7 | import Data.Time.Calendar.Quarter 8 | import Test.Arbitrary () 9 | import Test.Tasty 10 | import Test.Tasty.HUnit 11 | import Test.Tasty.QuickCheck 12 | 13 | newtype WDay = MkWDay Day 14 | deriving (Eq, Show) 15 | 16 | instance Arbitrary WDay where 17 | arbitrary = do 18 | (MkWYear y) <- arbitrary 19 | (MkWMonthOfYear m) <- arbitrary 20 | (MkWDayOfMonth d) <- arbitrary 21 | pure $ MkWDay $ YearMonthDay y m d 22 | 23 | newtype WYear = MkWYear Year 24 | deriving (Eq, Show) 25 | 26 | instance Arbitrary WYear where 27 | arbitrary = fmap MkWYear $ choose (-1000, 3000) 28 | 29 | newtype WMonthOfYear = MkWMonthOfYear MonthOfYear 30 | deriving (Eq, Show) 31 | 32 | instance Arbitrary WMonthOfYear where 33 | arbitrary = fmap MkWMonthOfYear $ choose (-5, 17) 34 | 35 | newtype WMonth = MkWMonth Month 36 | deriving (Eq, Show) 37 | 38 | instance Arbitrary WMonth where 39 | arbitrary = do 40 | (MkWYear y) <- arbitrary 41 | (MkWMonthOfYear m) <- arbitrary 42 | pure $ MkWMonth $ YearMonth y m 43 | 44 | newtype WDayOfMonth = MkWDayOfMonth DayOfMonth 45 | deriving (Eq, Show) 46 | 47 | instance Arbitrary WDayOfMonth where 48 | arbitrary = fmap MkWDayOfMonth $ choose (-5, 35) 49 | 50 | newtype WQuarterOfYear = MkWQuarterOfYear QuarterOfYear 51 | deriving (Eq, Show) 52 | 53 | instance Arbitrary WQuarterOfYear where 54 | arbitrary = fmap MkWQuarterOfYear $ elements [Q1 .. Q4] 55 | 56 | newtype WQuarter = MkWQuarter Quarter 57 | deriving (Eq, Show) 58 | 59 | instance Arbitrary WQuarter where 60 | arbitrary = do 61 | (MkWYear y) <- arbitrary 62 | (MkWQuarterOfYear q) <- arbitrary 63 | pure $ MkWQuarter $ YearQuarter y q 64 | 65 | testDayPeriod :: TestTree 66 | testDayPeriod = 67 | testGroup 68 | "DayPeriod" 69 | [ testGroup "Day" testDay 70 | , testGroup "Month" testMonth 71 | , testGroup "Quarter" testQuarter 72 | , testGroup "Year" testYear 73 | , testGroup "Week" testWeek 74 | ] 75 | 76 | testDay :: [TestTree] 77 | testDay = 78 | [ testProperty "periodFirstDay" $ \(MkWDay d) -> 79 | periodFirstDay d == d 80 | , testProperty "periodLastDay" $ \(MkWDay d) -> 81 | periodLastDay d == d 82 | , testProperty "dayPeriod" $ \(MkWDay d) -> 83 | dayPeriod d == d 84 | , testProperty "periodAllDays" $ \(MkWDay d) -> 85 | periodAllDays d == [d] 86 | , testProperty "periodLength" $ \(MkWDay d) -> 87 | periodLength d == 1 88 | ] 89 | 90 | testMonth :: [TestTree] 91 | testMonth = 92 | [ testProperty "periodFirstDay" $ \(MkWMonth my@(YearMonth y m)) -> 93 | periodFirstDay my == YearMonthDay y m 1 94 | , testGroup 95 | "periodLastDay" 96 | [ testCase "leap year" $ 97 | periodLastDay (YearMonth 2024 February) @?= YearMonthDay 2024 February 29 98 | , testCase "regular year" $ 99 | periodLastDay (YearMonth 2023 February) @?= YearMonthDay 2023 February 28 100 | ] 101 | , testProperty "dayPeriod" $ \(MkWMonth my@(YearMonth y m), MkWDayOfMonth d) -> 102 | dayPeriod (YearMonthDay y m d) == my 103 | , testProperty "periodAllDays" $ \(MkWMonth my@(YearMonth y1 m1)) -> 104 | all (== (y1, m1)) $ map (\(YearMonthDay y2 m2 _) -> (y2, m2)) $ periodAllDays my 105 | , testGroup 106 | "periodLength" 107 | [ testProperty "property tests" $ \(MkWMonth my) -> 108 | periodLength my >= 28 109 | , testCase "leap year" $ 110 | periodLength (YearMonth 2024 February) @?= 29 111 | , testCase "regular year" $ 112 | periodLength (YearMonth 2023 February) @?= 28 113 | ] 114 | ] 115 | 116 | testQuarter :: [TestTree] 117 | testQuarter = 118 | [ testGroup 119 | "periodFirstDay" 120 | [ testProperty "Q1" $ \(MkWYear y) -> 121 | periodFirstDay (YearQuarter y Q1) == YearMonthDay y January 1 122 | , testProperty "Q2" $ \(MkWYear y) -> 123 | periodFirstDay (YearQuarter y Q2) == YearMonthDay y April 1 124 | , testProperty "Q3" $ \(MkWYear y) -> 125 | periodFirstDay (YearQuarter y Q3) == YearMonthDay y July 1 126 | , testProperty "Q4" $ \(MkWYear y) -> 127 | periodFirstDay (YearQuarter y Q4) == YearMonthDay y October 1 128 | ] 129 | , testGroup 130 | "periodLastDay" 131 | [ testProperty "Q1" $ \(MkWYear y) -> 132 | periodLastDay (YearQuarter y Q1) == YearMonthDay y March 31 133 | , testProperty "Q2" $ \(MkWYear y) -> 134 | periodLastDay (YearQuarter y Q2) == YearMonthDay y June 30 135 | , testProperty "Q3" $ \(MkWYear y) -> 136 | periodLastDay (YearQuarter y Q3) == YearMonthDay y September 30 137 | , testProperty "Q4" $ \(MkWYear y) -> 138 | periodLastDay (YearQuarter y Q4) == YearMonthDay y December 31 139 | ] 140 | , testProperty "dayPeriod" $ \(MkWMonth my@(YearMonth y m), MkWDayOfMonth d) -> 141 | dayPeriod (YearMonthDay y m d) == monthQuarter my 142 | , testProperty "periodAllDays" $ \(MkWQuarter q) -> 143 | all (== q) $ map dayQuarter $ periodAllDays q 144 | , testProperty "periodLength" $ \(MkWQuarter q) -> 145 | periodLength q >= 90 146 | ] 147 | 148 | testYear :: [TestTree] 149 | testYear = 150 | [ testProperty "periodFirstDay" $ \(MkWYear y) -> 151 | periodFirstDay y == YearMonthDay y January 1 152 | , testProperty "periodLastDay" $ \(MkWYear y) -> 153 | periodLastDay y == YearMonthDay y December 31 154 | , testProperty "dayPeriod" $ \(MkWYear y, MkWMonthOfYear m, MkWDayOfMonth d) -> 155 | dayPeriod (YearMonthDay y m d) == y 156 | , testProperty "periodAllDays" $ \(MkWYear y1) -> 157 | all (== y1) $ map (\(YearMonthDay y2 _ _) -> y2) $ periodAllDays y1 158 | , testProperty "periodLength" $ \(MkWYear y) -> 159 | periodLength y >= 365 160 | ] 161 | 162 | testWeek :: [TestTree] 163 | testWeek = 164 | [ testProperty "weekFirstDay/weekLastDay range" $ \dw (MkWDay d) -> 165 | let 166 | f = weekFirstDay dw d 167 | l = weekLastDay dw d 168 | in 169 | f <= d && d <= l 170 | , testProperty "weekFirstDay/weekLastDay range" $ \dw (MkWDay d) -> 171 | let 172 | f = weekFirstDay dw d 173 | l = weekLastDay dw d 174 | in 175 | addDays 6 f == l 176 | , testProperty "weekFirstDay dayOfWeek" $ \dw (MkWDay d) -> 177 | let 178 | f = weekFirstDay dw d 179 | in 180 | dayOfWeek f == dw 181 | ] 182 | -------------------------------------------------------------------------------- /test/main/Test/Calendar/Duration.hs: -------------------------------------------------------------------------------- 1 | module Test.Calendar.Duration ( 2 | testDuration, 3 | ) where 4 | 5 | import Data.Time.Calendar 6 | import Data.Time.Calendar.Julian 7 | import Test.Arbitrary () 8 | import Test.Tasty 9 | import Test.Tasty.HUnit 10 | import Test.Tasty.QuickCheck hiding (reason) 11 | 12 | data AddDiff = MkAddDiff 13 | { adName :: String 14 | , adAdd :: CalendarDiffDays -> Day -> Day 15 | , adDifference :: Day -> Day -> CalendarDiffDays 16 | , adFromYMD :: Integer -> Int -> Int -> Day 17 | } 18 | 19 | gregorianClip :: AddDiff 20 | gregorianClip = MkAddDiff "gregorianClip" addGregorianDurationClip diffGregorianDurationClip fromGregorian 21 | 22 | gregorianRollOver :: AddDiff 23 | gregorianRollOver = MkAddDiff "gregorianRollOver" addGregorianDurationRollOver diffGregorianDurationRollOver fromGregorian 24 | 25 | julianClip :: AddDiff 26 | julianClip = MkAddDiff "julianClip" addJulianDurationClip diffJulianDurationClip fromJulian 27 | 28 | julianRollOver :: AddDiff 29 | julianRollOver = MkAddDiff "julianRollOver" addJulianDurationRollOver diffJulianDurationRollOver fromJulian 30 | 31 | addDiffs :: [AddDiff] 32 | addDiffs = 33 | [ gregorianClip 34 | , gregorianRollOver 35 | , julianClip 36 | , julianRollOver 37 | ] 38 | 39 | testAddDiff :: AddDiff -> TestTree 40 | testAddDiff MkAddDiff{..} = testProperty adName $ \day1 day2 -> 41 | adAdd (adDifference day2 day1) day1 == day2 42 | 43 | testAddDiffs :: TestTree 44 | testAddDiffs = 45 | testGroup 46 | "add-diff" 47 | $ fmap testAddDiff addDiffs 48 | 49 | newtype Smallish = MkSmallish Integer deriving (Eq, Ord) 50 | 51 | deriving newtype instance Show Smallish 52 | 53 | instance Arbitrary Smallish where 54 | arbitrary = do 55 | b <- arbitrary 56 | n <- if b then choose (0, 60) else return 30 57 | return $ MkSmallish n 58 | 59 | testPositiveDiff :: AddDiff -> TestTree 60 | testPositiveDiff MkAddDiff{..} = testProperty adName $ \day1 (MkSmallish i) -> 61 | let 62 | day2 = addDays i day1 63 | r = adDifference day2 day1 64 | in 65 | property $ cdMonths r >= 0 && cdDays r >= 0 66 | 67 | testPositiveDiffs :: TestTree 68 | testPositiveDiffs = 69 | testGroup 70 | "positive-diff" 71 | $ fmap testPositiveDiff addDiffs 72 | 73 | testSpecific :: AddDiff -> (Integer, Int, Int) -> (Integer, Int, Int) -> (Integer, Integer) -> TestTree 74 | testSpecific MkAddDiff{..} (y2, m2, d2) (y1, m1, d1) (em, ed) = 75 | let 76 | day1 = adFromYMD y1 m1 d1 77 | day2 = adFromYMD y2 m2 d2 78 | expected = CalendarDiffDays em ed 79 | found = adDifference day2 day1 80 | in 81 | testCase (adName ++ ": " ++ show day2 ++ " - " ++ show day1) $ do 82 | assertEqual "add" day2 $ adAdd found day1 83 | assertEqual "diff" expected found 84 | 85 | testSpecificPair :: (Integer, Int, Int) -> (Integer, Int, Int) -> (Integer, Integer) -> (Integer, Integer) -> TestTree 86 | testSpecificPair day2 day1 clipD rollD = 87 | testGroup 88 | (show day2 ++ " - " ++ show day1) 89 | [ testSpecific gregorianClip day2 day1 clipD 90 | , testSpecific gregorianRollOver day2 day1 rollD 91 | , testSpecific julianClip day2 day1 clipD 92 | , testSpecific julianRollOver day2 day1 rollD 93 | ] 94 | 95 | testSpecifics :: TestTree 96 | testSpecifics = 97 | testGroup 98 | "specific" 99 | [ testSpecificPair (2017, 04, 07) (2017, 04, 07) (0, 0) (0, 0) 100 | , testSpecific gregorianClip (2017, 04, 07) (2017, 04, 01) (0, 6) 101 | , testSpecific gregorianClip (2017, 04, 01) (2017, 04, 07) (0, -6) 102 | , testSpecific gregorianClip (2017, 04, 07) (2017, 02, 01) (2, 6) 103 | , testSpecific gregorianClip (2017, 02, 01) (2017, 04, 07) (-2, -6) 104 | , testSpecificPair (2000, 03, 01) (2000, 01, 30) (1, 1) (1, 0) 105 | , testSpecificPair (2001, 03, 01) (2001, 01, 30) (1, 1) (0, 30) 106 | , testSpecificPair (2001, 03, 01) (2000, 01, 30) (13, 1) (12, 30) 107 | , testSpecificPair (2000, 03, 01) (2000, 01, 31) (1, 1) (0, 30) 108 | , testSpecificPair (2001, 03, 01) (2001, 01, 31) (1, 1) (0, 29) 109 | , testSpecificPair (2001, 03, 01) (2000, 01, 31) (13, 1) (12, 29) 110 | , testSpecificPair (2001, 10, 01) (2001, 08, 31) (1, 1) (1, 0) 111 | ] 112 | 113 | testDuration :: TestTree 114 | testDuration = testGroup "CalendarDiffDays" [testAddDiffs, testPositiveDiffs, testSpecifics] 115 | -------------------------------------------------------------------------------- /test/main/Test/Calendar/Easter.hs: -------------------------------------------------------------------------------- 1 | module Test.Calendar.Easter ( 2 | testEaster, 3 | ) where 4 | 5 | import Data.Time.Calendar 6 | import Data.Time.Calendar.Easter 7 | import Data.Time.Format 8 | import Test.Calendar.EasterRef 9 | import Test.Tasty 10 | import Test.Tasty.HUnit 11 | 12 | -- 13 | days :: [Day] 14 | days = [ModifiedJulianDay 53000 .. ModifiedJulianDay 53014] 15 | 16 | showWithWDay :: Day -> String 17 | showWithWDay = formatTime defaultTimeLocale "%F %A" 18 | 19 | testEaster :: TestTree 20 | testEaster = 21 | testCase "testEaster" $ 22 | let 23 | ds = unlines $ map (\day -> unwords [showWithWDay day, "->", showWithWDay (sundayAfter day)]) days 24 | f y = 25 | unwords 26 | [ show y ++ ", Gregorian: moon," 27 | , show (gregorianPaschalMoon y) ++ ": Easter," 28 | , showWithWDay (gregorianEaster y) 29 | ] 30 | ++ "\n" 31 | g y = 32 | unwords 33 | [ show y ++ ", Orthodox : moon," 34 | , show (orthodoxPaschalMoon y) ++ ": Easter," 35 | , showWithWDay (orthodoxEaster y) 36 | ] 37 | ++ "\n" 38 | in 39 | assertEqual "" testEasterRef $ ds ++ concatMap (\y -> f y ++ g y) [2000 .. 2020] 40 | -------------------------------------------------------------------------------- /test/main/Test/Calendar/EasterRef.hs: -------------------------------------------------------------------------------- 1 | module Test.Calendar.EasterRef where 2 | 3 | testEasterRef :: String 4 | testEasterRef = 5 | unlines 6 | [ "2003-12-27 Saturday -> 2003-12-28 Sunday" 7 | , "2003-12-28 Sunday -> 2004-01-04 Sunday" 8 | , "2003-12-29 Monday -> 2004-01-04 Sunday" 9 | , "2003-12-30 Tuesday -> 2004-01-04 Sunday" 10 | , "2003-12-31 Wednesday -> 2004-01-04 Sunday" 11 | , "2004-01-01 Thursday -> 2004-01-04 Sunday" 12 | , "2004-01-02 Friday -> 2004-01-04 Sunday" 13 | , "2004-01-03 Saturday -> 2004-01-04 Sunday" 14 | , "2004-01-04 Sunday -> 2004-01-11 Sunday" 15 | , "2004-01-05 Monday -> 2004-01-11 Sunday" 16 | , "2004-01-06 Tuesday -> 2004-01-11 Sunday" 17 | , "2004-01-07 Wednesday -> 2004-01-11 Sunday" 18 | , "2004-01-08 Thursday -> 2004-01-11 Sunday" 19 | , "2004-01-09 Friday -> 2004-01-11 Sunday" 20 | , "2004-01-10 Saturday -> 2004-01-11 Sunday" 21 | , "2000, Gregorian: moon, 2000-04-18: Easter, 2000-04-23 Sunday" 22 | , "2000, Orthodox : moon, 2000-04-23: Easter, 2000-04-30 Sunday" 23 | , "2001, Gregorian: moon, 2001-04-08: Easter, 2001-04-15 Sunday" 24 | , "2001, Orthodox : moon, 2001-04-12: Easter, 2001-04-15 Sunday" 25 | , "2002, Gregorian: moon, 2002-03-28: Easter, 2002-03-31 Sunday" 26 | , "2002, Orthodox : moon, 2002-05-01: Easter, 2002-05-05 Sunday" 27 | , "2003, Gregorian: moon, 2003-04-16: Easter, 2003-04-20 Sunday" 28 | , "2003, Orthodox : moon, 2003-04-20: Easter, 2003-04-27 Sunday" 29 | , "2004, Gregorian: moon, 2004-04-05: Easter, 2004-04-11 Sunday" 30 | , "2004, Orthodox : moon, 2004-04-09: Easter, 2004-04-11 Sunday" 31 | , "2005, Gregorian: moon, 2005-03-25: Easter, 2005-03-27 Sunday" 32 | , "2005, Orthodox : moon, 2005-04-28: Easter, 2005-05-01 Sunday" 33 | , "2006, Gregorian: moon, 2006-04-13: Easter, 2006-04-16 Sunday" 34 | , "2006, Orthodox : moon, 2006-04-17: Easter, 2006-04-23 Sunday" 35 | , "2007, Gregorian: moon, 2007-04-02: Easter, 2007-04-08 Sunday" 36 | , "2007, Orthodox : moon, 2007-04-06: Easter, 2007-04-08 Sunday" 37 | , "2008, Gregorian: moon, 2008-03-22: Easter, 2008-03-23 Sunday" 38 | , "2008, Orthodox : moon, 2008-04-25: Easter, 2008-04-27 Sunday" 39 | , "2009, Gregorian: moon, 2009-04-10: Easter, 2009-04-12 Sunday" 40 | , "2009, Orthodox : moon, 2009-04-14: Easter, 2009-04-19 Sunday" 41 | , "2010, Gregorian: moon, 2010-03-30: Easter, 2010-04-04 Sunday" 42 | , "2010, Orthodox : moon, 2010-04-03: Easter, 2010-04-04 Sunday" 43 | , "2011, Gregorian: moon, 2011-04-18: Easter, 2011-04-24 Sunday" 44 | , "2011, Orthodox : moon, 2011-04-22: Easter, 2011-04-24 Sunday" 45 | , "2012, Gregorian: moon, 2012-04-07: Easter, 2012-04-08 Sunday" 46 | , "2012, Orthodox : moon, 2012-04-11: Easter, 2012-04-15 Sunday" 47 | , "2013, Gregorian: moon, 2013-03-27: Easter, 2013-03-31 Sunday" 48 | , "2013, Orthodox : moon, 2013-04-30: Easter, 2013-05-05 Sunday" 49 | , "2014, Gregorian: moon, 2014-04-14: Easter, 2014-04-20 Sunday" 50 | , "2014, Orthodox : moon, 2014-04-18: Easter, 2014-04-20 Sunday" 51 | , "2015, Gregorian: moon, 2015-04-03: Easter, 2015-04-05 Sunday" 52 | , "2015, Orthodox : moon, 2015-04-07: Easter, 2015-04-12 Sunday" 53 | , "2016, Gregorian: moon, 2016-03-23: Easter, 2016-03-27 Sunday" 54 | , "2016, Orthodox : moon, 2016-04-26: Easter, 2016-05-01 Sunday" 55 | , "2017, Gregorian: moon, 2017-04-11: Easter, 2017-04-16 Sunday" 56 | , "2017, Orthodox : moon, 2017-04-15: Easter, 2017-04-16 Sunday" 57 | , "2018, Gregorian: moon, 2018-03-31: Easter, 2018-04-01 Sunday" 58 | , "2018, Orthodox : moon, 2018-04-04: Easter, 2018-04-08 Sunday" 59 | , "2019, Gregorian: moon, 2019-04-18: Easter, 2019-04-21 Sunday" 60 | , "2019, Orthodox : moon, 2019-04-23: Easter, 2019-04-28 Sunday" 61 | , "2020, Gregorian: moon, 2020-04-08: Easter, 2020-04-12 Sunday" 62 | , "2020, Orthodox : moon, 2020-04-12: Easter, 2020-04-19 Sunday" 63 | ] 64 | -------------------------------------------------------------------------------- /test/main/Test/Calendar/LongWeekYears.hs: -------------------------------------------------------------------------------- 1 | module Test.Calendar.LongWeekYears ( 2 | longWeekYears, 3 | ) where 4 | 5 | import Data.Time.Calendar 6 | import Data.Time.Calendar.WeekDate 7 | import Test.Calendar.LongWeekYearsRef 8 | import Test.Tasty 9 | import Test.Tasty.HUnit 10 | 11 | longYear :: Integer -> Bool 12 | longYear year = 13 | case toWeekDate (fromGregorian year 12 31) of 14 | (_, 53, _) -> True 15 | _ -> False 16 | 17 | showLongYear :: Integer -> String 18 | showLongYear year = 19 | unwords 20 | [ show year ++ ":" 21 | , ( if isLeapYear year 22 | then "L" 23 | else " " 24 | ) 25 | ++ ( if longYear year 26 | then "*" 27 | else " " 28 | ) 29 | ] 30 | 31 | longWeekYears :: TestTree 32 | longWeekYears = testCase "longWeekYears" $ assertEqual "" longWeekYearsRef $ unlines $ map showLongYear [1901 .. 2050] 33 | -------------------------------------------------------------------------------- /test/main/Test/Calendar/LongWeekYearsRef.hs: -------------------------------------------------------------------------------- 1 | module Test.Calendar.LongWeekYearsRef where 2 | 3 | longWeekYearsRef :: String 4 | longWeekYearsRef = 5 | unlines 6 | [ "1901: " 7 | , "1902: " 8 | , "1903: *" 9 | , "1904: L " 10 | , "1905: " 11 | , "1906: " 12 | , "1907: " 13 | , "1908: L*" 14 | , "1909: " 15 | , "1910: " 16 | , "1911: " 17 | , "1912: L " 18 | , "1913: " 19 | , "1914: *" 20 | , "1915: " 21 | , "1916: L " 22 | , "1917: " 23 | , "1918: " 24 | , "1919: " 25 | , "1920: L*" 26 | , "1921: " 27 | , "1922: " 28 | , "1923: " 29 | , "1924: L " 30 | , "1925: *" 31 | , "1926: " 32 | , "1927: " 33 | , "1928: L " 34 | , "1929: " 35 | , "1930: " 36 | , "1931: *" 37 | , "1932: L " 38 | , "1933: " 39 | , "1934: " 40 | , "1935: " 41 | , "1936: L*" 42 | , "1937: " 43 | , "1938: " 44 | , "1939: " 45 | , "1940: L " 46 | , "1941: " 47 | , "1942: *" 48 | , "1943: " 49 | , "1944: L " 50 | , "1945: " 51 | , "1946: " 52 | , "1947: " 53 | , "1948: L*" 54 | , "1949: " 55 | , "1950: " 56 | , "1951: " 57 | , "1952: L " 58 | , "1953: *" 59 | , "1954: " 60 | , "1955: " 61 | , "1956: L " 62 | , "1957: " 63 | , "1958: " 64 | , "1959: *" 65 | , "1960: L " 66 | , "1961: " 67 | , "1962: " 68 | , "1963: " 69 | , "1964: L*" 70 | , "1965: " 71 | , "1966: " 72 | , "1967: " 73 | , "1968: L " 74 | , "1969: " 75 | , "1970: *" 76 | , "1971: " 77 | , "1972: L " 78 | , "1973: " 79 | , "1974: " 80 | , "1975: " 81 | , "1976: L*" 82 | , "1977: " 83 | , "1978: " 84 | , "1979: " 85 | , "1980: L " 86 | , "1981: *" 87 | , "1982: " 88 | , "1983: " 89 | , "1984: L " 90 | , "1985: " 91 | , "1986: " 92 | , "1987: *" 93 | , "1988: L " 94 | , "1989: " 95 | , "1990: " 96 | , "1991: " 97 | , "1992: L*" 98 | , "1993: " 99 | , "1994: " 100 | , "1995: " 101 | , "1996: L " 102 | , "1997: " 103 | , "1998: *" 104 | , "1999: " 105 | , "2000: L " 106 | , "2001: " 107 | , "2002: " 108 | , "2003: " 109 | , "2004: L*" 110 | , "2005: " 111 | , "2006: " 112 | , "2007: " 113 | , "2008: L " 114 | , "2009: *" 115 | , "2010: " 116 | , "2011: " 117 | , "2012: L " 118 | , "2013: " 119 | , "2014: " 120 | , "2015: *" 121 | , "2016: L " 122 | , "2017: " 123 | , "2018: " 124 | , "2019: " 125 | , "2020: L*" 126 | , "2021: " 127 | , "2022: " 128 | , "2023: " 129 | , "2024: L " 130 | , "2025: " 131 | , "2026: *" 132 | , "2027: " 133 | , "2028: L " 134 | , "2029: " 135 | , "2030: " 136 | , "2031: " 137 | , "2032: L*" 138 | , "2033: " 139 | , "2034: " 140 | , "2035: " 141 | , "2036: L " 142 | , "2037: *" 143 | , "2038: " 144 | , "2039: " 145 | , "2040: L " 146 | , "2041: " 147 | , "2042: " 148 | , "2043: *" 149 | , "2044: L " 150 | , "2045: " 151 | , "2046: " 152 | , "2047: " 153 | , "2048: L*" 154 | , "2049: " 155 | , "2050: " 156 | ] 157 | -------------------------------------------------------------------------------- /test/main/Test/Calendar/MonthDay.hs: -------------------------------------------------------------------------------- 1 | module Test.Calendar.MonthDay ( 2 | testMonthDay, 3 | ) where 4 | 5 | import Data.Time.Calendar.MonthDay 6 | import Test.Calendar.MonthDayRef 7 | import Test.Tasty 8 | import Test.Tasty.HUnit 9 | 10 | showCompare :: (Eq a, Show a) => a -> String -> a -> String 11 | showCompare a1 b a2 12 | | a1 == a2 = (show a1) ++ " == " ++ b 13 | showCompare a1 b a2 = "DIFF: " ++ (show a1) ++ " -> " ++ b ++ " -> " ++ (show a2) 14 | 15 | testMonthDay :: TestTree 16 | testMonthDay = 17 | testCase "testMonthDay" $ 18 | assertEqual "" testMonthDayRef $ 19 | concat $ 20 | map (\isL -> unlines (leap isL : yearDays isL)) [False, True] 21 | where 22 | leap isLeap = 23 | if isLeap 24 | then "Leap:" 25 | else "Regular:" 26 | yearDays isLeap = 27 | map 28 | ( \yd -> 29 | let 30 | (m, d) = dayOfYearToMonthAndDay isLeap yd 31 | yd' = monthAndDayToDayOfYear isLeap m d 32 | mdtext = show m ++ "-" ++ show d 33 | in 34 | showCompare yd mdtext yd' 35 | ) 36 | [-2 .. 369] 37 | -------------------------------------------------------------------------------- /test/main/Test/Calendar/MonthOfYear.hs: -------------------------------------------------------------------------------- 1 | module Test.Calendar.MonthOfYear ( 2 | testMonthOfYear, 3 | ) where 4 | 5 | import Data.Foldable 6 | import Data.Time.Calendar 7 | import Test.Tasty 8 | import Test.Tasty.HUnit 9 | 10 | matchMonthOfYear :: MonthOfYear -> Int 11 | matchMonthOfYear m = case m of 12 | January -> 1 13 | February -> 2 14 | March -> 3 15 | April -> 4 16 | May -> 5 17 | June -> 6 18 | July -> 7 19 | August -> 8 20 | September -> 9 21 | October -> 10 22 | November -> 11 23 | December -> 12 24 | 25 | testMonthOfYear :: TestTree 26 | testMonthOfYear = testCase "MonthOfYear" $ for_ [1 .. 12] $ \m -> assertEqual (show m) m $ matchMonthOfYear m 27 | -------------------------------------------------------------------------------- /test/main/Test/Calendar/Valid.hs: -------------------------------------------------------------------------------- 1 | module Test.Calendar.Valid ( 2 | testValid, 3 | ) where 4 | 5 | import Data.Time 6 | import Data.Time.Calendar.Julian 7 | import Data.Time.Calendar.OrdinalDate 8 | import Data.Time.Calendar.WeekDate 9 | import Test.QuickCheck.Property 10 | import Test.Tasty 11 | import Test.Tasty.QuickCheck hiding (reason) 12 | 13 | validResult :: (Eq c, Show c, Eq t, Show t) => (s -> c) -> Bool -> (t -> c) -> (c -> t) -> (c -> Maybe t) -> s -> Result 14 | validResult sc valid toComponents fromComponents fromComponentsValid s = 15 | let 16 | c = sc s 17 | mt = fromComponentsValid c 18 | t' = fromComponents c 19 | c' = toComponents t' 20 | in 21 | if valid 22 | then case mt of 23 | Nothing -> rejected 24 | Just t -> 25 | if t' /= t 26 | then failed{reason = "'fromValid' gives " ++ show t ++ ", but 'from' gives " ++ show t'} 27 | else 28 | if c' /= c 29 | then 30 | failed 31 | { reason = 32 | "found valid, but converts " 33 | ++ show c 34 | ++ " -> " 35 | ++ show t' 36 | ++ " -> " 37 | ++ show c' 38 | } 39 | else succeeded 40 | else case mt of 41 | Nothing -> 42 | if c' /= c 43 | then succeeded 44 | else failed{reason = show c ++ " found invalid, but converts with " ++ show t'} 45 | Just _ -> rejected 46 | 47 | validTest :: 48 | (Arbitrary s, Show s, Eq c, Show c, Eq t, Show t) => 49 | String -> 50 | (s -> c) -> 51 | (t -> c) -> 52 | (c -> t) -> 53 | (c -> Maybe t) -> 54 | TestTree 55 | validTest name sc toComponents fromComponents fromComponentsValid = 56 | testGroup 57 | name 58 | [ testProperty "valid" $ property $ validResult sc True toComponents fromComponents fromComponentsValid 59 | , testProperty "invalid" $ property $ validResult sc False toComponents fromComponents fromComponentsValid 60 | ] 61 | 62 | toSundayStartWeek :: Day -> (Integer, Int, Int) 63 | toSundayStartWeek day = 64 | let 65 | (y, _) = toOrdinalDate day 66 | (w, d) = sundayStartWeek day 67 | in 68 | (y, w, d) 69 | 70 | toMondayStartWeek :: Day -> (Integer, Int, Int) 71 | toMondayStartWeek day = 72 | let 73 | (y, _) = toOrdinalDate day 74 | (w, d) = mondayStartWeek day 75 | in 76 | (y, w, d) 77 | 78 | newtype WYear 79 | = MkWYear Year 80 | deriving (Eq, Show) 81 | 82 | instance Arbitrary WYear where 83 | arbitrary = fmap MkWYear $ choose (-1000, 3000) 84 | 85 | newtype WMonthOfYear 86 | = MkWMonthOfYear MonthOfYear 87 | deriving (Eq, Show) 88 | 89 | instance Arbitrary WMonthOfYear where 90 | arbitrary = fmap MkWMonthOfYear $ choose (-5, 17) 91 | 92 | newtype WDayOfMonth 93 | = MkWDayOfMonth DayOfMonth 94 | deriving (Eq, Show) 95 | 96 | instance Arbitrary WDayOfMonth where 97 | arbitrary = fmap MkWDayOfMonth $ choose (-5, 35) 98 | 99 | newtype WDayOfYear 100 | = MkWDayOfYear DayOfYear 101 | deriving (Eq, Show) 102 | 103 | instance Arbitrary WDayOfYear where 104 | arbitrary = fmap MkWDayOfYear $ choose (-20, 400) 105 | 106 | newtype WWeekOfYear 107 | = MkWWeekOfYear WeekOfYear 108 | deriving (Eq, Show) 109 | 110 | instance Arbitrary WWeekOfYear where 111 | arbitrary = fmap MkWWeekOfYear $ choose (-5, 60) 112 | 113 | newtype WDayOfWeek 114 | = MkWDayOfWeek Int 115 | deriving (Eq, Show) 116 | 117 | instance Arbitrary WDayOfWeek where 118 | arbitrary = fmap MkWDayOfWeek $ choose (-5, 15) 119 | 120 | fromYMD :: (WYear, WMonthOfYear, WDayOfMonth) -> (Year, MonthOfYear, DayOfMonth) 121 | fromYMD (MkWYear y, MkWMonthOfYear ym, MkWDayOfMonth md) = (y, ym, md) 122 | 123 | fromYD :: (WYear, WDayOfYear) -> (Year, DayOfYear) 124 | fromYD (MkWYear y, MkWDayOfYear yd) = (y, yd) 125 | 126 | fromYWD :: (WYear, WWeekOfYear, WDayOfWeek) -> (Year, WeekOfYear, Int) 127 | fromYWD (MkWYear y, MkWWeekOfYear yw, MkWDayOfWeek wd) = (y, yw, wd) 128 | 129 | testValid :: TestTree 130 | testValid = 131 | testGroup 132 | "testValid" 133 | [ validTest 134 | "Gregorian" 135 | fromYMD 136 | toGregorian 137 | (\(y, m, d) -> fromGregorian y m d) 138 | (\(y, m, d) -> fromGregorianValid y m d) 139 | , validTest 140 | "OrdinalDate" 141 | fromYD 142 | toOrdinalDate 143 | (\(y, d) -> fromOrdinalDate y d) 144 | (\(y, d) -> fromOrdinalDateValid y d) 145 | , validTest 146 | "WeekDate" 147 | fromYWD 148 | toWeekDate 149 | (\(y, w, d) -> fromWeekDate y w d) 150 | (\(y, w, d) -> fromWeekDateValid y w d) 151 | , validTest 152 | "SundayStartWeek" 153 | fromYWD 154 | toSundayStartWeek 155 | (\(y, w, d) -> fromSundayStartWeek y w d) 156 | (\(y, w, d) -> fromSundayStartWeekValid y w d) 157 | , validTest 158 | "MondayStartWeek" 159 | fromYWD 160 | toMondayStartWeek 161 | (\(y, w, d) -> fromMondayStartWeek y w d) 162 | (\(y, w, d) -> fromMondayStartWeekValid y w d) 163 | , validTest "Julian" fromYMD toJulian (\(y, m, d) -> fromJulian y m d) (\(y, m, d) -> fromJulianValid y m d) 164 | ] 165 | -------------------------------------------------------------------------------- /test/main/Test/Calendar/Year.hs: -------------------------------------------------------------------------------- 1 | module Test.Calendar.Year ( 2 | testYear, 3 | ) where 4 | 5 | import Data.Time.Calendar 6 | import Data.Time.Calendar.OrdinalDate 7 | import Test.Arbitrary () 8 | import Test.Tasty 9 | import Test.Tasty.HUnit 10 | import Test.TestUtil 11 | 12 | cbRoundTrip :: TestTree 13 | cbRoundTrip = nameTest "CE-BCE" $ \(YearDay y _) -> case y of 14 | CommonEra n -> case id y of 15 | BeforeCommonEra _ -> False 16 | _ -> n >= 1 && y == CommonEra n 17 | _ -> case id y of 18 | BeforeCommonEra n -> n >= 1 && y == BeforeCommonEra n 19 | _ -> False 20 | 21 | testYear :: TestTree 22 | testYear = 23 | nameTest 24 | "Year" 25 | [ cbRoundTrip 26 | , nameTest "succ 1" $ assertEqual "" (BeforeCommonEra 1) $ succ $ BeforeCommonEra 2 27 | , nameTest "succ 2" $ assertEqual "" (CommonEra 1) $ succ $ BeforeCommonEra 1 28 | , nameTest "succ 3" $ assertEqual "" (CommonEra 2) $ succ $ CommonEra 1 29 | ] 30 | -------------------------------------------------------------------------------- /test/main/Test/Clock/Conversion.hs: -------------------------------------------------------------------------------- 1 | module Test.Clock.Conversion ( 2 | testClockConversion, 3 | ) where 4 | 5 | import Data.Time.Clock 6 | import Data.Time.Clock.System 7 | import Test.Tasty 8 | import Test.Tasty.HUnit 9 | 10 | testClockConversion :: TestTree 11 | testClockConversion = 12 | testGroup "clock conversion" $ 13 | let 14 | testPair :: (SystemTime, UTCTime) -> TestTree 15 | testPair (st, ut) = 16 | testGroup (show ut) $ 17 | [ testCase "systemToUTCTime" $ assertEqual (show ut) ut $ systemToUTCTime st 18 | , testCase "utcToSystemTime" $ assertEqual (show ut) st $ utcToSystemTime ut 19 | ] 20 | in 21 | [ testPair (MkSystemTime 0 0, UTCTime systemEpochDay 0) 22 | , testPair (MkSystemTime 86399 0, UTCTime systemEpochDay 86399) 23 | , testPair (MkSystemTime 86399 999999999, UTCTime systemEpochDay 86399.999999999) 24 | , testPair (MkSystemTime 86399 1000000000, UTCTime systemEpochDay 86400) 25 | , testPair (MkSystemTime 86399 1999999999, UTCTime systemEpochDay 86400.999999999) 26 | , testPair (MkSystemTime 86400 0, UTCTime (succ systemEpochDay) 0) 27 | ] 28 | -------------------------------------------------------------------------------- /test/main/Test/Clock/Lift.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Test.Clock.Lift ( 4 | testLift, 5 | ) where 6 | 7 | import Data.Time.Clock 8 | import qualified Language.Haskell.TH.Syntax as TH 9 | import Test.Tasty 10 | import Test.Tasty.HUnit 11 | 12 | testLift :: TestTree 13 | testLift = 14 | testGroup 15 | "Lift instances" 16 | [ testCase "DiffTime" $ $$(TH.liftTyped (secondsToDiffTime 100)) @?= secondsToDiffTime 100 17 | , testCase "NominalDiffTime" $ $$(TH.liftTyped (secondsToNominalDiffTime 100)) @?= secondsToNominalDiffTime 100 18 | ] 19 | -------------------------------------------------------------------------------- /test/main/Test/Clock/Resolution.hs: -------------------------------------------------------------------------------- 1 | module Test.Clock.Resolution ( 2 | testResolutions, 3 | ) where 4 | 5 | import Control.Concurrent 6 | import Data.Fixed 7 | import Data.Time.Clock 8 | import Data.Time.Clock.TAI 9 | import Test.Tasty 10 | import Test.Tasty.HUnit 11 | 12 | repeatN :: Monad m => Int -> m a -> m [a] 13 | repeatN 0 _ = return [] 14 | repeatN n ma = do 15 | a <- ma 16 | aa <- repeatN (n - 1) ma 17 | return $ a : aa 18 | 19 | gcd' :: Real a => a -> a -> a 20 | gcd' a 0 = a 21 | gcd' a b = gcd' b (mod' a b) 22 | 23 | gcdAll :: Real a => [a] -> a 24 | gcdAll = foldr gcd' 0 25 | 26 | testResolution :: (Show dt, Real dt) => String -> (at -> at -> dt) -> (dt, IO at) -> TestTree 27 | testResolution name timeDiff (reportedRes, getTime) = 28 | testCase name $ do 29 | t0 <- getTime 30 | times0 <- 31 | repeatN 100 $ do 32 | threadDelay 0 33 | getTime 34 | times1 <- 35 | repeatN 100 $ -- 100us 36 | do 37 | threadDelay 1 -- 1us 38 | getTime 39 | times2 <- 40 | repeatN 100 $ -- 1ms 41 | do 42 | threadDelay 10 -- 10us 43 | getTime 44 | times3 <- 45 | repeatN 100 $ -- 10ms 46 | do 47 | threadDelay 100 -- 100us 48 | getTime 49 | times4 <- 50 | repeatN 100 $ -- 100ms 51 | do 52 | threadDelay 1000 -- 1ms 53 | getTime 54 | let 55 | times = fmap (\t -> timeDiff t t0) $ times0 ++ times1 ++ times2 ++ times3 ++ times4 56 | foundGrid = gcdAll times 57 | assertBool ("reported resolution: " <> show reportedRes <> ", found: " <> show foundGrid) $ foundGrid <= reportedRes 58 | 59 | testResolutions :: TestTree 60 | testResolutions = 61 | testGroup "resolution" $ 62 | [testResolution "getCurrentTime" diffUTCTime (realToFrac getTime_resolution, getCurrentTime)] 63 | ++ case taiClock of 64 | Just clock -> [testResolution "taiClock" diffAbsoluteTime clock] 65 | Nothing -> [] 66 | -------------------------------------------------------------------------------- /test/main/Test/Clock/TAI.hs: -------------------------------------------------------------------------------- 1 | module Test.Clock.TAI ( 2 | testTAI, 3 | ) where 4 | 5 | import Data.Time 6 | import Data.Time.Clock.TAI 7 | import Test.Tasty 8 | import Test.Tasty.HUnit 9 | import Test.TestUtil 10 | 11 | sampleLeapSecondMap :: LeapSecondMap 12 | sampleLeapSecondMap d 13 | | d < fromGregorian 1972 1 1 = Nothing 14 | sampleLeapSecondMap d 15 | | d < fromGregorian 1972 7 1 = Just 10 16 | sampleLeapSecondMap d 17 | | d < fromGregorian 1975 1 1 = Just 11 18 | sampleLeapSecondMap _ = Nothing 19 | 20 | testTAI :: TestTree 21 | testTAI = 22 | testGroup "leap second transition" $ 23 | let 24 | dayA = fromGregorian 1972 6 30 25 | dayB = fromGregorian 1972 7 1 26 | utcTime1 = UTCTime dayA 86399 27 | utcTime2 = UTCTime dayA 86400 28 | utcTime3 = UTCTime dayB 0 29 | mAbsTime1 = utcToTAITime sampleLeapSecondMap utcTime1 30 | mAbsTime2 = utcToTAITime sampleLeapSecondMap utcTime2 31 | mAbsTime3 = utcToTAITime sampleLeapSecondMap utcTime3 32 | in 33 | [ testCase "mapping" $ do 34 | assertEqual "dayA" (Just 10) $ sampleLeapSecondMap dayA 35 | assertEqual "dayB" (Just 11) $ sampleLeapSecondMap dayB 36 | , testCase "day length" $ do 37 | assertEqual "dayA" (Just 86401) $ utcDayLength sampleLeapSecondMap dayA 38 | assertEqual "dayB" (Just 86400) $ utcDayLength sampleLeapSecondMap dayB 39 | , testCase "differences" $ do 40 | absTime1 <- assertJust mAbsTime1 41 | absTime2 <- assertJust mAbsTime2 42 | absTime3 <- assertJust mAbsTime3 43 | assertEqual "absTime2 - absTime1" 1 $ diffAbsoluteTime absTime2 absTime1 44 | assertEqual "absTime3 - absTime2" 1 $ diffAbsoluteTime absTime3 absTime2 45 | , testGroup 46 | "round-trip" 47 | [ testCase "1" $ do 48 | absTime <- assertJust mAbsTime1 49 | utcTime <- assertJust $ taiToUTCTime sampleLeapSecondMap absTime 50 | assertEqual "round-trip" utcTime1 utcTime 51 | , testCase "2" $ do 52 | absTime <- assertJust mAbsTime2 53 | utcTime <- assertJust $ taiToUTCTime sampleLeapSecondMap absTime 54 | assertEqual "round-trip" utcTime2 utcTime 55 | , testCase "3" $ do 56 | absTime <- assertJust mAbsTime3 57 | utcTime <- assertJust $ taiToUTCTime sampleLeapSecondMap absTime 58 | assertEqual "round-trip" utcTime3 utcTime 59 | ] 60 | ] 61 | -------------------------------------------------------------------------------- /test/main/Test/Format/Compile.hs: -------------------------------------------------------------------------------- 1 | -- Tests succeed if module compiles 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | 4 | module Test.Format.Compile ( 5 | 6 | ) where 7 | 8 | import Data.Time 9 | 10 | newtype WrappedUTCTime 11 | = MkWrappedUTCTime UTCTime 12 | deriving (FormatTime, ParseTime) 13 | 14 | newtype Wrapped t 15 | = MkWrapped t 16 | deriving (FormatTime, ParseTime) 17 | -------------------------------------------------------------------------------- /test/main/Test/LocalTime/CalendarDiffTime.hs: -------------------------------------------------------------------------------- 1 | module Test.LocalTime.CalendarDiffTime ( 2 | testCalendarDiffTime, 3 | ) where 4 | 5 | import Data.Time 6 | import Test.Arbitrary () 7 | import Test.Tasty 8 | import Test.Tasty.HUnit 9 | import Test.TestUtil 10 | 11 | testReadShowExact :: (Read a, Show a, Eq a) => String -> a -> TestTree 12 | testReadShowExact t v = 13 | nameTest 14 | t 15 | [ nameTest "show" $ assertEqual "show" t $ show v 16 | , nameTest "read" $ assertEqual "read" v $ read t 17 | ] 18 | 19 | testCalendarDiffTime :: TestTree 20 | testCalendarDiffTime = 21 | nameTest 22 | "CalendarDiffTime" 23 | [ testReadShowExact "P0D" $ CalendarDiffTime 0 0 24 | , testReadShowExact "P1DT1S" $ CalendarDiffTime 0 $ secondsToNominalDiffTime 86401 25 | , testReadShowExact "P-1DT1S" $ CalendarDiffTime 0 $ secondsToNominalDiffTime $ negate 86399 26 | , testReadShowExact "P-1D" $ CalendarDiffTime 0 $ secondsToNominalDiffTime $ negate 86400 27 | , testReadShowExact "P-2DT23H59M59S" $ CalendarDiffTime 0 $ secondsToNominalDiffTime $ negate 86401 28 | , testReadShowExact "P1M-1DT1S" $ CalendarDiffTime 1 $ secondsToNominalDiffTime $ negate 86399 29 | , testReadShowExact "P1M-1D" $ CalendarDiffTime 1 $ secondsToNominalDiffTime $ negate 86400 30 | , testReadShowExact "P1M-2DT23H59M59S" $ CalendarDiffTime 1 $ secondsToNominalDiffTime $ negate 86401 31 | , testReadShowExact "P-1Y-1M-1DT1S" $ CalendarDiffTime (-13) $ secondsToNominalDiffTime $ negate 86399 32 | , testReadShowExact "P-1Y-1M-1D" $ CalendarDiffTime (-13) $ secondsToNominalDiffTime $ negate 86400 33 | , testReadShowExact "P-1Y-1M-2DT23H59M59S" $ CalendarDiffTime (-13) $ secondsToNominalDiffTime $ negate 86401 34 | ] 35 | -------------------------------------------------------------------------------- /test/main/Test/LocalTime/Time.hs: -------------------------------------------------------------------------------- 1 | module Test.LocalTime.Time ( 2 | testTime, 3 | ) where 4 | 5 | import Data.Time 6 | import Data.Time.Calendar.OrdinalDate 7 | import Data.Time.Calendar.WeekDate 8 | import Test.LocalTime.TimeRef 9 | import Test.Tasty 10 | import Test.Tasty.HUnit 11 | 12 | showCal :: Integer -> String 13 | showCal mjd = 14 | let 15 | date = ModifiedJulianDay mjd 16 | (y, m, d) = toGregorian date 17 | date' = fromGregorian y m d 18 | in 19 | concat 20 | [ show mjd ++ "=" ++ showGregorian date ++ "=" ++ showOrdinalDate date ++ "=" ++ showWeekDate date ++ "\n" 21 | , if date == date' 22 | then "" 23 | else "=" ++ (show $ toModifiedJulianDay date') ++ "!" 24 | ] 25 | 26 | testCal :: String 27 | testCal = 28 | concat 29 | -- days around 1 BCE/1 CE 30 | [ concatMap showCal [-678950 .. -678930] 31 | , -- days around 1000 CE 32 | concatMap showCal [-313710 .. -313690] 33 | , -- days around MJD zero 34 | concatMap showCal [-30 .. 30] 35 | , showCal 40000 36 | , showCal 50000 37 | , -- 1900 not a leap year 38 | showCal 15078 39 | , showCal 15079 40 | , -- 1980 is a leap year 41 | showCal 44297 42 | , showCal 44298 43 | , showCal 44299 44 | , -- 1990 not a leap year 45 | showCal 47950 46 | , showCal 47951 47 | , -- 2000 is a leap year 48 | showCal 51602 49 | , showCal 51603 50 | , showCal 51604 51 | , -- years 2000 and 2001, plus some slop 52 | concatMap showCal [51540 .. 52280] 53 | ] 54 | 55 | showUTCTime :: UTCTime -> String 56 | showUTCTime (UTCTime d t) = show (toModifiedJulianDay d) ++ "," ++ show t 57 | 58 | myzone :: TimeZone 59 | myzone = hoursToTimeZone (-8) 60 | 61 | leapSec1998Cal :: LocalTime 62 | leapSec1998Cal = LocalTime (fromGregorian 1998 12 31) (TimeOfDay 23 59 60.5) 63 | 64 | leapSec1998 :: UTCTime 65 | leapSec1998 = localTimeToUTC utc leapSec1998Cal 66 | 67 | testUTC :: String 68 | testUTC = 69 | let 70 | lsMineCal = utcToLocalTime myzone leapSec1998 71 | lsMine = localTimeToUTC myzone lsMineCal 72 | in 73 | unlines [showCal 51178, show leapSec1998Cal, showUTCTime leapSec1998, show lsMineCal, showUTCTime lsMine] 74 | 75 | neglong :: Rational 76 | neglong = -120 77 | 78 | poslong :: Rational 79 | poslong = 120 80 | 81 | testUT1 :: String 82 | testUT1 = 83 | unlines 84 | [ show $ ut1ToLocalTime 0 $ ModJulianDate 51604.0 85 | , show $ ut1ToLocalTime 0 $ ModJulianDate 51604.5 86 | , show $ ut1ToLocalTime neglong $ ModJulianDate 51604.0 87 | , show $ ut1ToLocalTime neglong $ ModJulianDate 51604.5 88 | , show $ ut1ToLocalTime poslong $ ModJulianDate 51604.0 89 | , show $ ut1ToLocalTime poslong $ ModJulianDate 51604.5 90 | ] 91 | 92 | testTimeOfDayToDayFraction :: String 93 | testTimeOfDayToDayFraction = 94 | let 95 | f = dayFractionToTimeOfDay . timeOfDayToDayFraction 96 | in 97 | unlines 98 | [ show $ f $ TimeOfDay 12 34 56.789 99 | , show $ f $ TimeOfDay 12 34 56.789123 100 | , show $ f $ TimeOfDay 12 34 56.789123456 101 | , show $ f $ TimeOfDay 12 34 56.789123456789 102 | , show $ f $ TimeOfDay minBound 0 0 103 | ] 104 | 105 | testTime :: TestTree 106 | testTime = 107 | testCase "testTime" $ 108 | assertEqual "times" testTimeRef $ 109 | unlines [testCal, testUTC, testUT1, testTimeOfDayToDayFraction] 110 | -------------------------------------------------------------------------------- /test/main/Test/LocalTime/TimeOfDay.hs: -------------------------------------------------------------------------------- 1 | module Test.LocalTime.TimeOfDay ( 2 | testTimeOfDay, 3 | ) where 4 | 5 | import Data.Time.LocalTime 6 | import Test.Arbitrary () 7 | import Test.Tasty 8 | import Test.Tasty.QuickCheck hiding (reason) 9 | 10 | testTimeOfDay :: TestTree 11 | testTimeOfDay = 12 | testGroup 13 | "TimeOfDay" 14 | [ testProperty "daysAndTimeOfDayToTime . timeToDaysAndTimeOfDay" $ \ndt -> 15 | let 16 | (d, tod) = timeToDaysAndTimeOfDay ndt 17 | ndt' = daysAndTimeOfDayToTime d tod 18 | in 19 | ndt' == ndt 20 | , testProperty "timeOfDayToTime . timeToTimeOfDay" $ \dt -> 21 | let 22 | tod = timeToTimeOfDay dt 23 | dt' = timeOfDayToTime tod 24 | in 25 | dt' == dt 26 | ] 27 | -------------------------------------------------------------------------------- /test/main/Test/TestUtil.hs: -------------------------------------------------------------------------------- 1 | module Test.TestUtil where 2 | 3 | import Test.QuickCheck.Property 4 | import Test.Tasty 5 | import Test.Tasty.HUnit 6 | import Test.Tasty.QuickCheck 7 | 8 | assertFailure' :: String -> IO a 9 | assertFailure' s = do 10 | _ <- assertFailure s -- returns () in some versions 11 | return undefined 12 | 13 | assertJust :: Maybe a -> IO a 14 | assertJust (Just a) = return a 15 | assertJust Nothing = assertFailure' "Nothing" 16 | 17 | class NameTest a where 18 | nameTest :: String -> a -> TestTree 19 | 20 | instance NameTest [TestTree] where 21 | nameTest = testGroup 22 | 23 | instance NameTest Assertion where 24 | nameTest = Test.Tasty.HUnit.testCase 25 | 26 | instance NameTest Property where 27 | nameTest = testProperty 28 | 29 | instance NameTest Result where 30 | nameTest name = nameTest name . property 31 | 32 | instance (Arbitrary a, Show a, Testable b) => NameTest (a -> b) where 33 | nameTest name = nameTest name . property 34 | 35 | tgroup :: (Show a, NameTest t) => [a] -> (a -> t) -> [TestTree] 36 | tgroup aa f = fmap (\a -> nameTest (show a) $ f a) aa 37 | -------------------------------------------------------------------------------- /test/main/Test/Types.hs: -------------------------------------------------------------------------------- 1 | module Test.Types () where 2 | 3 | import Control.DeepSeq 4 | import Data.Data 5 | import Data.Ix 6 | import Data.Time 7 | import Data.Time.Calendar.Month 8 | import Data.Time.Calendar.Quarter 9 | import Data.Time.Clock.System 10 | import Data.Time.Clock.TAI 11 | 12 | class (Typeable t, Data t, NFData t) => CheckDataInstances t 13 | 14 | class (Typeable t, Data t, NFData t, Eq t) => CheckEqInstances t 15 | 16 | class (Typeable t, Data t, NFData t, Eq t, Ord t) => CheckOrdInstances t 17 | 18 | class (Typeable t, Data t, NFData t, Eq t, Ord t, Ix t, Enum t) => CheckEnumInstances t 19 | 20 | class (Typeable t, Data t, NFData t, Eq t, Ord t, Ix t, Enum t, Bounded t) => CheckBoundedInstances t 21 | 22 | instance CheckOrdInstances UTCTime 23 | 24 | instance CheckOrdInstances NominalDiffTime 25 | 26 | instance CheckEnumInstances Day 27 | 28 | instance CheckEnumInstances DayOfWeek 29 | 30 | instance CheckOrdInstances TimeOfDay 31 | 32 | instance CheckOrdInstances LocalTime 33 | 34 | instance CheckOrdInstances TimeZone 35 | 36 | instance CheckDataInstances ZonedTime 37 | 38 | instance CheckEqInstances CalendarDiffDays 39 | 40 | instance CheckEqInstances CalendarDiffTime 41 | 42 | instance CheckEnumInstances Month 43 | 44 | instance CheckEnumInstances Quarter 45 | 46 | instance CheckBoundedInstances QuarterOfYear 47 | 48 | instance CheckOrdInstances SystemTime 49 | 50 | instance CheckOrdInstances AbsoluteTime 51 | 52 | instance CheckOrdInstances UniversalTime 53 | -------------------------------------------------------------------------------- /test/unix/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Format.Format 4 | import Test.LocalTime.TimeZone 5 | import Test.Tasty 6 | 7 | tests :: TestTree 8 | tests = testGroup "Time" [testGroup "Format" testFormat, testGroup "LocalTime" [testTimeZone]] 9 | 10 | main :: IO () 11 | main = defaultMain tests 12 | -------------------------------------------------------------------------------- /test/unix/Test/Format/FormatStuff.c: -------------------------------------------------------------------------------- 1 | #include "FormatStuff.h" 2 | 3 | size_t format_time ( 4 | char* buffer, size_t maxsize, 5 | const char* format, 6 | int isdst,int gmtoff,char* zonename,time_t t) 7 | { 8 | t += gmtoff; 9 | struct tm tmd; 10 | gmtime_r(&t,&tmd); 11 | tmd.tm_isdst = isdst; 12 | tmd.tm_gmtoff = gmtoff; 13 | tmd.tm_zone = zonename; 14 | return strftime(buffer,maxsize,format,&tmd); 15 | } 16 | -------------------------------------------------------------------------------- /test/unix/Test/Format/FormatStuff.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | size_t format_time ( 4 | char *s, size_t maxsize, 5 | const char *format, 6 | int isdst,int gmtoff,char* zonename,time_t t); 7 | -------------------------------------------------------------------------------- /test/unix/Test/LocalTime/TimeZone.hs: -------------------------------------------------------------------------------- 1 | module Test.LocalTime.TimeZone ( 2 | testTimeZone, 3 | ) where 4 | 5 | import Data.Time 6 | import System.Environment (setEnv) 7 | import Test.Tasty 8 | import Test.Tasty.HUnit 9 | 10 | testTimeZone :: TestTree 11 | testTimeZone = 12 | testCase "getTimeZone respects TZ env var" $ do 13 | let 14 | epoch = UTCTime (ModifiedJulianDay 57000) 0 15 | setEnv "TZ" "UTC+0" 16 | zone1 <- getTimeZone epoch 17 | setEnv "TZ" "EST+5" 18 | zone2 <- getTimeZone epoch 19 | assertBool "zone not changed" $ zone1 /= zone2 20 | -------------------------------------------------------------------------------- /test/unix/Test/TestUtil.hs: -------------------------------------------------------------------------------- 1 | module Test.TestUtil where 2 | 3 | import Test.QuickCheck.Property 4 | import Test.Tasty 5 | import Test.Tasty.HUnit 6 | import Test.Tasty.QuickCheck hiding (reason) 7 | 8 | assertFailure' :: String -> IO a 9 | assertFailure' s = do 10 | _ <- assertFailure s -- returns () in some versions 11 | return undefined 12 | 13 | assertJust :: Maybe a -> IO a 14 | assertJust (Just a) = return a 15 | assertJust Nothing = assertFailure' "Nothing" 16 | 17 | class NameTest a where 18 | nameTest :: String -> a -> TestTree 19 | 20 | instance NameTest [TestTree] where 21 | nameTest = testGroup 22 | 23 | instance NameTest Assertion where 24 | nameTest = Test.Tasty.HUnit.testCase 25 | 26 | instance NameTest Property where 27 | nameTest = testProperty 28 | 29 | instance NameTest Result where 30 | nameTest name = nameTest name . property 31 | 32 | instance (Arbitrary a, Show a, Testable b) => NameTest (a -> b) where 33 | nameTest name = nameTest name . property 34 | 35 | instance Testable a => NameTest (Gen a) where 36 | nameTest name = nameTest name . property 37 | 38 | tgroup :: (Show a, NameTest t) => [a] -> (a -> t) -> [TestTree] 39 | tgroup aa f = fmap (\a -> nameTest (show a) $ f a) aa 40 | 41 | assertEqualQC :: (Show a, Eq a) => String -> a -> a -> Result 42 | assertEqualQC _name expected found 43 | | expected == found = succeeded 44 | assertEqualQC "" expected found = failed{reason = "expected " ++ show expected ++ ", found " ++ show found} 45 | assertEqualQC name expected found = failed{reason = name ++ ": expected " ++ show expected ++ ", found " ++ show found} 46 | --------------------------------------------------------------------------------