hodatime 0.2.1.1 → 1.0.0.0
raw patch · 83 files changed
+6974/−496 lines, 83 filesdep +arraydep +deepseqdep +doctestdep ~Win32dep ~basedep ~binary
Dependencies added: array, deepseq, doctest, formatting, hashable, text
Dependency ranges changed: Win32, base, binary, bytestring, containers, directory, exceptions, filepath, mtl, parsec, unix
Files
- CHANGELOG.md +4/−0
- README.md +60/−0
- bench/HodaTime/CalendarBench.hs +40/−0
- bench/HodaTime/InstantBench.hs +37/−0
- bench/HodaTime/OffsetBench.hs +2/−2
- bench/bench.hs +4/−2
- doctest/doctests.hs +33/−0
- hodatime.cabal +126/−27
- platform/linux/Data/HodaTime/Locale/Platform.hs +17/−0
- platform/linux/Data/HodaTime/TimeZone/Platform.hs +4/−0
- platform/osx/Data/HodaTime/Locale/Platform.hs +17/−0
- platform/osx/Data/HodaTime/TimeZone/Platform.hs +4/−0
- platform/windows/Data/HodaTime/Locale/Platform.hsc +109/−0
- platform/windows/Data/HodaTime/TimeZone/Platform.hs +116/−12
- src/Data/HodaTime.hs +223/−17
- src/Data/HodaTime/Calendar/Constants.hs +0/−8
- src/Data/HodaTime/Calendar/Coptic.hs +178/−1
- src/Data/HodaTime/Calendar/Gregorian.hs +27/−16
- src/Data/HodaTime/Calendar/Gregorian/CacheTable.hs +29/−18
- src/Data/HodaTime/Calendar/Gregorian/Internal.hs +158/−121
- src/Data/HodaTime/Calendar/Hebrew.hs +430/−4
- src/Data/HodaTime/Calendar/Internal.hs +184/−2
- src/Data/HodaTime/Calendar/Islamic.hs +297/−11
- src/Data/HodaTime/Calendar/Iso.hs +16/−2
- src/Data/HodaTime/Calendar/Julian.hs +203/−0
- src/Data/HodaTime/Calendar/Persian.hs +203/−0
- src/Data/HodaTime/Calendar/Persian/Astronomical.hs +149/−0
- src/Data/HodaTime/CalendarDate.hs +70/−1
- src/Data/HodaTime/CalendarDateTime.hs +25/−7
- src/Data/HodaTime/CalendarDateTime/Internal.hs +125/−30
- src/Data/HodaTime/Constants.hs +1/−21
- src/Data/HodaTime/Duration.hs +13/−1
- src/Data/HodaTime/Exceptions.hs +42/−0
- src/Data/HodaTime/Instant.hs +10/−8
- src/Data/HodaTime/Instant/Internal.hs +28/−8
- src/Data/HodaTime/Internal/Lens.hs +32/−0
- src/Data/HodaTime/Interval.hs +14/−2
- src/Data/HodaTime/LocalTime.hs +8/−17
- src/Data/HodaTime/LocalTime/Internal.hs +56/−1
- src/Data/HodaTime/Locale.hs +116/−0
- src/Data/HodaTime/Locale/Internal.hs +122/−0
- src/Data/HodaTime/Locale/Posix.hsc +145/−0
- src/Data/HodaTime/Offset.hs +51/−15
- src/Data/HodaTime/Offset/Internal.hs +12/−1
- src/Data/HodaTime/OffsetDateTime.hs +52/−11
- src/Data/HodaTime/Pattern.hs +56/−0
- src/Data/HodaTime/Pattern/ApplyParse.hs +82/−0
- src/Data/HodaTime/Pattern/CalendarDate.hs +213/−0
- src/Data/HodaTime/Pattern/CalendarDateTime.hs +61/−0
- src/Data/HodaTime/Pattern/Duration.hs +99/−0
- src/Data/HodaTime/Pattern/Instant.hs +46/−0
- src/Data/HodaTime/Pattern/Internal.hs +218/−0
- src/Data/HodaTime/Pattern/LocalTime.hs +192/−0
- src/Data/HodaTime/Pattern/Locale.hs +309/−0
- src/Data/HodaTime/Pattern/Offset.hs +99/−0
- src/Data/HodaTime/Pattern/OffsetDateTime.hs +46/−0
- src/Data/HodaTime/Pattern/ParseTypes.hs +50/−0
- src/Data/HodaTime/Pattern/ZonedDateTime.hs +78/−0
- src/Data/HodaTime/Pattern/ZonedDateTime/Internal.hs +65/−0
- src/Data/HodaTime/TimeZone.hs +7/−2
- src/Data/HodaTime/TimeZone/Internal.hs +55/−27
- src/Data/HodaTime/TimeZone/Olson.hs +29/−18
- src/Data/HodaTime/TimeZone/ParseTZ.hs +9/−4
- src/Data/HodaTime/TimeZone/Unix.hs +28/−8
- src/Data/HodaTime/ZonedDateTime.hs +35/−16
- src/Data/HodaTime/ZonedDateTime/Internal.hs +90/−6
- tests/HodaTime/Calendar/CopticTest.hs +105/−0
- tests/HodaTime/Calendar/GregorianTest.hs +55/−3
- tests/HodaTime/Calendar/HebrewTest.hs +131/−0
- tests/HodaTime/Calendar/IslamicTest.hs +119/−0
- tests/HodaTime/Calendar/JulianTest.hs +109/−0
- tests/HodaTime/Calendar/PersianTest.hs +108/−0
- tests/HodaTime/CalendarDateTimeTest.hs +1/−1
- tests/HodaTime/ClassInstanceTests.hs +98/−0
- tests/HodaTime/InstantTest.hs +101/−7
- tests/HodaTime/LocalTimeTest.hs +2/−1
- tests/HodaTime/LocaleTest.hs +137/−0
- tests/HodaTime/OffsetTest.hs +17/−23
- tests/HodaTime/PatternTest.hs +249/−0
- tests/HodaTime/Util.hs +137/−3
- tests/HodaTime/WithCalendarTest.hs +84/−0
- tests/HodaTime/ZonedDateTimeTest.hs +52/−10
- tests/test.hs +10/−1
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+# Changelog++Release notes for each version are published on the+[GitHub releases page](https://github.com/jason-johnson/hodatime/releases).
+ README.md view
@@ -0,0 +1,60 @@+[](https://github.com/jason-johnson/hodatime)+[](https://hackage.haskell.org/package/hodatime)++# hodatime++A full-featured date and time library for Haskell, inspired by [Noda Time](https://nodatime.org) (and, in turn, Joda Time) and Erik Naggum's *The Long, Painful History of Time*.++hodatime draws a clear line between **physical time** — instants, durations and intervals on a single global timeline — and **civil time** — calendar dates, local times, and the calendar-and-zone rules that connect the two. The type you are holding always tells you exactly what you can and cannot do with it, so whole classes of date/time mistakes simply do not type-check.++## Features++- **Physical vs. civil time**, kept distinct at the type level (`Instant` / `Duration` / `Interval` versus `CalendarDate` / `LocalTime` / `CalendarDateTime`).+- **Multiple calendars** — Gregorian, ISO, Julian, Coptic, Persian (astronomical Solar Hijri), Islamic (parameterised over the leap-year rule) and Hebrew — with lossless conversion between them.+- **Operating-system time zones** — the IANA/Olson database on Unix, the registry on Windows — with explicit resolution of skipped and ambiguous local times across DST transitions.+- **A type-safe, composable pattern system** that derives a parser *and* a formatter together from a single field definition.+- **Locale-aware formatting** driven by the host system's locale data.++## Example++```haskell+import Data.HodaTime.Calendar.Gregorian (calendarDate, Month(..))+import Data.HodaTime.CalendarDate (dayOfWeek, withCalendar, CalendarDate)+import Data.HodaTime.Pattern (format)+import Data.HodaTime.Pattern.CalendarDate (pR)+import qualified Data.HodaTime.Calendar.Julian as Julian++-- Dates are smart-constructed; a date that cannot exist is Nothing+valentines = calendarDate 14 February 2024 -- a valid date (Just ...)+notADate = calendarDate 30 February 2024 -- Nothing++-- Read-only components are plain functions+valentinesDoW = dayOfWeek <$> valentines -- Just Wednesday++-- Convert losslessly to another calendar (the target is chosen by the result type)+julianChristmas :: Maybe (CalendarDate Julian.Julian)+julianChristmas = withCalendar <$> calendarDate 25 December 2024 -- 12 December 2024 in the Julian calendar++-- Format with a pattern (pR is the ISO-8601 round-trip date pattern)+isoText = format pR <$> calendarDate 23 April 2024 -- Just "2024-04-23"+```++## Installing++```+cabal install hodatime+```++or add `hodatime` to the `build-depends` of your package.++## Documentation++The full API documentation is on [Hackage](https://hackage.haskell.org/package/hodatime). Start with the [`Data.HodaTime`](https://hackage.haskell.org/package/hodatime/docs/Data-HodaTime.html) module, which gives a guided tour of the core concepts.++## Changelog++Release notes are published on the [GitHub releases page](https://github.com/jason-johnson/hodatime/releases).++## License++BSD-3-Clause. See [LICENSE](LICENSE).
+ bench/HodaTime/CalendarBench.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE FlexibleContexts #-}+module HodaTime.CalendarBench+(+ calendarBenches+)+where++import Criterion.Main+import Control.Applicative (Const(..))+import Data.Functor.Identity (Identity(..))+import Data.Maybe (fromJust)++import Data.HodaTime.CalendarDate (HasDate, MoY, DoW, day, month, year, dayOfWeek, next)+import Data.HodaTime.Calendar.Gregorian (calendarDate, Month(..), DayOfWeek(..))++-- Minimal van Laarhoven lens helpers (same as the test suite). Kept local so the benchmark depends only on the+-- public library interface and never reaches into internal modules.+get :: ((s -> Const s c) -> a -> Const t b) -> a -> t+get l = getConst . l Const++modify :: (s -> b) -> ((s -> Identity b) -> a -> Identity t) -> a -> t+modify f l = runIdentity . l (Identity . f)++-- | Force a date down to a single Int through the public accessors, so 'nf' evaluates the full decode.+forceDate :: (HasDate d, Enum (MoY d), Enum (DoW d)) => d -> Int+forceDate x = get day x + 100 * fromEnum (month x) + 10000 * get year x + 1000000 * fromEnum (dayOfWeek x)++calendarBenches :: Benchmark+calendarBenches = bgroup "Calendar (Gregorian)"+ [+ bench "construct" $ nf (maybe 0 forceDate . calendarDate 15 June) 2020+ ,bench "decode" $ nf forceDate cd+ ,bench "read month only" $ nf (fromEnum . month) cd+ ,bench "read dayOfWeek only" $ nf (fromEnum . dayOfWeek) cd+ ,bench "addDays in-century" $ nf (forceDate . modify (+ 40) day) cd+ ,bench "addDays cross-century" $ nf (forceDate . modify (+ 40000) day) cd+ ,bench "next dow" $ nf (forceDate . next 3 Monday) cd+ ]+ where+ cd = fromJust $ calendarDate 15 June 2020
+ bench/HodaTime/InstantBench.hs view
@@ -0,0 +1,37 @@+module HodaTime.InstantBench+(+ instantBenches+)+where++import Criterion.Main+import Data.List (foldl')+import qualified Data.HodaTime.Instant as I+import qualified Data.HodaTime.Duration as D++-- | Force an 'Instant' completely (its 'Show' touches every field), returning an 'Int' so criterion's 'nf' has+-- something fully-evaluable to hold on to.+forceI :: I.Instant -> Int+forceI = length . show++forceD :: D.Duration -> Int+forceD = length . show++instantBenches :: Benchmark+instantBenches = bgroup "Instant/Duration"+ [+ bench "add second" $ nf (forceI . I.add base) oneSec+ ,bench "add nano" $ nf (forceI . I.add base) oneNano+ ,bench "minus second" $ nf (forceI . I.minus base) oneSec+ ,bench "difference" $ nf (forceD . I.difference far) base+ ,bench "duration add" $ nf (forceD . D.add dSec) dNano+ ,bench "accumulate 10k adds sec" $ nf (\n -> forceI (foldl' I.add base (replicate n oneSec))) 10000+ ,bench "accumulate 10k adds nano" $ nf (\n -> forceI (foldl' I.add base (replicate n oneNano))) 10000+ ]+ where+ base = I.fromSecondsSinceUnixEpoch 1000000000+ far = I.fromSecondsSinceUnixEpoch 1500000000+ oneSec = D.fromSeconds 1+ oneNano = D.fromNanoseconds 1+ dSec = D.fromSeconds 3600+ dNano = D.fromNanoseconds 123456789
bench/HodaTime/OffsetBench.hs view
@@ -5,13 +5,13 @@ where import Criterion.Main-import Data.HodaTime.Offset (add, fromHours)+import Data.HodaTime.Offset (addClamped, fromHours) offsetBenches :: Benchmark offsetBenches = bgroup "Offset Benchmarks" [addHour] addHour :: Benchmark-addHour = bench "add 1" $ whnf (add oneHour) twoHours+addHour = bench "add 1" $ whnf (addClamped oneHour) twoHours where oneHour = fromHours (1 :: Int) twoHours = fromHours (2 :: Int)
bench/bench.hs view
@@ -6,14 +6,16 @@ import Criterion.Types (Config(..)) import HodaTime.OffsetBench (offsetBenches)+import HodaTime.CalendarBench (calendarBenches)+import HodaTime.InstantBench (instantBenches) main :: IO () main = defaultMainWith benchConfig [benches] benches :: Benchmark-benches = bgroup "Benchmarks" [offsetBenches]+benches = bgroup "Benchmarks" [offsetBenches, calendarBenches, instantBenches] -- This configuration enables garbage collection between benchmarks. It is a -- good idea to do so. Otherwise GC might distort your results benchConfig :: Config-benchConfig = defaultConfig { forceGC = True }+benchConfig = defaultConfig -- { forceGC = True }
+ doctest/doctests.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}+module Main (main) where++import Test.DocTest (doctest)++-- | Run the doctest examples embedded in the library's Haddock documentation.+--+-- doctest re-interprets the sources, so it needs the library's own source+-- directories (including the platform-specific one) on the search path. The+-- installed @hodatime@ package is hidden so that every module resolves to the+-- source we are checking, and the modules referenced from the @$setup@ block+-- are listed as targets so they load as home modules.+main :: IO ()+main = doctest+ [ "-isrc"+#if defined(mingw32_HOST_OS)+ , "-iplatform/windows"+#elif defined(darwin_HOST_OS)+ , "-iplatform/osx"+#else+ , "-iplatform/linux"+#endif+ -- Hide the installed hodatime package so its (hidden) internal modules do not+ -- shadow the sources we are loading from -isrc.+ , "-hide-package", "hodatime"+ , "src/Data/HodaTime/Internal/Lens.hs"+ , "src/Data/HodaTime/Calendar/Gregorian.hs"+ , "src/Data/HodaTime/Calendar/Julian.hs"+ , "src/Data/HodaTime/Pattern/CalendarDate.hs"+ , "src/Data/HodaTime/CalendarDateTime/Internal.hs"+ , "src/Data/HodaTime/CalendarDate.hs"+ , "src/Data/HodaTime/Pattern.hs"+ ]
hodatime.cabal view
@@ -1,18 +1,43 @@+cabal-version: 2.4 name: hodatime-version: 0.2.1.1+version: 1.0.0.0 stability: experimental-license: BSD3+license: BSD-3-Clause license-file: LICENSE-cabal-version: >=1.10 build-type: Simple author: Jason Johnson maintainer: <jason.johnson.081@gmail.com> homepage: https://github.com/jason-johnson/hodatime bug-reports: https://github.com/jason-johnson/hodatime/issues synopsis: A fully featured date/time library based on Nodatime-description: A library for dealing with time, dates, calendars and time zones+description:+ HodaTime is a full-featured date and time library for Haskell, inspired by+ Noda Time (and, in turn, Joda Time) and Erik Naggum's /The Long, Painful+ History of Time/.+ .+ It draws a clear line between /physical time/ (instants, durations and+ intervals on a global time line) and /civil time/ (calendar dates, local+ times and the calendar-and-zone rules that connect the two), so the type you+ are holding always tells you exactly what you can and cannot do with it.+ .+ Highlights:+ .+ * Multiple calendars (Gregorian, ISO, Julian, Coptic, Persian, Islamic and+ Hebrew) with lossless conversion between them.+ .+ * Time zones sourced from the operating system (the IANA\/Olson database on+ Unix, the registry on Windows), with explicit resolution of skipped and+ ambiguous local times across DST transitions.+ .+ * A type-safe, composable pattern system for parsing and formatting that+ derives a parser and a formatter together from a single field definition.+ .+ * Locale-aware formatting driven by the host system's locale data. category: Data, Time-tested-with: GHC == 8.0.2+tested-with: GHC == 9.4.8 || == 9.6.7 || == 9.8.4 || == 9.10.3+extra-doc-files:+ README.md+ CHANGELOG.md extra-source-files: platform/osx/Data/HodaTime/TimeZone/Platform.hs platform/osx/Data/HodaTime/Instant/Platform.hs@@ -20,6 +45,9 @@ platform/linux/Data/HodaTime/Instant/Platform.hs platform/windows/Data/HodaTime/TimeZone/Platform.hs platform/windows/Data/HodaTime/Instant/Platform.hsc+ platform/osx/Data/HodaTime/Locale/Platform.hs+ platform/linux/Data/HodaTime/Locale/Platform.hs+ platform/windows/Data/HodaTime/Locale/Platform.hsc source-repository head type: git@@ -37,20 +65,26 @@ hs-source-dirs: platform/windows build-depends:- base >= 4.9 && < 4.10,- mtl,- binary,- bytestring,- containers,- exceptions,- fingertree >= 0.1.3 && < 0.1.4,- parsec+ base >= 4.16 && < 4.21,+ mtl < 2.4,+ binary < 0.9,+ bytestring < 0.13,+ containers < 0.8,+ deepseq >= 1.4 && < 1.6,+ exceptions < 0.11,+ fingertree >= 0.1.3 && < 0.2,+ hashable >= 1.3 && < 1.6,+ text >= 0.11.0.8 && < 2.2,+ parsec < 3.2,+ formatting < 7.3,+ array < 0.6 if os(windows)- build-depends: Win32+ build-depends: Win32 < 2.15+ extra-libraries: kernel32 if !os(windows)- build-depends: unix,- filepath,- directory+ build-depends: unix < 2.9,+ filepath < 1.6,+ directory < 1.4 ghc-options: -Wall @@ -61,6 +95,7 @@ Data.HodaTime.Calendar.Hebrew, Data.HodaTime.Calendar.Islamic, Data.HodaTime.Calendar.Iso,+ Data.HodaTime.Calendar.Julian, Data.HodaTime.Calendar.Persian, Data.HodaTime.CalendarDate, Data.HodaTime.CalendarDateTime,@@ -70,30 +105,50 @@ Data.HodaTime.Offset, Data.HodaTime.LocalTime, Data.HodaTime.OffsetDateTime,- Data.HodaTime.TimeZone- Data.HodaTime.ZonedDateTime+ Data.HodaTime.TimeZone,+ Data.HodaTime.ZonedDateTime,+ Data.HodaTime.Locale,+ Data.HodaTime.Pattern,+ Data.HodaTime.Pattern.LocalTime,+ Data.HodaTime.Pattern.CalendarDate,+ Data.HodaTime.Pattern.CalendarDateTime,+ Data.HodaTime.Pattern.Instant,+ Data.HodaTime.Pattern.Offset,+ Data.HodaTime.Pattern.OffsetDateTime,+ Data.HodaTime.Pattern.Duration,+ Data.HodaTime.Pattern.ZonedDateTime,+ Data.HodaTime.Pattern.Locale,+ Data.HodaTime.Exceptions other-modules: Data.HodaTime.Constants, Data.HodaTime.Internal,+ Data.HodaTime.Internal.Lens, Data.HodaTime.Duration.Internal, Data.HodaTime.LocalTime.Internal, Data.HodaTime.Calendar.Internal,- Data.HodaTime.Calendar.Constants, Data.HodaTime.Calendar.Gregorian.Internal, Data.HodaTime.Calendar.Gregorian.CacheTable,+ Data.HodaTime.Calendar.Persian.Astronomical, Data.HodaTime.CalendarDateTime.Internal, Data.HodaTime.Instant.Internal, Data.HodaTime.Instant.Platform, Data.HodaTime.Offset.Internal, Data.HodaTime.TimeZone.Internal, Data.HodaTime.TimeZone.Platform,- Data.HodaTime.ZonedDateTime.Internal+ Data.HodaTime.ZonedDateTime.Internal,+ Data.HodaTime.Locale.Internal,+ Data.HodaTime.Locale.Platform,+ Data.HodaTime.Pattern.Internal,+ Data.HodaTime.Pattern.ZonedDateTime.Internal,+ Data.HodaTime.Pattern.ApplyParse+ Data.HodaTime.Pattern.ParseTypes if !os(windows) other-modules: Data.HodaTime.TimeZone.Olson, Data.HodaTime.TimeZone.ParseTZ, Data.HodaTime.TimeZone.Unix,- Data.HodaTime.Instant.Unix+ Data.HodaTime.Instant.Unix,+ Data.HodaTime.Locale.Posix test-suite test default-language:@@ -111,8 +166,17 @@ HodaTime.DurationTest, HodaTime.OffsetTest, HodaTime.Calendar.GregorianTest,+ HodaTime.Calendar.JulianTest,+ HodaTime.Calendar.CopticTest,+ HodaTime.Calendar.PersianTest,+ HodaTime.Calendar.IslamicTest,+ HodaTime.Calendar.HebrewTest, HodaTime.CalendarDateTimeTest,- HodaTime.ZonedDateTimeTest+ HodaTime.ZonedDateTimeTest,+ HodaTime.PatternTest,+ HodaTime.WithCalendarTest,+ HodaTime.LocaleTest,+ HodaTime.ClassInstanceTests build-depends: base >= 4 && < 5, tasty >= 0.11,@@ -122,24 +186,59 @@ QuickCheck, time, bytestring,+ exceptions,+ deepseq,+ hashable, hodatime +test-suite doctests+ default-language:+ Haskell2010+ type:+ exitcode-stdio-1.0+ hs-source-dirs:+ doctest+ main-is:+ doctests.hs+ build-depends:+ base >= 4.16 && < 4.21,+ doctest >= 0.16 && < 0.25,+ mtl < 2.4,+ binary < 0.9,+ bytestring < 0.13,+ containers < 0.8,+ deepseq >= 1.4 && < 1.6,+ exceptions < 0.11,+ fingertree >= 0.1.3 && < 0.2,+ hashable >= 1.3 && < 1.6,+ text >= 0.11.0.8 && < 2.2,+ parsec < 3.2,+ formatting < 7.3,+ array < 0.6+ if os(windows)+ build-depends: Win32 < 2.15+ if !os(windows)+ build-depends: unix < 2.9,+ filepath < 1.6,+ directory < 1.4+ benchmark bench default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs:- src, bench main-is: bench.hs other-modules:- HodaTime.OffsetBench+ HodaTime.OffsetBench,+ HodaTime.CalendarBench,+ HodaTime.InstantBench build-depends: base > 4, criterion,- random+ random,+ hodatime ghc-options: -Wall- -O2
+ platform/linux/Data/HodaTime/Locale/Platform.hs view
@@ -0,0 +1,17 @@+-- | Linux implementation of the locale reader. Linux exposes the POSIX per-locale query API, so this simply delegates+-- to the shared "Data.HodaTime.Locale.Posix" shim.+module Data.HodaTime.Locale.Platform+(+ loadCurrentLocale+ ,loadLocaleByName+)+where++import Data.HodaTime.Locale.Internal (Locale)+import qualified Data.HodaTime.Locale.Posix as P++loadCurrentLocale :: IO Locale+loadCurrentLocale = P.loadCurrentLocale++loadLocaleByName :: String -> IO (Maybe Locale)+loadLocaleByName = P.loadLocaleByName
platform/linux/Data/HodaTime/TimeZone/Platform.hs view
@@ -3,6 +3,7 @@ loadUTC ,loadLocalZone ,loadTimeZone+ ,loadAvailableZones ) where @@ -20,3 +21,6 @@ loadZoneFromOlsonFile :: FilePath -> IO (UtcTransitionsMap, CalDateTransitionsMap) loadZoneFromOlsonFile = U.defaultLoadZoneFromOlsonFile++loadAvailableZones :: IO [String]+loadAvailableZones = U.loadAvailableZones
+ platform/osx/Data/HodaTime/Locale/Platform.hs view
@@ -0,0 +1,17 @@+-- | macOS implementation of the locale reader. macOS exposes the POSIX per-locale query API, so this simply delegates+-- to the shared "Data.HodaTime.Locale.Posix" shim.+module Data.HodaTime.Locale.Platform+(+ loadCurrentLocale+ ,loadLocaleByName+)+where++import Data.HodaTime.Locale.Internal (Locale)+import qualified Data.HodaTime.Locale.Posix as P++loadCurrentLocale :: IO Locale+loadCurrentLocale = P.loadCurrentLocale++loadLocaleByName :: String -> IO (Maybe Locale)+loadLocaleByName = P.loadLocaleByName
platform/osx/Data/HodaTime/TimeZone/Platform.hs view
@@ -3,6 +3,7 @@ loadUTC ,loadLocalZone ,loadTimeZone+ ,loadAvailableZones ) where @@ -20,3 +21,6 @@ loadZoneFromOlsonFile :: FilePath -> IO (UtcTransitionsMap, CalDateTransitionsMap) loadZoneFromOlsonFile = U.defaultLoadZoneFromOlsonFile++loadAvailableZones :: IO [String]+loadAvailableZones = U.loadAvailableZones
+ platform/windows/Data/HodaTime/Locale/Platform.hsc view
@@ -0,0 +1,109 @@+{-# LANGUAGE ForeignFunctionInterface #-}++-- | Windows implementation of the locale reader, via @GetLocaleInfoEx@.+--+-- The name fields (month\/weekday names and AM\/PM designators, which power @pMMMM'@, @pddd'@, @ppp'@ and the reader)+-- come straight from the OS. The @raw*Format@ fields are the Windows /picture/ strings (e.g. @dd.MM.yyyy@) translated+-- to POSIX @strftime@ by 'windowsPictureToStrftime', so the layout-compiling patterns in+-- "Data.HodaTime.Pattern.Locale" (@localeDatePattern@ and friends) work on a Windows-read locale just as on POSIX.+module Data.HodaTime.Locale.Platform+(+ loadCurrentLocale+ ,loadLocaleByName+)+where++import Data.HodaTime.Locale.Internal (Locale(..), windowsPictureToStrftime)+import Foreign.Ptr (Ptr, nullPtr)+import Foreign.C.Types (CInt(..), CWchar)+import Foreign.Marshal.Array (allocaArray, peekArray, withArray0)+import Data.Bits ((.&.))+import Data.Char (chr, ord)++#include <windows.h>++-- @int GetLocaleInfoEx(LPCWSTR lpLocaleName, LCTYPE LCType, LPWSTR lpLCData, int cchData)@. (Windows CI is x86-64,+-- where @ccall@ is the sole calling convention; a 32-bit build would need @stdcall@.)+foreign import ccall unsafe "GetLocaleInfoEx"+ c_GetLocaleInfoEx :: Ptr CWchar -> CInt -> Ptr CWchar -> CInt -> IO CInt++-- LCTYPE bases (the numbered families are consecutive in @winnls.h@, so 'enumFrom' walks them).+lOCALE_SMONTHNAME1, lOCALE_SABBREVMONTHNAME1, lOCALE_SDAYNAME1, lOCALE_SABBREVDAYNAME1 :: CInt+lOCALE_SMONTHNAME1 = #{const LOCALE_SMONTHNAME1}+lOCALE_SABBREVMONTHNAME1 = #{const LOCALE_SABBREVMONTHNAME1}+lOCALE_SDAYNAME1 = #{const LOCALE_SDAYNAME1}+lOCALE_SABBREVDAYNAME1 = #{const LOCALE_SABBREVDAYNAME1}++lOCALE_S1159, lOCALE_S2359, lOCALE_SSHORTDATE, lOCALE_STIMEFORMAT :: CInt+lOCALE_S1159 = #{const LOCALE_S1159}+lOCALE_S2359 = #{const LOCALE_S2359}+lOCALE_SSHORTDATE = #{const LOCALE_SSHORTDATE}+lOCALE_STIMEFORMAT = #{const LOCALE_STIMEFORMAT}+#if defined(LOCALE_SNAME)+lOCALE_SNAME :: CInt+lOCALE_SNAME = #{const LOCALE_SNAME}+#endif++-- | Query one @LCTYPE@ from the given locale (a pointer to a wide name, or 'nullPtr' for the current locale) and decode+-- it as a 'String' (UTF-16, BMP — locale strings never use surrogate pairs).+getInfo :: Ptr CWchar -> CInt -> IO String+getInfo loc lctype = do+ n <- c_GetLocaleInfoEx loc lctype nullPtr 0+ if n <= 0+ then return ""+ else allocaArray (fromIntegral n) $ \buf -> do+ _ <- c_GetLocaleInfoEx loc lctype buf n+ ws <- peekArray (fromIntegral n) buf+ return . map (chr . (0xFFFF .&.) . fromIntegral) . takeWhile (/= 0) $ ws++-- | Run an action with a wide, null-terminated locale name, or with 'nullPtr' for the current locale.+withLocaleName :: Maybe String -> (Ptr CWchar -> IO a) -> IO a+withLocaleName Nothing act = act nullPtr+withLocaleName (Just s) act = withArray0 0 (map (fromIntegral . ord) s) act++-- | POSIX @\"C\"@\/@\"POSIX\"@ (and the empty name) map to the Windows /invariant/ locale (@L\"\"@).+normalizeName :: String -> String+normalizeName n+ | n `elem` ["C", "POSIX", ""] = ""+ | otherwise = n++buildLocale :: String -> Ptr CWchar -> IO Locale+buildLocale lid loc = do+ monsFull <- mapM (getInfo loc) (take 12 [lOCALE_SMONTHNAME1 ..])+ monsAbbr <- mapM (getInfo loc) (take 12 [lOCALE_SABBREVMONTHNAME1 ..])+ daysMon <- mapM (getInfo loc) (take 7 [lOCALE_SDAYNAME1 ..]) -- Windows is Monday-first+ daysAbbrMon <- mapM (getInfo loc) (take 7 [lOCALE_SABBREVDAYNAME1 ..])+ am <- getInfo loc lOCALE_S1159+ pm <- getInfo loc lOCALE_S2359+ sdate <- windowsPictureToStrftime <$> getInfo loc lOCALE_SSHORTDATE+ stime <- windowsPictureToStrftime <$> getInfo loc lOCALE_STIMEFORMAT+ return Locale+ { localeId = lid+ , monthNames = monsFull+ , monthNamesShort = monsAbbr+ , dayNames = sundayFirst daysMon+ , dayNamesShort = sundayFirst daysAbbrMon+ , amName = am+ , pmName = pm+ , rawDateFormat = sdate+ , rawTimeFormat = stime+ , rawDateTimeFormat = sdate ++ " " ++ stime+ }+ where+ sundayFirst xs = last xs : init xs -- [Mon .. Sun] -> [Sun, Mon .. Sat]++-- | Read a specific locale by (Windows or normalized POSIX) name; 'Nothing' if it is not a valid locale.+loadLocaleByName :: String -> IO (Maybe Locale)+loadLocaleByName name = withLocaleName (Just (normalizeName name)) $ \loc -> do+ n <- c_GetLocaleInfoEx loc lOCALE_SMONTHNAME1 nullPtr 0 -- validity probe+ if n <= 0 then return Nothing else Just <$> buildLocale name loc++-- | Read the current (user default) locale.+loadCurrentLocale :: IO Locale+loadCurrentLocale = do+#if defined(LOCALE_SNAME)+ lid <- withLocaleName Nothing (`getInfo` lOCALE_SNAME)+ withLocaleName Nothing (buildLocale (if null lid then "C" else lid))+#else+ withLocaleName Nothing (buildLocale "C")+#endif
platform/windows/Data/HodaTime/TimeZone/Platform.hs view
@@ -4,6 +4,7 @@ loadUTC ,loadLocalZone ,loadTimeZone+ ,loadAvailableZones ) where @@ -16,14 +17,89 @@ import Data.Char (isDigit) import Data.List (sortOn, foldl') import Control.Monad (forM)-import Control.Exception (bracket)-import System.Win32.Types (LONG, HKEY)+import Control.Exception (bracket, try, SomeException)+import Data.Int (Int32)+import System.Win32.Types (LONG, HKEY, peekTString, withTString) import System.Win32.Registry import System.Win32.Time (SYSTEMTIME(..))-import Foreign.Marshal.Alloc (allocaBytes)+import System.Win32.DLL (loadLibrary, getProcAddress)+import System.IO.Unsafe (unsafePerformIO)+import Foreign.Marshal.Alloc (allocaBytes, alloca)+import Foreign.Marshal.Array (allocaArray) import Foreign.Storable (sizeOf, Storable(..))-import Foreign.Ptr (castPtr)+import Foreign.Ptr (castPtr, castPtrToFunPtr, Ptr, FunPtr)+import Foreign.C.Types (CWchar)+import Foreign.C.String (CString, withCString) +-- ICU-based conversion between IANA and Windows zone ids. Windows uses its own registry zone names (e.g.+-- @"W. Europe Standard Time"@) while the rest of the world uses IANA ids (e.g. @"Europe/Zurich"@). Rather than+-- vendoring a CLDR windowsZones table (which Microsoft explicitly advises against, since time zones change often and+-- they maintain the data), we delegate to ICU, which has shipped with Windows since Windows 10 v1703 (build 15063)+-- and is kept current by Windows Update. We load @icu.dll@ dynamically (there is no import library for the+-- system copy, so it cannot be linked against) and resolve the two conversion functions at runtime. On systems+-- where @icu.dll@ or the symbols are unavailable (e.g. Windows before v1703) the conversions return 'Nothing' and we+-- fall back to treating names as Windows registry names, i.e. the pre-ICU behaviour.+type GetWindowsTimeZoneID = Ptr CWchar -> Int32 -> Ptr CWchar -> Int32 -> Ptr Int32 -> IO Int32+type GetTimeZoneIDForWindowsID = Ptr CWchar -> Int32 -> CString -> Ptr CWchar -> Int32 -> Ptr Int32 -> IO Int32++foreign import ccall unsafe "dynamic"+ mkGetWindowsTimeZoneID :: FunPtr GetWindowsTimeZoneID -> GetWindowsTimeZoneID++foreign import ccall unsafe "dynamic"+ mkGetTimeZoneIDForWindowsID :: FunPtr GetTimeZoneIDForWindowsID -> GetTimeZoneIDForWindowsID++-- | The two ICU zone-conversion functions, resolved once from @icu.dll@. 'Nothing' when ICU is unavailable.+{-# NOINLINE icuZoneFns #-}+icuZoneFns :: Maybe (GetWindowsTimeZoneID, GetTimeZoneIDForWindowsID)+icuZoneFns = unsafePerformIO $ do+ r <- try loadFns :: IO (Either SomeException (GetWindowsTimeZoneID, GetTimeZoneIDForWindowsID))+ return $ either (const Nothing) Just r+ where+ loadFns = do+ hmod <- loadLibrary "icu.dll"+ p1 <- getProcAddress hmod "ucal_getWindowsTimeZoneID"+ p2 <- getProcAddress hmod "ucal_getTimeZoneIDForWindowsID"+ return (mkGetWindowsTimeZoneID (castPtrToFunPtr p1), mkGetTimeZoneIDForWindowsID (castPtrToFunPtr p2))++-- | Output buffer size in UChar units for ICU zone-id conversions; zone ids are far shorter than this.+icuBufLen :: Int+icuBufLen = 128++-- | Translate an IANA zone id (e.g. @"Europe/Zurich"@) to its Windows registry zone name via ICU. Returns 'Nothing'+-- when the argument is not a known IANA id (for instance it is already a Windows name) or ICU is unavailable.+ianaToWindowsZone :: String -> IO (Maybe String)+ianaToWindowsZone iana = case icuZoneFns of+ Nothing -> return Nothing+ Just (getWindowsTZ, _) ->+ withTString iana $ \pIana ->+ allocaArray icuBufLen $ \pOut ->+ alloca $ \pStatus -> do+ poke pStatus 0+ n <- getWindowsTZ pIana (-1) pOut (fromIntegral icuBufLen) pStatus+ st <- peek pStatus+ if st <= 0 && n > 0 then Just <$> peekTString pOut else return Nothing++-- | Translate a Windows registry zone name to its canonical IANA zone id (CLDR region @"001"@) via ICU. Returns+-- 'Nothing' when the argument is not a known Windows name or ICU is unavailable.+windowsZoneToIana :: String -> IO (Maybe String)+windowsZoneToIana win = case icuZoneFns of+ Nothing -> return Nothing+ Just (_, getTZForWindows) ->+ withTString win $ \pWin ->+ withCString "001" $ \pRegion ->+ allocaArray icuBufLen $ \pOut ->+ alloca $ \pStatus -> do+ poke pStatus 0+ n <- getTZForWindows pWin (-1) pRegion pOut (fromIntegral icuBufLen) pStatus+ st <- peek pStatus+ if st <= 0 && n > 0 then Just <$> peekTString pOut else return Nothing+++-- | Accept either a Windows registry zone name or an IANA id. If ICU recognises the argument as an IANA id we use+-- the matching Windows name; otherwise we assume it is already a Windows name (or ICU is unavailable).+resolveWindowsZone :: String -> IO String+resolveWindowsZone zone = maybe zone id <$> ianaToWindowsZone zone+ data REG_TZI_FORMAT = REG_TZI_FORMAT { _tziBias :: LONG@@ -52,19 +128,24 @@ loadLocalZone :: IO (UtcTransitionsMap, CalDateTransitionsMap, String) loadLocalZone = do- zone <- readLocalZoneName- (utcM, calDateM) <- loadTimeZone zone- return (utcM, calDateM, zone)+ winZone <- readLocalZoneName+ (utcM, calDateM) <- loadTimeZone winZone+ ianaName <- windowsZoneToIana winZone+ return (utcM, calDateM, maybe winZone id ianaName) loadTimeZone :: String -> IO (UtcTransitionsMap, CalDateTransitionsMap) loadTimeZone "UTC" = return (utcM, calDateM) where (utcM, calDateM, _) = fixedOffsetZone "UTC" (Offset 0) loadTimeZone zone = do- (stdAbbr, dstAbbr, tzi) <- readTziForZone zone- dynTzis <- readDynamicDstForZone zone+ winZone <- resolveWindowsZone zone+ (stdAbbr, dstAbbr, tzi) <- readTziForZone winZone+ dynTzis <- readDynamicDstForZone winZone return $ mkZoneMaps stdAbbr dstAbbr tzi dynTzis +loadAvailableZones :: IO [String]+loadAvailableZones = readAllZoneNames+ -- conversion from Windows types mkZoneMaps :: String -> String -> REG_TZI_FORMAT -> [(Int, REG_TZI_FORMAT)] -> (UtcTransitionsMap, CalDateTransitionsMap)@@ -96,6 +177,9 @@ stdOffSecs = 60 * (negate . fromIntegral $ bias + stdBias) dstOffSecs = stdOffSecs + 60 * (negate . fromIntegral $ dstBias) +-- TODO: When wYear (the first, discarded field) is non-zero the SYSTEMTIME is an absolute one-time transition, not a+-- recurring yearly pattern. We currently always treat it as the recurring (NthDay) form, which mis-reads those+-- explicit transitions. Handle the wYear /= 0 case as an explicit transition instead. systemTimeToNthDayExpression :: SYSTEMTIME -> Int -> TransitionExpression systemTimeToNthDayExpression (SYSTEMTIME _ m d nth h mm s _) offsetSecs = NthDayExpression (fromIntegral m - 1) (adjust . fromIntegral $ nth) (fromIntegral d) s'' where@@ -109,16 +193,24 @@ readLocalZoneName :: IO String readLocalZoneName = bracket op regCloseKey $ \key ->- regQueryValue key (Just "TimeZoneKeyName")+ regQueryValueString key "TimeZoneKeyName" where op = regOpenKeyEx hKEY_LOCAL_MACHINE hive kEY_QUERY_VALUE hive = "SYSTEM\\CurrentControlSet\\Control\\TimeZoneInformation" +readAllZoneNames :: IO [String]+readAllZoneNames =+ bracket op regCloseKey $ \key ->+ regEnumKeys key+ where+ op = regOpenKeyEx hKEY_LOCAL_MACHINE hive kEY_READ+ hive = "SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\Time Zones"+ readTziForZone :: String -> IO (String, String, REG_TZI_FORMAT) readTziForZone zone = bracket op regCloseKey $ \key -> do- std <- regQueryValue key (Just "Std")- dst <- regQueryValue key (Just "Dlt")+ std <- regQueryValueString key "Std"+ dst <- regQueryValueString key "Dlt" tzi <- readTzi key "TZI" return (std, dst, tzi) where@@ -157,3 +249,15 @@ verifyAndPeak rvt ptr | rvt == rEG_BINARY = peek . castPtr $ ptr | otherwise = error $ "registry corrupt: TZI variable was non-binary type: " ++ show rvt++-- | Read a named REG_SZ (or REG_EXPAND_SZ) value as a 'String'. Note: 'regQueryValue' reads the /default/ value of a+-- subkey, not a named value, so named string values (Std, Dlt, TimeZoneKeyName) must go through 'regQueryValueEx'.+regQueryValueString :: HKEY -> String -> IO String+regQueryValueString key name =+ allocaBytes sz $ \ptr -> do+ rvt <- regQueryValueEx key name ptr sz+ if rvt == rEG_SZ || rvt == rEG_EXPAND_SZ+ then peekTString (castPtr ptr)+ else error $ "registry corrupt: " ++ name ++ " was non-string type: " ++ show rvt+ where+ sz = 512
src/Data/HodaTime.hs view
@@ -1,5 +1,5 @@ {-|-Module : Data.HodaTime.Interval+Module : Data.HodaTime Copyright : (C) 2017 Jason Johnson License : BSD-style (see the file LICENSE) Maintainer : Jason Johnson <jason.johnson.081@gmail.com>@@ -61,26 +61,232 @@ == Core Concepts -<snip - add stuff rest of documentation>+Almost everything in Hoda Time follows from a single distinction: the difference between /physical time/ and /civil time/. -== Cookbook+/Physical time/ is what a stopwatch measures. It flows at the same rate everywhere, it has no notion of days, months or time zones, and any two observers can agree on it. A single point on this universal timeline is an @Instant@ (see "Data.HodaTime.Instant"), and the amount of time elapsed between two instants is a @Duration@ (see "Data.HodaTime.Duration"). These are the types to reach for when the question is /"how long did this take?"/ or /"which of these two events happened first?"/ — they cannot mislead you about time zones because they know nothing about them. -=== USA Holidays+/Civil time/ is the human labelling laid on top of that timeline: calendars, wall clocks, "the 23rd of April at nine in the morning". A label like that is not, on its own, a point on the timeline. Until you say /where/ it applies it is ambiguous — "9am on the 23rd" happens at different physical instants in Tokyo and in New York. Hoda Time gives that unanchored label its own type, @CalendarDateTime@ (see "Data.HodaTime.CalendarDateTime"), and deliberately makes it /not/ interchangeable with an @Instant@. You move between the two worlds on purpose — by supplying the missing information, either a fixed @Offset@ from UTC or a full @TimeZone@ — and never by accident. ->>>import Data.HodaTime.CalendarDate (DayNth(..))->>>import Data.HodaTime.Calendar.Gregorian (calendarDate, fromNthDay, Month(..), DayOfWeek(..), Gregorian)+This split is the most important idea in the library. A great many date and time bugs come from treating a wall-clock label as though it were an absolute instant; Hoda Time turns that mistake into a compile error instead of a lurking one. ->>>usaHolidays y = catMaybes $ ($ y) <$>- [- calendarDate 1 January -- New Year- ,calendarDate 4 July -- Independence Day - ,calendarDate 25 December -- Christmas- ,fromNthDay First Monday September -- Labor day- ,fromNthDay Third Monday January -- MLK day- ,fromNthDay Second Tuesday February -- Presidents day- ,fromNthDay Fourth Thursday November -- Thanksgiving- ,calendarDate 29 February -- Leap day (not a real holiday but demonstrates date that may not exist)- ]+=== The pieces++Each concept below has its own type and module. You rarely need all of them at once — start with the one that matches the question you are asking, and follow the links for the detail.++[@Instant@ — "Data.HodaTime.Instant"] A single point on the universal timeline, independent of any calendar or zone.++[@Duration@ — "Data.HodaTime.Duration"] The exact time elapsed between two instants, measured in days, hours, seconds and nanoseconds. This is /machine/ time — a precise count — as opposed to a calendar-aware amount such as "one month", whose length depends on which month you mean.++[@LocalTime@ — "Data.HodaTime.LocalTime"] A time of day on its own, such as 09:00:00, with no date attached.++[@CalendarDate@ — "Data.HodaTime.CalendarDate"] A date in some calendar, such as 23 April 2024, with no time of day attached.++[@CalendarDateTime@ — "Data.HodaTime.CalendarDateTime"] A date together with a time of day, still /not/ tied to any particular place on the timeline.++[@Offset@ — "Data.HodaTime.Offset"] A fixed displacement from UTC, such as +01:00.++[@OffsetDateTime@ — "Data.HodaTime.OffsetDateTime"] A @CalendarDateTime@ pinned to the timeline by a fixed @Offset@: enough to be unambiguous, but with no knowledge of daylight saving.++[@TimeZone@ — "Data.HodaTime.TimeZone"] The full set of rules for a place, including its history of daylight-saving and offset changes.++[@ZonedDateTime@ — "Data.HodaTime.ZonedDateTime"] A date and time anchored in a real @TimeZone@ — the fully resolved civil time, which therefore also corresponds to a definite @Instant@.++[@Interval@ — "Data.HodaTime.Interval"] The span of physical time between two instants, as a value you can hold and inspect.++[The calendar — "Data.HodaTime.Calendar.Gregorian" and friends] The system of dates itself. Gregorian is the default, but Julian, Coptic, Persian, Islamic, Hebrew and ISO are all provided; the calendar is carried in the type, so dates from different calendars cannot be silently mixed.++[Patterns — "Data.HodaTime.Pattern"] Parsing text into these types, and formatting them back out again.++=== A first example++Here is the whole library in miniature. A meeting is scheduled for 9 in the morning on 23 April 2024 in Zürich, and we want the exact instant at which it happens — and what that same moment reads on a wall clock in New York.++> import Data.HodaTime.Calendar.Gregorian (calendarDate, Month(..), Gregorian)+> import Data.HodaTime.LocalTime (localTime)+> import Data.HodaTime.CalendarDateTime (at)+> import Data.HodaTime.TimeZone (timeZone)+> import Data.HodaTime.ZonedDateTime (ZonedDateTime, fromCalendarDateTimeStrictly, toInstant, fromInstant, zoneAbbreviation)+> import Data.HodaTime.Locale (currentLocale)+> import Data.HodaTime.Pattern (format)+> import Data.HodaTime.Pattern.CalendarDateTime (pF)+> import Data.HodaTime.Pattern.ZonedDateTime (zonedDateTimePattern)+> import Data.HodaTime.Pattern.Locale (localeDatePattern)+>+> main :: IO ()+> main = do+> zurich <- timeZone "Europe/Zurich"+> newYork <- timeZone "America/New_York"+>+> -- civil time: a date and a time of day, combined into a label with no place on the timeline+> let Just meeting = at <$> calendarDate 23 April 2024 <*> localTime 9 0 0 0+>+> -- anchor the label in Zürich, then read off the physical instant+> here <- fromCalendarDateTimeStrictly meeting zurich+> let instant = toInstant here+>+> -- the very same instant, on a New York wall clock (any calendar would do, so we name Gregorian)+> let there = fromInstant instant newYork :: ZonedDateTime Gregorian+>+> -- one zoned pattern renders both: the long civil form (pF) followed by the zone abbreviation+> let zoned = zonedDateTimePattern pF (\z -> " " ++ zoneAbbreviation z)+> putStrLn $ format zoned here -- Tuesday, 23 April 2024 09:00:00 CEST+> putStrLn $ format zoned there -- Tuesday, 23 April 2024 03:00:00 EDT+>+> -- the same civil date, written the way the machine's own locale writes it+> loc <- currentLocale+> datePat <- localeDatePattern loc+> putStrLn $ format datePat meeting -- 04/23/2024 on a US machine, 23.04.2024 on a German one++Read top to bottom, the example crosses from civil time to physical time and back:++1. @calendarDate@ and @localTime@ build /civil/ values. Both return a @Maybe@, because 31 April and 25:00 are not real; combining them with @at@ gives a @CalendarDateTime@ — a label that does not yet name a point on the timeline.++2. @fromCalendarDateTimeStrictly@ resolves that label inside a @TimeZone@, producing a @ZonedDateTime@ that /is/ anchored, and @toInstant@ extracts the pure @Instant@. We used the /strict/ resolver, which refuses to guess when a local time is skipped or ambiguous — the awkward cases covered in the section on offsets and zones.++3. Because an @Instant@ is just a point on the timeline, @fromInstant@ can re-express it on any zone's wall clock. New York is six hours behind Zürich in April, so 09:00 CEST is 03:00 EDT.++4. Finally a /pattern/ renders each @ZonedDateTime@ as text: @zonedDateTimePattern@ pairs the long civil form (@pF@) with the zone abbreviation, so a single @format@ prints the whole line. Patterns are the subject of their own section below.++5. A closing flourish shows the /locale/ side of the library: @currentLocale@ reads the machine's own date conventions from the operating system, and @localeDatePattern@ compiles them into an ordinary pattern, so the very same @meeting@ date prints @04\/23\/2024@ on a US machine but @23.04.2024@ on a German one — again covered in the section on patterns.++Notice the type annotation on the New York view: @fromInstant@ can hand back a date in /any/ calendar, so we name the one we want. That the calendar rides along in the type — and never has to be guessed — is the subject of the section on calendars.++=== Physical time++The three physical-time types — @Instant@, @Duration@ and @Interval@ — have one thing in common: they know nothing of calendars or time zones. They are pure points and lengths on the universal timeline, and every operation on them is exact.++__Instant.__ An @Instant@ is a single moment, the same everywhere. You will usually get one from the outside world with @now@ (an @IO Instant@), from a @ZonedDateTime@ with @toInstant@, or from a raw count of seconds with @fromSecondsSinceUnixEpoch@. To read a moment /as/ a date and time you must first choose a zone: @inTimeZone@ turns an @Instant@ into a @ZonedDateTime@. This is the same rule as everywhere else in the library — there is no calendar view of a moment until you say where you are standing.++__Duration.__ A @Duration@ is the exact gap between two instants, tracked down to the nanosecond. You build one from a unit — @fromHours@, @fromMinutes@, @fromSeconds@, @fromNanoseconds@ and friends — and shift an instant by it with @add@ and @minus@ (a worked example is in the cookbook on "Data.HodaTime.Duration").++The word /standard/ in @fromStandardDays@ and @fromStandardWeeks@ is a deliberate caution. A standard day is /exactly/ 24 hours and a standard week /exactly/ seven of them, because a @Duration@ is machine time. That is not the same thing as "a calendar day": across a daylight-saving change a civil day can run to 23 or 25 hours. If you mean "the same wall-clock time tomorrow" you are asking a /calendar/ question and should add to a @ZonedDateTime@; if you mean "exactly 24 hours later" you add a @Duration@ to an @Instant@. Keeping those two apart is, once more, the entire point.++__Interval.__ An @Interval@ is a stretch of the timeline fixed by its two endpoints, built with @interval start end@. It is /half-open/: @contains@ counts the start instant but not the end, so that adjacent intervals tile the timeline without overlapping. @duration@ returns its length as a @Duration@, and its @start@ and @end@ are exposed as lenses.++=== Civil time++Civil time is the world of labels: a @CalendarDate@ is a date, a @LocalTime@ is a time of day, and a @CalendarDateTime@ is the two together. None of them names a point on the timeline — that is what makes them /civil/ rather than /physical/ — and each carries its calendar in its type, so a Gregorian date and a Hebrew date can never be mistaken for one another.++__CalendarDate.__ You build a date through the module for the calendar you want, most often "Data.HodaTime.Calendar.Gregorian". Its @calendarDate@ takes a day, a month and a year and returns a @Maybe@, because a great many (day, month, year) triples are not real dates: 30 February, the 31st of a 30-day month, 29 February in a common year, or — since the Gregorian calendar is not proleptic — anything before the changeover of 15 October 1582. Rather than silently "fixing" your input, the library hands back @Nothing@ and lets you decide what that should mean. Two further constructors cover common calendar idioms: @fromNthDay@ for "the fourth Thursday of November", and @fromWeekDate@ for week-numbered dates. (Worked examples are in the cookbook on "Data.HodaTime.CalendarDate".)++__LocalTime.__ A @LocalTime@ is a wall-clock time with no date, built with @localTime@ from an hour, minute, second and nanosecond. Clock arithmetic /normalizes/: adding one minute to 23:59 rolls round to 00:00 rather than overflowing, so a @LocalTime@ is always a real time of day.++__CalendarDateTime.__ Glue a date and a time together with @at@ (or its flipped partner @on@) to get a @CalendarDateTime@, and @atStartOfDay@ pairs a date with midnight. This is still a civil label — the very @CalendarDateTime@ we anchored in the opening example — and it becomes a point on the timeline only once you resolve it against an @Offset@ or a @TimeZone@.++__Reading and changing fields.__ Every date type is an instance of @HasDate@, which offers its components in two forms. The read-only accessors — @month@, @dayOfWeek@ and the combined @yearMonthDay@ — are ordinary functions. The mutable components — @day@, @monthl@ (the month as an @Int@, so that arithmetic on it is meaningful) and @year@ — are /lenses/, while @next@ and @previous@ jump to the nth following or preceding weekday. The lenses are quietly opinionated about the awkward cases:++* @day@ does /not/ clamp: add 400 to it and the month and year roll over accordingly.+* @monthl@ clamps only as a final step, and only for end-of-month days — so two months after 31 January is 31 March, not the 29 March that some libraries would hand you.+* @year@ clamps 29 February back to the 28th in a common year.++Hoda Time takes no dependency on any lens library to provide these; as noted under /Accessors/ above, any lens package will drive them, or you can define the three one-line helpers from @tests\/HodaTime\/Util.hs@ if you would rather not pull one in.++=== Crossing over: offsets and zones++A civil label becomes a point on the timeline only once you attach the missing UTC information, and there are two ways to attach it. You can give a /fixed/ displacement from UTC — an @Offset@ — or the /full rules/ of a place — a @TimeZone@. Each produces an anchored type: an @OffsetDateTime@ or a @ZonedDateTime@.++__Offset and OffsetDateTime.__ An @Offset@ is a fixed distance from UTC, such as +02:00, built with @fromHours@, @fromMinutes@, @fromSeconds@ or @empty@ (UTC itself) and adjusted through its @hours@, @minutes@ and @seconds@ lenses. Offsets are clamped to a maximum of eighteen hours either side of UTC, comfortably covering every real zone. An @OffsetDateTime@ (from @fromCalendarDateTimeWithOffset@ or @fromInstantWithOffset@) is simply a @CalendarDateTime@ tagged with one — the shape HTTP and other wire formats use, as in @2024-04-23T09:00:00+02:00@. It is unambiguous, but /dumb/: it records that the offset was +02:00 without knowing that +01:00 applies in winter. Reach for it when the offset is already a given (a timestamp on the wire, a logged event); reach for a @TimeZone@ when the question involves a place and its rules.++__TimeZone and ZonedDateTime.__ A @TimeZone@ is the whole rulebook for a location — every daylight-saving and offset change in its history. Because that data comes from the operating system, loading a zone is an @IO@ action: @timeZone "Europe\/Zurich"@, @utc@, @localZone@ for the machine's own setting, or @availableZones@ to list them all. Resolving a civil date and time in a zone yields a @ZonedDateTime@: a fully pinned-down value that corresponds to exactly one @Instant@. It answers every question — @year@, @month@, @day@, @hour@ and the rest, plus @inDst@ and @zoneAbbreviation@ — converts to the timeline with @toInstant@ and comes back with @fromInstant@ (equivalently @inTimeZone@).++__Two awkward moments.__ Turning a /local/ @CalendarDateTime@ into a @ZonedDateTime@ is not always a one-to-one mapping, because twice a year the clocks move:++* On the /spring-forward/ night an hour of local time is __skipped__ — a label such as 02:30 simply never occurs, and maps to /no/ instant.+* On the /fall-back/ night an hour is repeated, so a label is __ambiguous__ — 01:30 happens /twice/, mapping to two different instants.++Most libraries quietly pick an answer and move on. Hoda Time makes you decide, and gives you four ways to do it, from the most explicit to the most convenient:++[@fromCalendarDateTimeAll@] returns every valid mapping as a list: empty for a skipped time, one element in the ordinary case, and two (earlier then later) for an ambiguous one. You look and choose.++[@fromCalendarDateTimeStrictly@] the cautious default — it succeeds with the single mapping, or fails in @MonadThrow@ with a @DateTimeDoesNotExistException@ for a skipped time or a @DateTimeAmbiguousException@ for an ambiguous one. This is the resolver the opening example used.++[@fromCalendarDateTimeLeniently@] never fails: an ambiguous time collapses to the /earlier/ of its two instants, and a skipped time is nudged /forward/ by the length of the gap.++[@resolve@] you supply the policy. It takes a handler for the ambiguous case (given both matches, earlier and later) and one for the skipped case (given the instant just before the gap and the one just after); @fromCalendarDateTimeStrictly@ and @fromCalendarDateTimeLeniently@ are themselves just @resolve@ with particular handlers.++The reverse journey never has this trouble: going from an @Instant@ to a @ZonedDateTime@ with @fromInstant@ (or @inTimeZone@), and back with @toInstant@, is always unambiguous — an instant is a genuine point on the timeline, and at any point a zone has exactly one offset in force. The awkwardness is a property of civil labels, not of time itself.++=== Calendars++Every date type carries its calendar as a type parameter — @CalendarDate cal@, @CalendarDateTime cal@, @ZonedDateTime cal@. The tag is a /phantom/: it selects the rules (the month names and lengths, the leap-year rule, the epoch) at no runtime cost, and, more importantly, it stops dates in different calendars from being mixed by accident — combining a Hebrew month with a Gregorian date is a compile error, not a lurking bug. @Gregorian@ is the default, and the reference against which every other calendar is measured.++You construct dates through the module for the calendar you want, using /that/ calendar's own @calendarDate@ (plus @fromNthDay@ and @fromWeekDate@) and its own @Month@ and @DayOfWeek@ — @January@ for Gregorian, @Tishri@ for Hebrew, @Muharram@ for Islamic, and so on. The full roster:++[Gregorian — "Data.HodaTime.Calendar.Gregorian"] The civil calendar used across most of the world today, and the timeline's reference point. It is not proleptic: it begins at the 15 October 1582 changeover.++[ISO — "Data.HodaTime.Calendar.Iso"] Identical to Gregorian for every date; it differs only in week numbering — weeks start on Monday and week 1 is the first with at least four days in the new year. Use its @fromWeekDate@ for ISO-8601 week dates.++[Julian — "Data.HodaTime.Calendar.Julian"] The \"Old Calendar\" that preceded the Gregorian and is still used liturgically by parts of the Eastern Orthodox church. Fully proleptic with astronomical year numbering, floored at its introduction in 45 BC.++[Coptic — "Data.HodaTime.Calendar.Coptic"] The Coptic (Alexandrian) calendar: twelve thirty-day months followed by a short thirteenth.++[Persian — "Data.HodaTime.Calendar.Persian"] The astronomical Solar Hijri calendar, Iran's official civil calendar, whose year begins on the spring equinox as observed at Tehran.++[Islamic — "Data.HodaTime.Calendar.Islamic"] The tabular Islamic (Hijri) calendar, /parameterised by its leap-year pattern/ (see below).++[Hebrew — "Data.HodaTime.Calendar.Hebrew"] The Hebrew (Jewish) lunisolar calendar, /parameterised by its month numbering/ (see below).++__Parameterised calendars.__ A couple of calendars come in more than one variant, and rather than bury the choice in a runtime flag Hoda Time lifts it into the type too — just like the calendar itself. @Islamic@ is tagged with its /leap pattern/ — @IslamicBase15@, @IslamicIndian@, @IslamicHabashAlHasib@, or @IslamicBcl@ (the .NET-compatible Base16 default) — which decides which years of the thirty-year cycle gain a day; @Hebrew@ is tagged with its /month numbering/ — @HebrewCivil@ (counting from Tishri, the default) or @HebrewScriptural@ (counting from Nisan). Each variant is a distinct type, so a Base15 date can never be confused with a Base16 one, and the plain @calendarDate@ in each module still builds the default variant with no annotation required.++__Converting between calendars.__ Because they all share the one timeline, a single moment can be re-expressed in any of them with @withCalendar@ — there is a version at each level, in "Data.HodaTime.CalendarDate", "Data.HodaTime.CalendarDateTime" and "Data.HodaTime.ZonedDateTime" — which keeps the underlying day (or instant and time zone) and changes only the calendar the value is labelled in. The target is chosen by the result type; the cookbook on "Data.HodaTime.CalendarDate" has a worked @withCalendar@ example.++=== Patterns++Turning these types into text, and text back into these types, is the job of a @Pattern@ (see "Data.HodaTime.Pattern"). Where most libraries hand you two separate stringly-typed operations — a format string in one direction and a parse string in the other — Hoda Time uses a /single/ @Pattern@ value that goes both ways. A pattern is assembled from typed pieces rather than from a mini-language buried in a string, so a field that makes no sense for the type you are formatting is a compile error rather than a run-time surprise, and the very value that printed a date will read one back.++You drive a pattern with two functions: @format@ turns a value into a @String@, and @parse@ reads one back in any @MonadThrow@ — so @Maybe@, @IO@, @Either SomeException@ and friends all work — failing with a @ParseFailedException@ on bad input. @parse'@ is the same but lets you supply the value whose fields fill in for anything the pattern does not mention. (Worked @format@\/@parse@ examples are on "Data.HodaTime.Pattern".)++__The standard patterns.__ For the common layouts there is a ready-made pattern per type, each named for its Noda Time counterpart. For a @CalendarDate@ (see "Data.HodaTime.Pattern.CalendarDate"):++[@pd@] short date, @dd\/MM\/yyyy@.++[@pD@] long date, @dddd, dd MMMM yyyy@.++[@pR@] the ISO-8601 round-trippable date, @yyyy-MM-dd@.++For a @LocalTime@ (see "Data.HodaTime.Pattern.LocalTime"):++[@pt@] short time, @HH:mm@.++[@pT@] long time, @HH:mm:ss@.++[@pr@] round-trippable time, @HH:mm:ss.fffffffff@, down to the nanosecond.++For a @CalendarDateTime@ (see "Data.HodaTime.Pattern.CalendarDateTime"), which simply glues a date pattern to a time pattern:++[@ps@] the sortable ISO form, @yyyy-MM-ddTHH:mm:ss@.++[@pf@ and @pF@] full: the long date with the short (@pf@) or long (@pF@) time.++[@pg@ and @pG@] general: the short date with the short (@pg@) or long (@pG@) time.++[@po@] the round-trippable form — @ps@ carried down to the nanosecond.++And the anchored and measured types have their own patterns:++[@pInstant@ — "Data.HodaTime.Pattern.Instant"] an @Instant@ as ISO-8601 UTC, @yyyy-MM-ddTHH:mm:ssZ@ (@pInstantNano@ carries the fraction).++[@pOffset@ — "Data.HodaTime.Pattern.Offset"] an @Offset@ as @(+\/-)HH:mm@ (@pOffsetFull@ adds seconds).++[@pOffsetDateTime@ — "Data.HodaTime.Pattern.OffsetDateTime"] an @OffsetDateTime@ as @yyyy-MM-ddTHH:mm:ss(+\/-)HH:mm@.++[@pDuration@ — "Data.HodaTime.Pattern.Duration"] a @Duration@ as @[-]D:HH:mm:ss@ (@pDurationNano@ carries the fraction).++[@pZonedDateTime@ — "Data.HodaTime.Pattern.ZonedDateTime"] a @ZonedDateTime@ as its local time followed by the zone id. Formatting is pure; /parsing/ one is effectful (see below).++__Building your own.__ A standard pattern is nothing more than the field patterns from those same modules combined with two operators, and you assemble your own the same way: @\<\>@ merges two fields, and @\<%@ appends a fixed literal (built with @char@ or @string@). The cookbook on "Data.HodaTime.Pattern" has a worked custom-pattern example.++The field patterns cover the usual components: @pyyyy@, @pMM@ (numeric month), @pMMM@ and @pMMMM@ (abbreviated and full month name) and @pdd@ (day), plus @pddd@ and @pdddd@ (abbreviated and full weekday name) for dates; @pHH@ (24-hour) or @phh@ (12-hour) with @pp@ \/ @ppp@ for the AM\/PM designator, then @pmm@, @pss@ and @pfrac@ for times. @pfrac@ is the one pattern that takes an argument — the number of fractional-second digits, from 1 (tenths) up to 9 (nanoseconds) — because a single width covers every case cleanly.++__Locale-driven patterns.__ Beyond the fixed, English patterns, Hoda Time can read the /machine's own/ conventions from the operating system's locale database (see "Data.HodaTime.Locale"). @currentLocale@ (or @localeByName@) hands back a @Locale@, and "Data.HodaTime.Pattern.Locale" compiles that locale's layouts into ordinary patterns: @localeDatePattern@ for the short date — so the same date prints @03\/15\/2020@ under @en_US@ but @15.03.2020@ under @de_DE@ — @localeTimePattern@ for the time of day, and @localeDateTimePattern@ for the combined date-and-time layout (as a @CalendarDateTime@, with any zone field dropped). When the layout carries a zone, @parseZonedDateTime@ resolves its abbreviation (@%Z@) through a provider you supply, and @localeOffsetDateTimePattern@ turns an unambiguous numeric offset (@%z@) into a pure, bidirectional @OffsetDateTime@ pattern. The name patterns have locale-aware variants too: @pMMMM'@, @pMMM'@, @pdddd'@, @pddd'@ and @ppp'@ each take a @Locale@ and use its month\/weekday names and AM\/PM designators in place of the built-in English ones. This reads from the machine rather than bundling data (the same philosophy as the time-zone support) and works on Linux, macOS and Windows alike, covering the Gregorian names the OS exposes; when you want a fixed locale with no @IO@, the built-ins @enUS@, @deDE@ and @jaJP@ are provided.++__Parsing a @ZonedDateTime@.__ Building a @ZonedDateTime@ has to load the zone rules and resolve the local time (which may be skipped or ambiguous), so it cannot come from the pure @parse@. Instead @parseZonedDateTime@ takes a zone /provider/ (@timeZone@ in @IO@, or a pure lookup) and a /resolver/ (one of the four from the section on offsets and zones) and does it effectfully; formatting with @pZonedDateTime@ stays pure.++__What patterns do not yet do.__ This is a deliberately honest list; each item is on the roadmap rather than a decision against it.++* The /standard/ patterns are /fixed format/ — @pd@ is always @dd\/MM\/yyyy@, with English names taken from each calendar's own @Month@ and @DayOfWeek@. The locale-driven patterns above follow the machine's own layout and names instead, but only for the Gregorian names the operating system exposes.+* A weekday in a pattern (@pddd@ or @pdddd@) is /consumed but not validated/ on a parse: since the day, month and year already fix the date, the weekday is not checked against them.+* The abbreviated month @pMMM@ is just the first three letters of the name, which is ambiguous where two months share a prefix (the Hebrew @AdarI@ and @Adar@); use @pMMMM@ or @pMM@ when you need a guaranteed round-trip. -} module Data.HodaTime (
− src/Data/HodaTime/Calendar/Constants.hs
@@ -1,8 +0,0 @@-module Data.HodaTime.Calendar.Constants-(- daysPerStandardYear-)-where--daysPerStandardYear :: Num a => a-daysPerStandardYear = 365
src/Data/HodaTime/Calendar/Coptic.hs view
@@ -1,6 +1,183 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.Calendar.Coptic+-- Copyright : (C) 2017 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- This is the module for 'CalendarDate' and 'CalendarDateTime' in the 'Coptic' calendar, the liturgical calendar of the Coptic Orthodox Church whose era of the Martyrs (Anno Martyrum) counts years+-- from AD 284. The year is twelve months of 30 days followed by a short thirteenth month ('PiKogiEnavot', the epagomenal days) of five days, or six in a leap year. Leap years follow the same simple+-- every-fourth-year rule as 'Data.HodaTime.Calendar.Julian' (a Coptic year is leap when @year \`mod\` 4 == 3@), with the extra day added at the end of the year. Year 1 begins on 29.Aug.284 in the+-- Julian calendar; dates share the same absolute timeline as every other calendar.+---------------------------------------------------------------------------- module Data.HodaTime.Calendar.Coptic (+ -- * Constructors+ calendarDate+ ,fromNthDay+ ,fromWeekDate+ -- * Types+ ,Month(..)+ ,DayOfWeek(..)+ ,Coptic ) where --- TODO: Min start week day+import Data.HodaTime.CalendarDateTime.Internal (IsCalendar(..), IsCalendarDateTime(..), CalendarDate, DayNth, DayOfMonth, Year, WeekNumber, CalendarDateTime(..), LocalTime(..), Date)+import Control.DeepSeq (NFData(..))+import Data.Hashable (Hashable(..))+import Data.HodaTime.Instant.Internal (Instant(..))+import Data.HodaTime.Calendar.Internal (mkCommonDayLens, mkCommonMonthLens, mkYearLens, mkFromNthDay, mkFromWeekDate, moveByDow, dayOfWeekFromDays, daysPerStandardYear, daysPerFourYears)+import Data.Int (Int32)+import Data.Word (Word8)+import Control.Monad (guard)++-- constants++monthsPerYear :: Int+monthsPerYear = 13++daysPerMonth :: Int+daysPerMonth = 30++-- | The day-of-year (0-based) at which the thirteenth month (the epagomenal days) begins.+daysBeforeEpagomenae :: Int+daysBeforeEpagomenae = 12 * daysPerMonth -- 360++-- | Coptic works in its own frame: internal flat day 0 is 1.Thout.1 (= 29.Aug.284 Julian). Only the 'Instant' bridge+-- crosses to the universal timeline (day 0 = 1.Mar.2000 Gregorian), where the Coptic epoch sits at this constant, so+-- 'toUnadjustedInstant' adds it and 'fromAdjustedInstant' subtracts it.+copticEpoch :: Num a => a+copticEpoch = -626575++firstCopDayTuple :: (Integral a, Integral b, Integral c) => (a, b, c)+firstCopDayTuple = (1, 0, 1) -- NOTE: 1.Thout.AM 1++invalidDayThresh :: Integral a => a+invalidDayThresh = fromIntegral $ pred day0+ where+ (y, m, d) = firstCopDayTuple :: (Year, Int, DayOfMonth)+ day0 = yearMonthDayToDays y (toEnum m) d++epochDayOfWeek :: DayOfWeek Coptic+epochDayOfWeek = Friday++-- types++data Coptic++instance IsCalendar Coptic where+ data Date Coptic = CopticDate {-# UNPACK #-} !Int32 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Int32+ deriving (Eq, Ord)++ data DayOfWeek Coptic = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++ data Month Coptic = Thout | Paopi | Hathor | Koiak | Tobi | Meshir | Paremhat | Paremoude | Pashons | Paoni | Epip | Mesori | PiKogiEnavot+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++ fromDays = copticFromDays+ toDays = copticToDays+ toYmd = copticToYmd+ calendarName _ = "Coptic"++ day' = mkCommonDayLens invalidDayThresh yearMonthDayToDays copticFromDays copticToYmd+ {-# INLINE day' #-}++ month' (CopticDate _ _ m _) = toEnum . fromIntegral $ m++ monthl' = mkCommonMonthLens monthsPerYear firstCopDayTuple maxDaysInMonth yearMonthDayToDays copticToYmd copticFromDays+ {-# INLINE monthl' #-}++ year' = mkYearLens firstCopDayTuple maxDaysInMonth yearMonthDayToDays copticToYmd copticFromDays+ {-# INLINE year' #-}++ dayOfWeek' (CopticDate days _ _ _) = toEnum . dayOfWeekFromDays epochDayOfWeek . fromIntegral $ days++ next' n dow (CopticDate days _ _ _) = moveByDow copticFromDays epochDayOfWeek n dow (-) (+) (>) (fromIntegral days)++ previous' n dow (CopticDate days _ _ _) = moveByDow copticFromDays epochDayOfWeek n dow subtract (-) (<) (fromIntegral days) -- NOTE: subtract is (-) with the arguments flipped++instance NFData (Date Coptic) where+ rnf (CopticDate days d m y) = rnf days `seq` rnf d `seq` rnf m `seq` rnf y++instance Hashable (Date Coptic) where+ hashWithSalt s (CopticDate days d m y) = s `hashWithSalt` days `hashWithSalt` d `hashWithSalt` m `hashWithSalt` y++instance NFData (Month Coptic) where+ rnf m = m `seq` ()++instance Hashable (Month Coptic) where+ hashWithSalt s = hashWithSalt s . fromEnum++instance NFData (DayOfWeek Coptic) where+ rnf d = d `seq` ()++instance Hashable (DayOfWeek Coptic) where+ hashWithSalt s = hashWithSalt s . fromEnum++instance IsCalendarDateTime Coptic where+ fromAdjustedInstant (Instant days secs nsecs) = CalendarDateTime (copticFromDays (days - copticEpoch)) (LocalTime secs nsecs)+ toUnadjustedInstant (CalendarDateTime cd (LocalTime secs nsecs)) = Instant (copticToDays cd + copticEpoch) secs nsecs++-- | Build the flat Coptic date (denormalized: keeps the day count plus the decoded day\/month\/year).+copticFromDays :: Int32 -> Date Coptic+copticFromDays days = CopticDate days d m y+ where (y, m, d) = daysToYearMonthDay days++copticToDays :: Date Coptic -> Int32+copticToDays (CopticDate days _ _ _) = days++copticToYmd :: Date Coptic -> (Int32, Word8, Word8)+copticToYmd (CopticDate _ d m y) = (y, m, d)++-- Constructors++-- | Smart constructor for a 'Coptic' calendar date.+calendarDate :: DayOfMonth -> Month Coptic -> Year -> Maybe (CalendarDate Coptic)+calendarDate d m y = do+ guard $ d > 0 && d <= maxDaysInMonth m y+ let days = fromIntegral $ yearMonthDayToDays y m d+ guard $ days > invalidDayThresh+ return $ copticFromDays days++-- | Smart constructor for a 'Coptic' calendar date given as a day relative to a month (e.g. the third Monday of the month). Returns 'Nothing' if the resulting date is invalid.+fromNthDay :: DayNth -> DayOfWeek Coptic -> Month Coptic -> Year -> Maybe (CalendarDate Coptic)+fromNthDay = mkFromNthDay invalidDayThresh epochDayOfWeek yearMonthDayToDays maxDaysInMonth copticFromDays++-- | Smart constructor for a 'Coptic' calendar date given as a week date. Note that this method assumes weeks start on Sunday and the first week of the year is the one+-- which has at least one day in the new year.+fromWeekDate :: WeekNumber -> DayOfWeek Coptic -> Year -> Maybe (CalendarDate Coptic)+fromWeekDate = mkFromWeekDate invalidDayThresh epochDayOfWeek yearMonthDayToDays copticFromDays 1 Sunday++-- helper functions++maxDaysInMonth :: Month Coptic -> Year -> Int+maxDaysInMonth PiKogiEnavot y+ | isLeap = 6+ | otherwise = 5+ where+ isLeap = 3 == y `mod` 4+maxDaysInMonth _ _ = daysPerMonth++yearMonthDayToDays :: Year -> Month Coptic -> DayOfMonth -> Int+yearMonthDayToDays y m d = (y - 1) * daysPerStandardYear + y `div` 4 + fromEnum m * daysPerMonth + d - 1++daysToYearMonthDay :: Int32 -> (Int32, Word8, Word8)+daysToYearMonthDay flatDays = (fromIntegral y, fromIntegral m, fromIntegral d)+ where+ n = fromIntegral flatDays -- days since 1.Thout.1 (>= 0 for valid dates)+ (fourYears, remaining) = n `divMod` daysPerFourYears -- 1461-day cycle, leap year last in each block+ (yearInBlock, dayOfYear)+ | remaining < 365 = (0, remaining)+ | remaining < 730 = (1, remaining - 365)+ | remaining < 1096 = (2, remaining - 730) -- the leap year (366 days)+ | otherwise = (3, remaining - 1096)+ y = 4 * fourYears + 1 + yearInBlock+ (m, d)+ | dayOfYear >= daysBeforeEpagomenae = (12, dayOfYear - daysBeforeEpagomenae + 1)+ | otherwise = let (mm, dd) = dayOfYear `divMod` daysPerMonth in (mm, dd + 1)
src/Data/HodaTime/Calendar/Gregorian.hs view
@@ -1,3 +1,19 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.Calendar.Gregorian+-- Copyright : (C) 2017 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- This is the module for 'CalendarDate' and 'CalendarDateTime' in the 'Gregorian' calendar, the civil calendar used across most of the world today. The Gregorian calendar refines the Julian leap+-- year rule: every fourth year is a leap year, except that a century year (one divisible by 100) is a leap year only when it is also divisible by 400. Those century exceptions keep the calendar+-- closely aligned to the solar year and correct the slow drift of 'Data.HodaTime.Calendar.Julian' (which gains roughly three days every four centuries). Unlike some libraries this calendar is not+-- proleptic: because the Gregorian calendar first took effect on 15 October 1582 (the day after 4 October 1582 in the Julian calendar, when ten days were dropped) this implementation rejects any+-- earlier date \- use 'Data.HodaTime.Calendar.Julian' for dates before the changeover. The Gregorian calendar anchors the absolute timeline that every other calendar is measured against, so a given+-- instant's Gregorian date is the reference that the other calendars are offset from.+---------------------------------------------------------------------------- module Data.HodaTime.Calendar.Gregorian ( -- * Constructors@@ -12,33 +28,28 @@ where import Data.HodaTime.Calendar.Gregorian.Internal hiding (fromWeekDate)-import Data.HodaTime.CalendarDateTime.Internal (CalendarDate(..), DayNth, DayOfMonth, Year, WeekNumber)+import Data.HodaTime.CalendarDateTime.Internal (CalendarDate, DayNth, DayOfMonth, Year, WeekNumber)+import Data.HodaTime.Calendar.Internal (mkFromNthDay) import qualified Data.HodaTime.Calendar.Gregorian.Internal as GI import Control.Monad (guard) -- Constructors --- | Smart constuctor for Gregorian calendar date.+-- TODO: smart constructors hard coded to Maybe, make them like LocalTime++-- | Smart constructor for a 'Gregorian' calendar date. Returns 'Nothing' if the day is out of range for the given month and year, or if the date falls before the 15 October 1582 changeover. calendarDate :: DayOfMonth -> Month Gregorian -> Year -> Maybe (CalendarDate Gregorian) calendarDate d m y = do guard $ d > 0 && d <= maxDaysInMonth m y- let days = fromIntegral $ yearMonthDayToDays y m d- guard $ days > invalidDayThresh- return $ CalendarDate days (fromIntegral d) (fromIntegral . fromEnum $ m) (fromIntegral y)+ let gd = gregorianFromYmd y m d+ guard $ gregorianToDays gd > invalidDayThresh+ return gd --- | Smart constuctor for Gregorian calendar date based on relative month day.+-- | Smart constructor for a 'Gregorian' calendar date given as a day relative to a month (e.g. the third Monday of the month). Returns 'Nothing' if the resulting date is invalid. fromNthDay :: DayNth -> DayOfWeek Gregorian -> Month Gregorian -> Year -> Maybe (CalendarDate Gregorian)-fromNthDay nth dow m y = do- guard $ d > 0 && d <= mdim- guard $ days > invalidDayThresh- return $ CalendarDate (fromIntegral days) (fromIntegral d) (fromIntegral . fromEnum $ m) (fromIntegral y)- where- nth' = fromEnum nth - 4- mdim = maxDaysInMonth m y- d = nthDayToDayOfMonth nth' (fromEnum dow) m y- days = yearMonthDayToDays y m d+fromNthDay = mkFromNthDay invalidDayThresh epochDayOfWeek yearMonthDayToDays maxDaysInMonth daysToGregorian --- | Smart constuctor for Gregorian calendar date based on week date. Note that this method assumes weeks start on Sunday and the first week of the year is the one+-- | Smart constructor for a 'Gregorian' calendar date given as a week date. Note that this method assumes weeks start on Sunday and the first week of the year is the one -- which has at least one day in the new year. For ISO compliant behavior use this constructor from the ISO module fromWeekDate :: WeekNumber -> DayOfWeek Gregorian -> Year -> Maybe (CalendarDate Gregorian) fromWeekDate = GI.fromWeekDate 1 Sunday
src/Data/HodaTime/Calendar/Gregorian/CacheTable.hs view
@@ -13,21 +13,32 @@ import Data.Word (Word16) import Data.Bits (shift, (.|.), (.&.), shiftR)+import Data.Array.Unboxed (array, UArray) -type DTCacheTableDaysEntry = Word16-type DTCacheTableHoursEntry = Word16+type DTCacheDaysTable = UArray Int Word16+type DTCacheHoursTable = UArray Int Word16 -data DTCacheTable = DTCacheTable [DTCacheTableDaysEntry] [DTCacheTableDaysEntry] [DTCacheTableHoursEntry]+data DTCacheTable = DTCacheTable DTCacheDaysTable DTCacheHoursTable +-- TODO: The start date is offset but otherwise the months are all in their+-- unrotated form (i.e. Jan/Feb are in their normal year, not the previous year).+-- does this hurt anything? It's nice for decoding but maybe some math expects+-- Jan/Feb to be (year - 1)++-- The Cache Table holds years and hours in the following format:+-- +-----+----+----+ +----+----+----++-- |0-100|1-12|1-31| |0-11|0-59|0-59|+-- +-----+----+----+ +----+----+----++-- 7 4 5 4 6 6+-- Meaning we can store 100 years of days and 12 hours of seconds in 16 bits each cacheTable :: DTCacheTable-cacheTable = DTCacheTable days negDays hours where- days = firstYear ++ restYears- firstYear = [ encodeDate 0 m d | m <- [2..11], d <- daysInMonth m 0]- restYears = [ encodeDate y m d | y <- [1..127], m <- [0..11], d <- daysInMonth m y]- negDays = 0 : negFirstYear ++ restPrevYears -- TODO: instead of 0 it should be undefined, as this should never be accessed- negFirstYear = [ encodeDate 0 m d | m <- [1,0], d <- reverse . daysInMonth m $ 0]- restPrevYears = [ encodeDate y m d | y <- [1..127], m <- [11,10..0], d <- reverse . daysInMonth m $ - y] -- NOTE: all that matters is the feb calculation which is fixed by negating the year- hours = [ encodeTime h m s | h <- [0..11], m <- [0..59], s <- [0..59]]+cacheTable = DTCacheTable days hours where+ toArray xs = array (0, length xs - 1) $ zip [0..] xs+ days = toArray $ firstYear ++ years ++ lastYear+ firstYear = [ encodeDate 0 m d | m <- [2..11], d <- daysInMonth m 0]+ years = [ encodeDate y m d | y <- [1..99], m <- [0..11], d <- daysInMonth m y]+ lastYear = [ encodeDate 100 m d | m <- [0, 1], d <- daysInMonth m 100]+ hours = toArray [ encodeTime h m s | h <- [0..11], m <- [0..59], s <- [0..59]] -- encode @@ -40,18 +51,18 @@ encodeDate :: Word16 -> Word16 -> Word16 -> Word16 encodeDate y m d = shift y yearShift .|. shift m monthShift .|. d +-- Annoying to semi replicate this logic but otherwise we have to move much of this code to Internal to use the enums daysInMonth :: Word16 -> Word16 -> [Word16] daysInMonth 1 y- | isLeap = [1..29]- | otherwise = [1..28]+ | isLeap = [1..29]+ | otherwise = [1..28] where- y' = y + 2000 isLeap- | 0 == y' `mod` 100 = 0 == y' `mod` 400- | otherwise = 0 == y' `mod` 4+ | 0 == y `mod` 100 = False -- 400+ is not possible here+ | otherwise = 0 == y `mod` 4 daysInMonth n _- | n == 3 || n == 5 || n == 8 || n == 10 = [1..30]- | otherwise = [1..31]+ | n == 3 || n == 5 || n == 8 || n == 10 = [1..30]+ | otherwise = [1..31] hourShift :: Num a => a hourShift = 12
src/Data/HodaTime/Calendar/Gregorian/Internal.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE TypeFamilies #-}-+{-# LANGUAGE FlexibleInstances #-} module Data.HodaTime.Calendar.Gregorian.Internal ( daysToYearMonthDay@@ -14,23 +14,33 @@ ,nthDayToDayOfMonth ,dayOfWeekFromDays ,instantToYearMonthDay+ ,yearMonthDayToCycleCenturyDays+ ,gregorianFromYmd+ ,gregorianToDays+ ,daysToGregorian+ ,gregorianToYearMonthDay ) where -import Data.HodaTime.Constants (daysPerCycle, daysPerCentury, daysPerFourYears)-import Data.HodaTime.CalendarDateTime.Internal (IsCalendar(..), CalendarDate(..), IsCalendarDateTime(..), DayOfMonth, Year, WeekNumber, CalendarDateTime(..), LocalTime(..))+import Data.HodaTime.CalendarDateTime.Internal (IsCalendar(..), IsCalendarDateTime(..), DayOfMonth, Year, WeekNumber, CalendarDateTime(..), LocalTime(..), Date) import Data.HodaTime.Calendar.Gregorian.CacheTable (DTCacheTable(..), decodeMonth, decodeYear, decodeDay, cacheTable)-import Data.HodaTime.Calendar.Constants (daysPerStandardYear)+import Data.HodaTime.Calendar.Internal (mkCommonMonthLens, mkYearLens, mkFromWeekDate, dayOfWeekFromDays, commonMonthDayOffsets, borders, daysPerStandardYear, daysPerCentury) import Data.HodaTime.Instant.Internal (Instant(..)) import Control.Arrow ((>>>), (&&&), (***), first)-import Data.Maybe (fromJust)-import Data.List (findIndex) import Data.Int (Int32, Int8) import Data.Word (Word8, Word32)-import Control.Monad (guard)+import Data.Array.Unboxed ((!))+import Control.DeepSeq (NFData(..))+import Data.Hashable (Hashable(..)) -- Constants +yearsPerCycle :: Num a => a+yearsPerCycle = 400++daysPerCycle :: Num a => a -- NOTE: A "cycle" is 400 years+daysPerCycle = 146097+ invalidDayThresh :: Integral a => a invalidDayThresh = -152445 -- NOTE: 14.Oct.1582, one day before Gregorian calendar came into effect @@ -40,120 +50,97 @@ epochDayOfWeek :: DayOfWeek Gregorian epochDayOfWeek = Wednesday -monthDayOffsets :: Num a => [a]-monthDayOffsets = 0 : rest- where- rest = zipWith (+) daysPerMonth (0:rest)- daysPerMonth = [31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31, 28] -- NOTE: rotated (TODO BUG: Why do we need Feb? That will be past end of year, thus impossible)- -- types data Gregorian instance IsCalendar Gregorian where- type Date Gregorian = CalendarDate Gregorian- + data Date Gregorian = GregorianDate {-# UNPACK #-} !Int8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word32+ deriving (Eq, Ord)+ data DayOfWeek Gregorian = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday- deriving (Show, Eq, Ord, Enum, Bounded)- + deriving (Show, Read, Eq, Ord, Enum, Bounded)+ data Month Gregorian = January | February | March | April | May | June | July | August | September | October | November | December- deriving (Show, Eq, Ord, Enum, Bounded)- - day' f (CalendarDate _ d m y) = mkcd . (rest+) <$> f (fromIntegral d)- where- rest = pred $ yearMonthDayToDays (fromIntegral y) (toEnum . fromIntegral $ m) 1- mkcd days =- let- days' = fromIntegral $ if days > invalidDayThresh then days else invalidDayThresh + 1- (y', m', d') = daysToYearMonthDay days'- in CalendarDate days' d' m' y'- {-# INLINE day' #-}- - month' (CalendarDate _ _ m _) = toEnum . fromIntegral $ m- - monthl' f (CalendarDate _ d m y) = mkcd <$> f (fromEnum m)+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++ fromDays = daysToGregorian+ toDays = gregorianToDays+ toYmd = gregorianToYearMonthDay+ calendarName _ = "Gregorian"++ -- Fast path: shift only the day-in-century, leaving cycle\/century untouched when we stay in-century.+ day' f gd = mkgd <$> f (fromIntegral d) where- mkcd months = CalendarDate (fromIntegral days) d'' (fromIntegral m') (fromIntegral y'')- where- (y', months') = flip divMod 12 >>> first (+ fromIntegral y) $ months- (y'', m', d') = if (y', months', d) < firstGregDayTuple then firstGregDayTuple else (y', months', d)- mdim = fromIntegral $ maxDaysInMonth (toEnum m') y'- d'' = if d' > mdim then mdim else d'- days = yearMonthDayToDays y'' (toEnum m') (fromIntegral d'')+ (_, _, d) = gregorianToYearMonthDay gd+ mkgd d' = shiftDaysWith clampToValid (d' - fromIntegral d) gd++ month' gd = toEnum . fromIntegral $ m+ where (_, m, _) = gregorianToYearMonthDay gd++ monthl' = mkCommonMonthLens 12 firstGregDayTuple maxDaysInMonth yearMonthDayToDays gregorianToYearMonthDay daysToGregorian {-# INLINE monthl' #-}- - year' f (CalendarDate _ d m y) = mkcd <$> f (fromIntegral y)- where- mkcd y' = CalendarDate days d'' m' (fromIntegral y'')- where- (y'', m', d') = if (y', m, d) < firstGregDayTuple then firstGregDayTuple else (y', m, d)- m'' = toEnum . fromIntegral $ m'- mdim = fromIntegral $ maxDaysInMonth m'' y''- d'' = if d' > mdim then mdim else d'- days = fromIntegral $ yearMonthDayToDays y'' m'' (fromIntegral d'')++ year' = mkYearLens firstGregDayTuple maxDaysInMonth yearMonthDayToDays gregorianToYearMonthDay daysToGregorian {-# INLINE year' #-}- - dayOfWeek' (CalendarDate days _ _ _) = toEnum . dayOfWeekFromDays . fromIntegral $ days- - next' n dow (CalendarDate days _ _ _) = moveByDow n dow (-) (+) (fromIntegral days)- - previous' n dow (CalendarDate days _ _ _) = moveByDow n dow subtract (-) (fromIntegral days) -- NOTE: subtract is (-) with the arguments flipped -instance IsCalendarDateTime Gregorian where- fromAdjustedInstant (Instant days secs nsecs) = CalendarDateTime cd lt+ dayOfWeek' (GregorianDate _ century dic) = toEnum . dayOfWeekFromDays epochDayOfWeek $ 5 * fromIntegral century + fromIntegral dic++ next' n dow gd@(GregorianDate _ century dic) = shiftDaysWith id (7 * n' + targetDow - currentDoW) gd where- cd = CalendarDate days d m y- (y, m, d) = daysToYearMonthDay days- lt = LocalTime secs nsecs+ currentDoW = dayOfWeekFromDays epochDayOfWeek $ 5 * fromIntegral century + fromIntegral dic+ targetDow = fromEnum dow+ n' = if targetDow > currentDoW then n - 1 else n - toUnadjustedInstant (CalendarDateTime (CalendarDate days _ _ _) (LocalTime secs nsecs)) = Instant days secs nsecs+ previous' n dow gd@(GregorianDate _ century dic) = shiftDaysWith id (negate $ 7 * n' + currentDoW - targetDow) gd+ where+ currentDoW = dayOfWeekFromDays epochDayOfWeek $ 5 * fromIntegral century + fromIntegral dic+ targetDow = fromEnum dow+ n' = if targetDow < currentDoW then n - 1 else n +instance NFData (Date Gregorian) where+ rnf (GregorianDate cyc century dic) = rnf cyc `seq` rnf century `seq` rnf dic++instance Hashable (Date Gregorian) where+ hashWithSalt s (GregorianDate cyc century dic) = s `hashWithSalt` cyc `hashWithSalt` century `hashWithSalt` dic++instance NFData (Month Gregorian) where+ rnf m = m `seq` ()++instance Hashable (Month Gregorian) where+ hashWithSalt s = hashWithSalt s . fromEnum++instance NFData (DayOfWeek Gregorian) where+ rnf d = d `seq` ()++instance Hashable (DayOfWeek Gregorian) where+ hashWithSalt s = hashWithSalt s . fromEnum++instance IsCalendarDateTime Gregorian where+ fromAdjustedInstant (Instant days secs nsecs) = CalendarDateTime (daysToGregorian days) (LocalTime secs nsecs)+ toUnadjustedInstant (CalendarDateTime gd (LocalTime secs nsecs)) = Instant (gregorianToDays gd) secs nsecs+ -- constructors fromWeekDate :: Int -> DayOfWeek Gregorian -> WeekNumber -> DayOfWeek Gregorian -> Year -> Maybe (Date Gregorian)-fromWeekDate minWeekDays wkStartDoW weekNum dow y = do- guard $ days > invalidDayThresh- return $ CalendarDate days d m y'- where- soyDays = yearMonthDayToDays y January minWeekDays- soyDoW = dayOfWeekFromDays soyDays- startDoWDistance = fromEnum soyDoW - fromEnum wkStartDoW- dowDistance = fromEnum dow - fromEnum wkStartDoW- dowDistance' = if dowDistance < 0 then dowDistance + 7 else dowDistance- startDays = soyDays - startDoWDistance- weekNum' = pred weekNum- days = fromIntegral $ startDays + weekNum' * 7 + dowDistance'- (y', m, d) = daysToYearMonthDay days+fromWeekDate = mkFromWeekDate invalidDayThresh epochDayOfWeek yearMonthDayToDays daysToGregorian -- helper functions nthDayToDayOfMonth :: Int -> Int -> Month Gregorian -> Int -> Int-nthDayToDayOfMonth nth day month y = dom + d' + 7 * nth+nthDayToDayOfMonth nth day month y+ | nth < 0 = mdm - backwardDist + 7 * (nth + 1) -- NOTE: "from last" (POSIX week 5 -> nth -1) counts back from the last day, so the final weekday is not missed when the month ends exactly on it+ | otherwise = 1 + forwardDist + 7 * nth where mdm = maxDaysInMonth month y- dom = if nth < 0 then mdm else 1+ forwardDist = (day - dowOf 1) `mod` 7+ backwardDist = (dowOf mdm - day) `mod` 7+ dowOf dom = (dom + (13 * m' - 1) `div` 5 + yrhs + (yrhs `div` 4) + (ylhs `div` 4) - 2 * ylhs) `mod` 7 m = fromEnum month- dow = (dom + (13 * m' - 1) `div` 5 + yrhs + (yrhs `div` 4) + (ylhs `div` 4) - 2 * ylhs) `mod` 7- d = day - dow- d' = if d < 0 then d + 7 else d (m', y') = if m < 2 then (m + 11, y - 1) else (m - 1, y) yrhs = y' `mod` 100 ylhs = y' `div` 100 -dayOfWeekFromDays :: Int -> Int-dayOfWeekFromDays = normalize . (fromEnum epochDayOfWeek +) . flip mod 7- where- normalize n = if n >= 7 then n - 7 else n--moveByDow :: Int -> DayOfWeek Gregorian -> (Int -> Int -> Int) -> (Int -> Int -> Int) -> Int -> CalendarDate Gregorian-moveByDow n dow distanceF adjust days = CalendarDate days' d m y- where- currentDoW = dayOfWeekFromDays days- targetDow = fromIntegral . fromEnum $ dow- distance = distanceF targetDow currentDoW- days' = fromIntegral $ fromIntegral days `adjust` (7 * n) `adjust` distance- (y, m, d) = daysToYearMonthDay days'- maxDaysInMonth :: Month Gregorian -> Year -> Int maxDaysInMonth February y | isLeap = 29@@ -166,22 +153,37 @@ | m == April || m == June || m == September || m == November = 30 | otherwise = 31 --- NOTE: Epoch is March 1 2000 because that has nicest properties that is near our current time.--- TODO: The addition of leap days below will add from the previous year. We need to determine if this is a bug--- TODO: and if it is not, why isn't it+-- | Construct the (cycle, century, day-in-century) triple directly from a year\/month\/day, without first+-- computing the flat day count and dividing it back down. Within a cycle each century is exactly 36524 days+-- (4*36524 = 146097 - 1, the missing day being the cycle's extra leap day), and within a century the leap rule+-- reduces to a plain \/4 (the \/100 and \/400 corrections vanish for year-offsets 0..99). This naturally yields+-- representation (ii): 'century' is always in [0,3] and the extra leap day falls out as day 36524 of the last century.+yearMonthDayToCycleCenturyDays :: Year -> Month Gregorian -> DayOfMonth -> (Int, Int, Int)+yearMonthDayToCycleCenturyDays y m d = (cyc, century, dic)+ where+ years = if m < March then y - 2001 else y - 2000+ (cyc, yearInCycle) = years `divMod` yearsPerCycle+ (century, yoc) = yearInCycle `divMod` 100+ m' = if m > February then fromEnum m - 2 else fromEnum m + 10+ dic = yoc * daysPerStandardYear + yoc `div` 4 + commonMonthDayOffsets !! m' + d - 1++-- | Build a 'Date' 'Gregorian' directly from a year\/month\/day via 'yearMonthDayToCycleCenturyDays' (keeping the+-- 'GregorianDate' constructor internal to this module). No validity checking is performed here.+gregorianFromYmd :: Year -> Month Gregorian -> DayOfMonth -> Date Gregorian+gregorianFromYmd y m d = GregorianDate (fromIntegral cyc) (fromIntegral century) (fromIntegral dic)+ where (cyc, century, dic) = yearMonthDayToCycleCenturyDays y m d++-- NOTE: Epoch is March 1 2000 because that has nicest properties that is near our current time. Because the year is+-- NOTE: shifted to start in March, January and February belong to the /previous/ shifted year (years = y - 2001), so+-- NOTE: the leap-day terms (div 4 \/ 100 \/ 400) naturally count Feb 29 only once it has actually occurred. Verified+-- NOTE: against proleptic Gregorian arithmetic for every date in years 1-9999 (all century boundaries and negatives). yearMonthDayToDays :: Year -> Month Gregorian -> DayOfMonth -> Int yearMonthDayToDays y m d = days where m' = if m > February then fromEnum m - 2 else fromEnum m + 10 years = if m < March then y - 2001 else y - 2000 yearDays = years * daysPerStandardYear + years `div` 4 + years `div` 400 - years `div` 100- days = yearDays + monthDayOffsets !! m' + d - 1---- | The issue is that 4 * daysPerCentury will be one less than daysPerCycle. The reason for this is that the Gregorian calendar adds one more day per 400 year cycle--- and this day is missing from adding up 4 individual centuries. We have the same issue again with 4 years (i.e. 365*4 is daysPerFourYears - 1)--- so we use this function to check if this has occurred so we can add the missing day back in.-borders :: (Num a, Eq a) => a -> a -> Bool-borders c x = x == c - 1+ days = yearDays + commonMonthDayOffsets !! m' + d - 1 -- | Count up centuries, plus remaining days and determine if this is a special extra cycle day. NOTE: This -- function would be more accurate if it only took absolute values, but it does end up coming up with the correct answer even on negatives. It just@@ -192,29 +194,64 @@ (cycleYears, (cycleDays, isExtraCycleDay)) = flip divMod daysPerCycle >>> (* 400) *** id &&& borders daysPerCycle $ days (centuryYears, centuryDays) = flip divMod daysPerCentury >>> first (* 100) $ cycleDays y = cycleYears + centuryYears- -daysToYearMonthDay :: Int32 -> (Word32, Word8, Word8)-daysToYearMonthDay days = (fromIntegral y, fromIntegral m'', fromIntegral d')- where- (centuryYears, centuryDays, isExtraCycleDay) = calculateCenturyDays days- (fourYears, (remaining, isLeapDay)) = flip divMod daysPerFourYears >>> (* 4) *** id &&& borders daysPerFourYears $ centuryDays- (oneYears, yearDays) = remaining `divMod` daysPerStandardYear- m = pred . fromJust . findIndex (\mo -> yearDays < mo) $ monthDayOffsets- (m', startDate) = if m >= 10 then (m - 10, 2001) else (m + 2, 2000)- d = yearDays - monthDayOffsets !! m + 1- (m'', d') = if isExtraCycleDay || isLeapDay then (1, 29) else (m', d)- y = startDate + centuryYears + fourYears + oneYears- --- TODO: At some point we should see how much a difference the caching makes-_daysToYearMonthDay' :: Int32 -> (Int32, Int8, Int8)-_daysToYearMonthDay' days = (y',m'', fromIntegral d')++daysToYearMonthDay :: Int32 -> (Int32, Word8, Word8)+daysToYearMonthDay days = (fromIntegral y', m'', fromIntegral d') where (centuryYears, centuryDays, isExtraCycleDay) = calculateCenturyDays days- decodeEntry (DTCacheTable xs _ _) = (\x -> (decodeYear x, decodeMonth x, decodeDay x)) . (!!) xs+ decodeEntry (DTCacheTable xs _) = (\x -> (decodeYear x, decodeMonth x, decodeDay x)) . (!) xs (y,m,d) = decodeEntry cacheTable . fromIntegral $ centuryDays (m',d') = if isExtraCycleDay then (1,29) else (m,d) (y',m'') = (2000 + centuryYears + fromIntegral y, fromIntegral $ m') -- here to avoid circular dependancy between Instant and Gregorian-instantToYearMonthDay :: Instant -> (Word32, Word8, Word8)+instantToYearMonthDay :: Instant -> (Int32, Word8, Word8) instantToYearMonthDay (Instant days _ _) = daysToYearMonthDay days++-- Date Gregorian bridge functions (cycle\/century\/day-in-century representation)++-- | Reconstruct the flat (epoch-relative) day count from a 'Date' 'Gregorian'. Inverse of 'daysToGregorian'; must+-- agree with 'yearMonthDayToDays' so the cycle representation round-trips against the flat day count.+gregorianToDays :: Date Gregorian -> Int32+gregorianToDays (GregorianDate cyc century days) = fromIntegral $ cyc' * daysPerCycle + century' * daysPerCentury + days'+ where+ cyc' = fromIntegral cyc :: Int+ century' = fromIntegral century :: Int+ days' = fromIntegral days :: Int++-- | Decompose a flat (epoch-relative) day count into the cycle\/century\/day-in-century representation. Uses floored+-- 'divMod' so remainders are non-negative. Representation (ii): 'century' is always in [0,3]; the single extra leap+-- day per cycle (which floored division would place at century 4, day 0) is folded back to day 36524 of century 3.+daysToGregorian :: Int32 -> Date Gregorian+daysToGregorian days = GregorianDate (fromIntegral cycles) (fromIntegral century) (fromIntegral dic)+ where+ (cycles, cycleDays) = (fromIntegral days :: Int) `divMod` daysPerCycle+ (century0, dic0) = cycleDays `divMod` daysPerCentury+ (century, dic) = if century0 == (4 :: Int) then (3, dic0 + daysPerCentury) else (century0, dic0)++-- | Decode a 'Date' 'Gregorian' directly to (year, zero-based month, day) from its stored fields: the cycle\/century+-- split is already present, so month and day come from a single cache-table lookup on the day-in-century.+gregorianToYearMonthDay :: Date Gregorian -> (Int32, Word8, Word8)+gregorianToYearMonthDay (GregorianDate cyc century dic)+ | dic == daysPerCentury = (fromIntegral extraYear, 1, 29) -- extra-cycle-day: 29 Feb (month 1 = February, 0-based)+ | otherwise = (fromIntegral yr, fromIntegral m, fromIntegral d)+ where+ cycleYear = fromIntegral cyc * (400 :: Int)+ extraYear = 2000 + cycleYear + 400+ yr = 2000 + cycleYear + fromIntegral century * 100 + fromIntegral y+ (y, m, d) = decodeEntry cacheTable . fromIntegral $ dic+ decodeEntry (DTCacheTable xs _) = (\x -> (decodeYear x, decodeMonth x, decodeDay x)) . (!) xs++-- | Shift a date by 'delta' days. Fast path: when the shift stays within the current century (and we are safely+-- past the pre-Gregorian threshold, so cyc >= -1) only the day-in-century changes and the cycle\/century are+-- untouched. Otherwise fall back to reconstructing the flat day count, applying 'onFlat' (e.g. the validity clamp),+-- and re-decomposing. The extra-cycle-day (day-in-century == 36524) always fails the in-century bound.+shiftDaysWith :: (Int32 -> Int32) -> Int -> Date Gregorian -> Date Gregorian+shiftDaysWith onFlat delta gd@(GregorianDate cyc century dic)+ | cyc >= -1 && dic' >= 0 && dic' < daysPerCentury = GregorianDate cyc century (fromIntegral dic')+ | otherwise = daysToGregorian . onFlat $ gregorianToDays gd + fromIntegral delta+ where dic' = fromIntegral dic + delta :: Int++-- | Clamp a flat day count so it never precedes the first valid Gregorian date (15 Oct 1582).+clampToValid :: Int32 -> Int32+clampToValid days = if days > invalidDayThresh then days else invalidDayThresh + 1
src/Data/HodaTime/Calendar/Hebrew.hs view
@@ -1,9 +1,435 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.Calendar.Hebrew+-- Copyright : (C) 2017 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- This is the module for 'CalendarDate' and 'CalendarDateTime' in the 'Hebrew' (Jewish) calendar, a lunisolar calendar that keeps its lunar months in step with the solar year by inserting a thirteenth+-- month ('AdarI') seven times in each nineteen-year Metonic cycle (in years 3, 6, 8, 11, 14, 17 and 19). A common year has twelve months and a leap year thirteen; two of the months ('Cheshvan' and+-- 'Kislev') can independently gain or lose a day so that the year comes out to one of six permitted lengths (353\/354\/355 days common, 383\/384\/385 leap). The year number changes at 1 'Tishri' (Rosh+-- Hashanah), and dates share the same absolute timeline as every other calendar.+--+-- == Month numbering: civil vs. scriptural+--+-- There are two traditional ways to /number/ the Hebrew months, and — as with the Islamic leap patterns — the calendar is parameterised over the choice at the /type level/ so that a date always records which+-- convention it uses and the type system refuses to mix the two. The choice does not change the underlying calendar at all (the months, their lengths and the day a given date falls on are identical); it only+-- changes which ordinal number 'fromEnum' \/ 'toEnum' assign to each month:+--+-- * __Civil__ (the default) counts from 'Tishri', the month of Rosh Hashanah at which the year number turns over. This is the numbering used by the .NET @HebrewCalendar@ and is the natural one for most+-- software: Tishri = 1, Cheshvan = 2, … , with the leap month 'AdarI' falling in the middle of the sequence in a leap year.+--+-- * __Scriptural__ (biblical\/ecclesiastical) counts from 'Nisan', the \"first month\" of the Exodus. Nisan = 1, Iyar = 2, … , Tishri = 7, and the leap month 'AdarI' is numbered last (after 'Shevat'),+-- keeping the numbers of the other twelve months fixed between common and leap years.+--+-- The month /constructors/ are shared across both conventions (the parameter is phantom for storage), so 'Nisan' is the same month either way — only its 'Enum' number differs. Each convention has a type+-- synonym, 'HebrewCivil' and 'HebrewScriptural', and 'HebrewCivil' is the default.+--+-- == The two Adars+--+-- In a common year there is a single month 'Adar'. A leap year inserts an extra month, 'AdarI' (Adar Rishon), /before/ it; the original 'Adar' then plays the role of \"Adar II\" (Adar Sheni) and still+-- carries Purim. So 'Adar' is present every year and 'AdarI' exists only in leap years — attempting to build a date in 'AdarI' in a common year yields 'Nothing', exactly as an out-of-range day or year does.+---------------------------------------------------------------------------- module Data.HodaTime.Calendar.Hebrew (+ -- * Constructors (default civil calendar)+ calendarDate+ ,fromNthDay+ ,fromWeekDate+ -- * Constructors (choose the numbering)+ ,calendarDate'+ ,fromNthDay'+ ,fromWeekDate'+ -- * Types+ ,Hebrew+ ,MonthNumbering(..)+ ,Month(..)+ ,DayOfWeek(..)+ ,KnownNumbering+ -- * Named calendars (month-numbering type synonyms)+ ,HebrewCivil+ ,HebrewScriptural ) where -data HebrewMonthNumbering =- HebrewCivil- | HebrewScriptural- deriving (Eq, Show)+import Data.HodaTime.CalendarDateTime.Internal (IsCalendar(..), IsCalendarDateTime(..), CalendarDate, DayNth, DayOfMonth, Year, WeekNumber, CalendarDateTime(..), LocalTime(..), Date)+import Control.DeepSeq (NFData(..))+import Data.Hashable (Hashable(..))+import Data.HodaTime.Instant.Internal (Instant(..))+import Data.HodaTime.Calendar.Internal (mkFromNthDay, moveByDow, dayOfWeekFromDays)+import Data.Int (Int32)+import Data.List (elemIndex)+import Data.Maybe (fromJust)+import Data.Word (Word8)+import Control.Monad (guard)++-- types++-- | The two conventions for numbering the Hebrew months, used as the (kind-'MonthNumbering') type parameter of 'Hebrew'+-- (see the module header).+data MonthNumbering = Civil | Scriptural++-- | The Hebrew (Jewish) calendar, parameterised by its month-numbering convention (see 'MonthNumbering').+data Hebrew (n :: MonthNumbering)++-- | The Hebrew calendar numbered from 'Tishri' (the .NET @HebrewCalendar@ convention). This is the default.+type HebrewCivil = Hebrew 'Civil+-- | The Hebrew calendar numbered from 'Nisan' (the biblical \/ ecclesiastical convention).+type HebrewScriptural = Hebrew 'Scriptural++-- | Reflects a 'MonthNumbering' down to the calendar-order index at which it begins counting months: civil starts at+-- 'Tishri' (0) and scriptural at 'Nisan' (7). Read it via @TypeApplications@, e.g. @'numberingStart' \@'Civil'@.+class KnownNumbering (n :: MonthNumbering) where+ numberingStart :: Int++instance KnownNumbering 'Civil where numberingStart = 0+instance KnownNumbering 'Scriptural where numberingStart = 7 -- 'Nisan' is calendar-order index 7++-- | The Hebrew calendar. All of the field lenses and conversions run in numbering-independent calendar order; the+-- numbering only selects how 'Month' values are numbered by 'Enum'.+instance KnownNumbering n => IsCalendar (Hebrew n) where+ -- | Denormalized: the flat, epoch-relative day count plus the decoded day, calendar-order month index and year.+ data Date (Hebrew n) = HebrewDate {-# UNPACK #-} !Int32 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Int32+ deriving (Eq, Ord)++ -- | The Hebrew months, listed in calendar order from 'Tishri'. 'AdarI' (the leap month) sits between 'Shevat' and+ -- 'Adar'; it exists only in leap years. The constructors are shared by both numbering conventions — only their+ -- 'Enum' numbers differ.+ data Month (Hebrew n) =+ Tishri | Cheshvan | Kislev | Tevet | Shevat | AdarI | Adar | Nisan | Iyar | Sivan | Tammuz | Av | Elul+ deriving (Show, Read, Eq, Ord, Bounded)++ data DayOfWeek (Hebrew n) = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++ fromDays = hebrewFromDays+ toDays = hebrewToDays+ toYmd = hebrewToYmd+ calendarName _ = "Hebrew"++ day' = hebrewDayLens+ {-# INLINE day' #-}++ month' (HebrewDate _ _ ci _) = monthAt (fromIntegral ci)++ monthl' = hebrewMonthLens (numberingStart @n)+ {-# INLINE monthl' #-}++ year' = hebrewYearLens+ {-# INLINE year' #-}++ dayOfWeek' (HebrewDate days _ _ _) = toEnum . dayOfWeekFromDays epochDayOfWeek . fromIntegral $ days++ next' i dow (HebrewDate days _ _ _) = moveByDow hebrewFromDays epochDayOfWeek i dow (-) (+) (>) (fromIntegral days)++ previous' i dow (HebrewDate days _ _ _) = moveByDow hebrewFromDays epochDayOfWeek i dow subtract (-) (<) (fromIntegral days) -- NOTE: subtract is (-) with the arguments flipped++-- | The 'Month' 'Enum' is the one place the numbering shows: it is calendar order rotated so counting begins at the+-- numbering's start month ('numberingStart').+instance KnownNumbering n => Enum (Month (Hebrew n)) where+ fromEnum m = (calendarIndex m - numberingStart @n) `mod` monthCount+ toEnum i+ | i >= 0 && i < monthCount = monthAt ((i + numberingStart @n) `mod` monthCount)+ | otherwise = error "Data.HodaTime.Calendar.Hebrew: toEnum: month out of range 0..12"++instance NFData (Date (Hebrew n)) where+ rnf (HebrewDate days d m y) = rnf days `seq` rnf d `seq` rnf m `seq` rnf y++instance Hashable (Date (Hebrew n)) where+ hashWithSalt s (HebrewDate days d m y) = s `hashWithSalt` days `hashWithSalt` d `hashWithSalt` m `hashWithSalt` y++instance NFData (Month (Hebrew n)) where+ rnf m = m `seq` ()++instance KnownNumbering n => Hashable (Month (Hebrew n)) where+ hashWithSalt s = hashWithSalt s . fromEnum++instance NFData (DayOfWeek (Hebrew n)) where+ rnf d = d `seq` ()++instance Hashable (DayOfWeek (Hebrew n)) where+ hashWithSalt s = hashWithSalt s . fromEnum++instance IsCalendarDateTime (Hebrew n) where+ fromAdjustedInstant (Instant days secs nsecs) = CalendarDateTime (hebrewFromDays days) (LocalTime secs nsecs)+ toUnadjustedInstant (CalendarDateTime hd (LocalTime secs nsecs)) = Instant (hebrewToDays hd) secs nsecs++-- constructors++-- | Smart constructor for a date in the default civil-numbered Hebrew calendar. Returns 'Nothing' if the day is out of+-- range for the month (including 'AdarI' in a common year) or the year is before 1. Use @calendarDate'@ to select the+-- scriptural numbering.+calendarDate :: DayOfMonth -> Month HebrewCivil -> Year -> Maybe (CalendarDate HebrewCivil)+calendarDate = calendarDate'++-- | Smart constructor for a 'Hebrew' date in either numbering (chosen by the result type). Returns 'Nothing' if the+-- day is out of range for the month (including 'AdarI' in a common year) or the year is before 1.+calendarDate' :: DayOfMonth -> Month (Hebrew n) -> Year -> Maybe (CalendarDate (Hebrew n))+calendarDate' d m y = do+ guard $ y >= 1+ guard $ d > 0 && d <= maxDaysInMonth m y+ let days = hebrewYearMonthDayToDays y (calendarIndex m) d+ guard $ days > invalidDayThresh+ return $ hebrewFromDays (fromIntegral days)++-- | Smart constructor for the default civil calendar given as a day relative to a month (e.g. the third Monday).+-- Returns 'Nothing' if the resulting date is invalid.+fromNthDay :: DayNth -> DayOfWeek HebrewCivil -> Month HebrewCivil -> Year -> Maybe (CalendarDate HebrewCivil)+fromNthDay = fromNthDay'++-- | As 'fromNthDay', but in either numbering (chosen by the result type).+fromNthDay' :: KnownNumbering n => DayNth -> DayOfWeek (Hebrew n) -> Month (Hebrew n) -> Year -> Maybe (CalendarDate (Hebrew n))+fromNthDay' = mkFromNthDay invalidDayThresh epochDayOfWeek ymd mdim hebrewFromDays+ where+ ymd y m d = hebrewYearMonthDayToDays y (calendarIndex m) d+ mdim m y = maxDaysInMonth m y++-- | Smart constructor for the default civil calendar given as a week date. Weeks are taken to start on 'Sunday' (as in+-- the Hebrew week) and week 1 is the one containing 1.'Tishri'.+fromWeekDate :: WeekNumber -> DayOfWeek HebrewCivil -> Year -> Maybe (CalendarDate HebrewCivil)+fromWeekDate = fromWeekDate'++-- | As 'fromWeekDate', but in either numbering (chosen by the result type).+fromWeekDate' :: WeekNumber -> DayOfWeek (Hebrew n) -> Year -> Maybe (CalendarDate (Hebrew n))+fromWeekDate' weekNum dow y = do+ guard $ days > invalidDayThresh+ return $ hebrewFromDays (fromIntegral days)+ where+ startOfYear = hebrewYearMonthDayToDays y 0 1 -- 1.Tishri (calendar-order index 0)+ startDoW = dayOfWeekFromDays epochDayOfWeek startOfYear+ weekStartDays = startOfYear - startDoW -- the Sunday on or before 1.Tishri+ days = weekStartDays + pred weekNum * 7 + fromEnum dow++-- helper functions++-- | The Hebrew months in calendar order, starting at 'Tishri': the single source of truth for month ordering. Both+-- numbering conventions derive from it (civil counts from the head; scriptural is this cycle rotated to begin at+-- 'Nisan'), so their 'Enum' numbers cannot drift out of step.+calendarMonths :: [Month (Hebrew n)]+calendarMonths = [Tishri, Cheshvan, Kislev, Tevet, Shevat, AdarI, Adar, Nisan, Iyar, Sivan, Tammuz, Av, Elul]++-- | The number of month constructors (13: the twelve common-year months plus the leap month 'AdarI').+monthCount :: Int+monthCount = length calendarMonths++-- | A month's 0-based position in calendar order (from 'Tishri'), independent of the numbering convention. This is+-- the internal, storage-facing ordinal (and the civil 'Enum' number).+calendarIndex :: Month (Hebrew n) -> Int+calendarIndex m = fromJust (elemIndex m calendarMonths)++-- | Inverse of 'calendarIndex', checked against the valid 0..12 range.+monthAt :: Int -> Month (Hebrew n)+monthAt i+ | i >= 0 && i < monthCount = calendarMonths !! i+ | otherwise = error "Data.HodaTime.Calendar.Hebrew: month index out of range 0..12"++-- | Calendar-order index of the leap month 'AdarI'.+adarICalIndex :: Int+adarICalIndex = 5++-- | Calendar-order index of 'Adar' (\"Adar II\" in a leap year).+adarCalIndex :: Int+adarCalIndex = 6++-- | Hebrew dates are stored directly on the universal timeline (day 0 = 1.Mar.2000 Gregorian = Wednesday), so the+-- 'Instant' bridge is the identity and the epoch weekday is that of the shared day 0.+epochDayOfWeek :: DayOfWeek (Hebrew n)+epochDayOfWeek = Wednesday++-- | The day before 1.Tishri.1: a day is \"before the calendar starts\" when it is on or before this.+invalidDayThresh :: Int+invalidDayThresh = pred (firstDayOfYear 1)++-- | Anchors the molad-based day count to the shared timeline: the universal flat day of 1.Tishri.1 (the Hebrew epoch,+-- Rata Die -1373427 = universal day -2103607) less @'elapsedDays' 1@ (which is 1). So+-- @'firstDayOfYear' = 'hebrewRefDay' + 'elapsedDays'@.+hebrewRefDay :: Int+hebrewRefDay = -2103608++-- Molad and Rosh Hashanah++-- | A year is a leap year (thirteen months) in 7 of every 19 (years 3, 6, 8, 11, 14, 17 and 19 of the Metonic cycle).+isLeapYear :: Year -> Bool+isLeapYear y = (7 * y + 1) `mod` 19 < 7++-- | Number of months in a year (12 common, 13 leap).+monthsInYear :: Year -> Int+monthsInYear y = if isLeapYear y then 13 else 12++-- | Lunar months from the epoch molad to the molad of 'Tishri' of the given year.+monthsElapsed :: Year -> Int+monthsElapsed year = 235 * cycles + 12 * inCycle + (7 * inCycle + 1) `div` 19+ where (cycles, inCycle) = (year - 1) `divMod` 19++-- | Days from the epoch molad to 1.Tishri of the given year after the four postponement rules (dechiyot): the molad+-- rules (molad zaken, and the GaTaRaD \/ BeTUTaKPaT year-length fixes) and \"lo ADU rosh\" (Rosh Hashanah may not+-- fall on Sunday, Wednesday or Friday). A part (chelek) is 1\/1080 of an hour, so a day is 25920 parts.+elapsedDays :: Year -> Int+elapsedDays year = aduAdjusted+ where+ m = monthsElapsed year+ partsElapsed = 204 + 793 * (m `mod` 1080)+ hoursElapsed = 5 + 12 * m + 793 * (m `div` 1080) + partsElapsed `div` 1080+ moladDay = 1 + 29 * m + hoursElapsed `div` 24+ moladParts = 1080 * (hoursElapsed `mod` 24) + partsElapsed `mod` 1080+ postponed+ | moladParts >= 19440 = moladDay + 1 -- molad zaken (molad at or after 18h)+ | moladDay `mod` 7 == 2 && moladParts >= 9924 && not (isLeapYear year) = moladDay + 1 -- GaTaRaD (Tue, 9h204p, common year)+ | moladDay `mod` 7 == 1 && moladParts >= 16789 && isLeapYear (year - 1) = moladDay + 1 -- BeTUTaKPaT (Mon, 15h589p, year after leap)+ | otherwise = moladDay+ aduAdjusted = if postponed `mod` 7 `elem` [0, 3, 5] then postponed + 1 else postponed++-- | Universal flat day (day 0 = 1.Mar.2000 Gregorian) of 1.Tishri of the given year (Rosh Hashanah).+firstDayOfYear :: Year -> Int+firstDayOfYear year = hebrewRefDay + elapsedDays year++-- | Length of the given year in days (353\/354\/355 common, 383\/384\/385 leap).+daysInYear :: Year -> Int+daysInYear year = firstDayOfYear (year + 1) - firstDayOfYear year++-- | In a \"complete\" (shelemah) year 'Cheshvan' has 30 days instead of 29.+isCheshvanLong :: Year -> Bool+isCheshvanLong year = daysInYear year `mod` 10 == 5++-- | In a \"deficient\" (chaserah) year 'Kislev' has 29 days instead of 30.+isKislevShort :: Year -> Bool+isKislevShort year = daysInYear year `mod` 10 == 3++-- | Length of the month at the given calendar-order index in the given year (0 for 'AdarI' in a common year, so any+-- day in it is out of range).+monthLengthByIndex :: Year -> Int -> Int+monthLengthByIndex year ci = case ci of+ 0 -> 30 -- Tishri+ 1 -> if isCheshvanLong year then 30 else 29-- Cheshvan+ 2 -> if isKislevShort year then 29 else 30-- Kislev+ 3 -> 29 -- Tevet+ 4 -> 30 -- Shevat+ 5 -> if isLeapYear year then 30 else 0 -- AdarI (leap years only)+ 6 -> 29 -- Adar (Adar II in leap years)+ 7 -> 30 -- Nisan+ 8 -> 29 -- Iyar+ 9 -> 30 -- Sivan+ 10 -> 29 -- Tammuz+ 11 -> 30 -- Av+ 12 -> 29 -- Elul+ _ -> 0++-- | Maximum day for a month in a given year (0 for 'AdarI' in a common year, so such a date is always rejected).+maxDaysInMonth :: Month (Hebrew n) -> Year -> Int+maxDaysInMonth m year = monthLengthByIndex year (calendarIndex m)++-- | Days elapsed in the year before the first of the month at the given calendar-order index.+daysBeforeMonth :: Year -> Int -> Int+daysBeforeMonth year ci = sum [monthLengthByIndex year i | i <- [0 .. ci - 1]]++-- Date <-> day count++-- | Universal flat day (day 0 = 1.Mar.2000 Gregorian) of the given year, calendar-order month index and day.+hebrewYearMonthDayToDays :: Year -> Int -> DayOfMonth -> Int+hebrewYearMonthDayToDays year ci d = firstDayOfYear year + daysBeforeMonth year ci + d - 1++-- | Decode a universal flat day to @(year, calendar-order month index, day)@.+hebrewDaysToYmd :: Int32 -> (Int32, Word8, Word8)+hebrewDaysToYmd flatDays = (fromIntegral year, fromIntegral ci, fromIntegral d)+ where+ n = fromIntegral flatDays :: Int+ year = findYear (estimate n)+ (ci, d) = findMonth 0 (n - firstDayOfYear year)+ findMonth i remaining+ | remaining < len = (i, remaining + 1) -- a 0-length AdarI in a common year is skipped here+ | otherwise = findMonth (i + 1) (remaining - len)+ where len = monthLengthByIndex year i+ -- a Hebrew year averages ~365.25 days, so dividing by 366 gives a safe under-estimate to search up from+ estimate d0 = max 1 $ (d0 - firstDayOfYear 1) `div` 366 + 1+ findYear y+ | firstDayOfYear y > n = findYear (y - 1)+ | firstDayOfYear (y + 1) <= n = findYear (y + 1)+ | otherwise = y++-- | Build the flat Hebrew date (denormalized: keeps the day count plus the decoded day\/calendar-month\/year).+hebrewFromDays :: Int32 -> Date (Hebrew n)+hebrewFromDays flatDays = HebrewDate flatDays d ci y+ where (y, ci, d) = hebrewDaysToYmd flatDays++hebrewToDays :: Date (Hebrew n) -> Int32+hebrewToDays (HebrewDate flatDays _ _ _) = flatDays++hebrewToYmd :: Date (Hebrew n) -> (Int32, Word8, Word8)+hebrewToYmd (HebrewDate _ d ci y) = (y, ci, d)++-- lenses (Hebrew-specific: the shared helpers assume a fixed month count and that the stored month index equals the+-- numbering's Enum number, neither of which holds here, so these work in numbering-independent calendar-index space)++-- | Day-of-month lens: shifts the flat day directly, so overflowing the month rolls into the next (not clamped).+hebrewDayLens :: Functor f => (DayOfMonth -> f DayOfMonth) -> Date (Hebrew n) -> f (Date (Hebrew n))+hebrewDayLens f date = rebuild <$> f (fromIntegral d)+ where+ (y, ci, d) = hebrewToYmd date+ startOfMonth = pred $ hebrewYearMonthDayToDays (fromIntegral y) (fromIntegral ci) 1+ rebuild newDay = hebrewFromDays (fromIntegral days)+ where+ raw = startOfMonth + newDay+ days = if raw > invalidDayThresh then raw else invalidDayThresh + 1++-- | Month lens. The exposed 'Int' is the month in the calendar's numbering; adding to it moves that many months in+-- calendar order (carrying the year at 'Tishri' and skipping the absent 'AdarI' in common years), clamping the day.+hebrewMonthLens :: Functor f => Int -> (Int -> f Int) -> Date (Hebrew n) -> f (Date (Hebrew n))+hebrewMonthLens start f date = rebuild <$> f current+ where+ (y, ci, d) = hebrewToYmd date+ yr = fromIntegral y+ cur = fromIntegral ci+ current = (cur - start) `mod` monthCount+ rebuild target = hebrewFromDays (fromIntegral days)+ where+ (y', ci') = addMonthsChrono yr cur (target - current)+ mdim = monthLengthByIndex (max 1 y') ci'+ d' = min (fromIntegral d) mdim+ raw = hebrewYearMonthDayToDays (max 1 y') ci' d'+ days = if raw > invalidDayThresh then raw else invalidDayThresh + 1++-- | Year lens: keeps the month and day (clamping the day, and moving 'AdarI' to 'Adar' when the target year is common).+hebrewYearLens :: Functor f => (Year -> f Year) -> Date (Hebrew n) -> f (Date (Hebrew n))+hebrewYearLens f date = rebuild <$> f (fromIntegral y)+ where+ (y, ci, d) = hebrewToYmd date+ rebuild newYear = hebrewFromDays (fromIntegral days)+ where+ y' = max 1 newYear+ ci' = if fromIntegral ci == adarICalIndex && not (isLeapYear y') then adarCalIndex else fromIntegral ci+ mdim = monthLengthByIndex y' ci'+ d' = min (fromIntegral d) mdim+ days = hebrewYearMonthDayToDays y' ci' d'++-- | Move a @(year, calendar-order month index)@ by a number of months in calendar order, carrying the year at 'Tishri'+-- and stepping over the absent 'AdarI' in common years.+addMonthsChrono :: Year -> Int -> Int -> (Year, Int)+addMonthsChrono year ci delta = go year (calIndexToPos year ci + delta)+ where+ go y p+ | p < 0 = go (y - 1) (p + monthsInYear (y - 1))+ | p >= monthsInYear y = go (y + 1) (p - monthsInYear y)+ | otherwise = (y, posToCalIndex y p)++-- | Calendar-order index to sequential position within the year (common years have no 'AdarI', so 'Adar' onward shift down).+calIndexToPos :: Year -> Int -> Int+calIndexToPos year ci+ | isLeapYear year = ci+ | ci < adarICalIndex = ci+ | otherwise = ci - 1++-- | Inverse of 'calIndexToPos'.+posToCalIndex :: Year -> Int -> Int+posToCalIndex year p+ | isLeapYear year = p+ | p < adarICalIndex = p+ | otherwise = p + 1
src/Data/HodaTime/Calendar/Internal.hs view
@@ -1,7 +1,189 @@ {-# LANGUAGE TypeFamilies #-}-+{-# LANGUAGE FlexibleContexts #-} module Data.HodaTime.Calendar.Internal (- + mkCommonDayLens+ ,mkCommonMonthLens+ ,mkYearLens+ ,mkFromNthDay+ ,mkFromWeekDate+ ,moveByDow+ ,dayOfWeekFromDays+ ,commonMonthDayOffsets+ ,borders+ ,daysPerStandardYear+ ,daysPerFourYears+ ,daysPerCentury ) where++import Data.HodaTime.CalendarDateTime.Internal (Year, DayOfMonth, DayNth, WeekNumber)+import Data.Int (Int32)+import Data.Word (Word8)+import Control.Arrow ((>>>), first)+import Control.Monad (guard)++-- Constants++daysPerStandardYear :: Num a => a+daysPerStandardYear = 365++daysPerFourYears :: Num a => a+daysPerFourYears = 1461++daysPerCentury :: Num a => a+daysPerCentury = 36524++-- helper functions+--+-- NOTE: These are representation-agnostic: each calendar passes its own @fromDays@ (build a date from a flat+-- epoch-relative day count) and @toYmd@ (decode a date to year\/month\/day) so the same lens logic works whether+-- the calendar stores a flat day count, a packed cycle, or anything else.++mkCommonDayLens :: (Functor f, Enum mon) =>+ Int+ -> (Year -> mon -> DayOfMonth -> Int)+ -> (Int32 -> d)+ -> (d -> (Int32, Word8, Word8))+ -> (DayOfMonth -> f DayOfMonth)+ -> d+ -> f d+mkCommonDayLens preStartDay yearMonthDayToDays fromDays toYmd f date = mkcd . (rest +) <$> f (fromIntegral d)+ where+ (y, m, d) = toYmd date+ rest = pred $ yearMonthDayToDays (fromIntegral y) (toEnum . fromIntegral $ m) 1+ mkcd days = fromDays days'+ where days' = fromIntegral $ if days > preStartDay then days else preStartDay + 1+{-# INLINE mkCommonDayLens #-}++mkCommonMonthLens :: (Functor f, Enum mon) =>+ Int+ -> (Int, Int, Word8)+ -> (mon -> Year -> Int)+ -> (Year -> mon -> DayOfMonth -> Int)+ -> (d -> (Int32, Word8, Word8))+ -> (Int32 -> d)+ -> (Int -> f Int)+ -> d+ -> f d+mkCommonMonthLens monthsPerYear firstDayTuple maxDaysInMonth yearMonthDayToDays toYmd fromDays f date = mkcd <$> f (fromIntegral m)+ where+ (y, m, d) = toYmd date+ mkcd months = fromDays (fromIntegral days)+ where+ (y', months') = flip divMod monthsPerYear >>> first (+ fromIntegral y) $ months+ (y'', m', d') = if (y', months', d) < firstDayTuple then firstDayTuple else (y', months', d)+ mdim = fromIntegral $ maxDaysInMonth (toEnum m') y'+ d'' = if d' > mdim then mdim else d'+ days = yearMonthDayToDays y'' (toEnum m') (fromIntegral d'')+{-# INLINE mkCommonMonthLens #-}++mkYearLens :: (Functor f, Enum mon) =>+ (Int, Word8, Word8)+ -> (mon -> Year -> Int)+ -> (Year -> mon -> DayOfMonth -> Int)+ -> (d -> (Int32, Word8, Word8))+ -> (Int32 -> d)+ -> (Int -> f Int)+ -> d+ -> f d+mkYearLens firstDayTuple maxDaysInMonth yearMonthDayToDays toYmd fromDays f date = mkcd <$> f (fromIntegral y)+ where+ (y, m, d) = toYmd date+ mkcd y' = fromDays days+ where+ (y'', m', d') = if (y', m, d) < firstDayTuple then firstDayTuple else (y', m, d)+ m'' = toEnum . fromIntegral $ m'+ mdim = fromIntegral $ maxDaysInMonth m'' y''+ d'' = if d' > mdim then mdim else d'+ days = fromIntegral $ yearMonthDayToDays y'' m'' (fromIntegral d'')+{-# INLINE mkYearLens #-}++-- | Build a date from the nth (or nth-from-last) weekday within a month (e.g. \"the third Monday\"). This is the+-- calendar-agnostic core of a per-calendar @fromNthDay@: it reads the weekday of the anchor day (the 1st, or the+-- last day of the month for a \"from last\" request) via the calendar's own day count, so it needs no per-calendar+-- weekday formula.+mkFromNthDay :: (Enum mon, Enum dow) =>+ Int -- ^ invalid-day threshold (dates on or before this are rejected)+ -> dow -- ^ epoch day of week+ -> (Year -> mon -> DayOfMonth -> Int) -- ^ yearMonthDayToDays+ -> (mon -> Year -> Int) -- ^ maxDaysInMonth+ -> (Int32 -> d) -- ^ fromDays+ -> DayNth -> dow -> mon -> Year -> Maybe d+mkFromNthDay invalidDayThresh epochDayOfWeek yearMonthDayToDays maxDaysInMonth fromDays nth dow m y = do+ guard $ d > 0 && d <= mdim+ guard $ days > invalidDayThresh+ return $ fromDays (fromIntegral days)+ where+ nth' = fromEnum nth - 4+ mdim = maxDaysInMonth m y+ target = fromEnum dow+ -- forward (nth' >= 0) counts from the first of the month; \"from last\" (nth' < 0) counts back from the last day.+ -- Using the backward distance for the from-last case is what makes \"the last Friday\" land on the final Friday+ -- even when the month ends exactly on that weekday (where a naive forward offset would be a week short).+ d | nth' < 0 = mdim - backwardDist + 7 * (nth' + 1)+ | otherwise = 1 + forwardDist + 7 * nth'+ forwardDist = (target - dowOf 1) `mod` 7+ backwardDist = (dowOf mdim - target) `mod` 7+ dowOf dom = dayOfWeekFromDays epochDayOfWeek (yearMonthDayToDays y m dom)+ days = yearMonthDayToDays y m d+{-# INLINE mkFromNthDay #-}++-- | Build a date from a week-numbering rule. @minWeekDays@ and @weekStart@ define the rule (e.g. @1 Sunday@ for the+-- simple rule where week 1 is the first week with any day in the new year, or @4 Monday@ for ISO-8601). This is the+-- calendar-agnostic core of a per-calendar @fromWeekDate@.+mkFromWeekDate :: (Enum mon, Enum dow) =>+ Int -- ^ invalid-day threshold+ -> dow -- ^ epoch day of week+ -> (Year -> mon -> DayOfMonth -> Int) -- ^ yearMonthDayToDays+ -> (Int32 -> d) -- ^ fromDays+ -> Int -- ^ minimum days of the new year that fall in week 1+ -> dow -- ^ first day of the week+ -> WeekNumber -> dow -> Year -> Maybe d+mkFromWeekDate invalidDayThresh epochDayOfWeek yearMonthDayToDays fromDays minWeekDays wkStartDoW weekNum dow y = do+ guard $ days > invalidDayThresh+ return $ fromDays (fromIntegral days)+ where+ soyDays = yearMonthDayToDays y (toEnum 0) minWeekDays+ soyDoW = dayOfWeekFromDays epochDayOfWeek soyDays+ startDoWDistance = soyDoW - fromEnum wkStartDoW+ dowDistance = fromEnum dow - fromEnum wkStartDoW+ dowDistance' = if dowDistance < 0 then dowDistance + 7 else dowDistance+ startDays = soyDays - startDoWDistance+ days = startDays + pred weekNum * 7 + dowDistance'+{-# INLINE mkFromWeekDate #-}++moveByDow :: Enum dow =>+ (Int32 -> d)+ -> dow+ -> Int+ -> dow+ -> (Int -> Int -> Int)+ -> (Int -> Int -> Int)+ -> (Int -> Int -> Bool)+ -> Int+ -> d+moveByDow fromDays epochDayOfWeek n dow distanceF adjust cmp days = fromDays days'+ where+ n' = if targetDow `cmp` currentDoW then n-1 else n+ currentDoW = dayOfWeekFromDays epochDayOfWeek days+ targetDow = fromIntegral . fromEnum $ dow+ distance = distanceF targetDow currentDoW+ days' = fromIntegral $ fromIntegral days `adjust` (7 * n') `adjust` distance++dayOfWeekFromDays :: Enum dow => dow -> Int -> Int+dayOfWeekFromDays epochDayOfWeek = normalize . (fromEnum epochDayOfWeek +) . flip mod 7+ where+ normalize n = if n >= 7 then n - 7 else n++commonMonthDayOffsets :: Num a => [a]+commonMonthDayOffsets = 0 : rest+ where+ rest = zipWith (+) daysPerMonth (0:rest)+ daysPerMonth = [31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31]++-- | The issue is that 4 * daysPerCentury will be one less than daysPerCycle. The reason for this is that the Gregorian calendar adds one more day per 400 year cycle+-- and this day is missing from adding up 4 individual centuries. We have the same issue again with 4 years (i.e. 365*4 is daysPerFourYears - 1)+-- so we use this function to check if this has occurred so we can add the missing day back in.+borders :: (Num a, Eq a) => a -> a -> Bool+borders c x = x == c - 1
src/Data/HodaTime/Calendar/Islamic.hs view
@@ -1,16 +1,302 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.Calendar.Islamic+-- Copyright : (C) 2017 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- This is the module for 'CalendarDate' and 'CalendarDateTime' in the 'Islamic' (Hijri) calendar, a purely lunar calendar of twelve months. The odd-numbered months ('Muharram', 'RabiAlAwwal', … ) have+-- 30 days and the even-numbered months ('Safar', 'RabiAlThani', … ) have 29, except that the final month ('DhulHijjah') gains a thirtieth day in a leap year. A common year is therefore 354 days and a+-- leap year 355 — roughly eleven days shorter than a solar year, so Islamic dates drift steadily backwards through the seasons. Year 1 begins on 18.Jul.622 CE (proleptic Gregorian), the year of the+-- Hijra; dates share the same absolute timeline as every other calendar.+--+-- == Which Islamic calendar this is, and the choices we made+--+-- There is no single \"Islamic calendar\": the religiously authoritative one is /observational/ (each month begins on the naked-eye sighting of the new crescent), which is inherently non-algorithmic and+-- varies by location, so it cannot be computed. What software can compute is either the /tabular/ (arithmetic) calendar or a tabulated astronomical calendar such as Umm al-Qura. This module implements+-- the __tabular arithmetic__ calendar. A tabular calendar leaves two parameters open — the /leap-year pattern/ and the /epoch/ — and we treat them differently:+--+-- * __Leap-year pattern: selectable, defaulting to \"Base16\" (type II).__ A leap pattern says which 11 of every 30 years carry the extra day. Four patterns are in common use, and the calendar is+-- parameterised over them at the /type level/ (see below), so a date always records which pattern built it and the type system refuses to mix incompatible ones. The default, __Base16__ — leap years+-- 2, 5, 7, 10, 13, 16, 18, 21, 24, 26 and 29 of each cycle — is the pattern used by the .NET BCL @HijriCalendar@ and NodaTime's @IslamicBcl@, so it is the most interoperable choice and the one we+-- cross-check against.+--+-- * __Epoch: fixed to astronomical (\"Thursday\") — 18.Jul.622 CE (proleptic Gregorian), Julian day 1948439.__ The alternative \"civil\" (\"Friday\") epoch is exactly one day later. Unlike the leap+-- pattern, the epoch does not change the calendar's internal structure (month lengths, leap years, arithmetic); it only shifts how Islamic dates line up with the absolute timeline — i.e. their+-- 'Data.HodaTime.Instant.Instant', their Gregorian correspondence and their day-of-week — by that one day. Because it is a one-day alignment convention rather than a structurally different calendar,+-- we fix it (to the astronomical epoch, matching the .NET BCL and NodaTime) rather than expose it. Were it ever wanted it would become a second type parameter in exactly the same way as the leap+-- pattern, a non-breaking change (today's @Islamic l@ would become a synonym for @Islamic l Astronomical@).+--+-- Being purely arithmetic, the calendar is exact by definition (there is no astronomical approximation, unlike the astronomical Persian calendar) and total for every year, so — like the Coptic calendar —+-- it is only floored at year 1 (the Hijra) and has no upper bound. Note that the tabular calendar can differ from an actual crescent sighting, and from the Umm al-Qura calendar, by a day or two; if you+-- need to match observation you must use sighting data, which is outside the scope of an arithmetic calendar.+--+-- == Selecting a leap pattern+--+-- The calendar type carries the leap pattern as a type parameter of kind 'LeapPattern': @'Islamic' l@. This is why ordinary, non-configurable calendars such as 'Data.HodaTime.Calendar.Gregorian.Gregorian'+-- are unaffected — only a calendar that actually has a choice to record gains a parameter, and it is always fully applied (e.g. @'CalendarDateTime' ('Islamic' 'Base15')@). Because the parameter is phantom,+-- the month and weekday constructors ('Muharram', 'Sunday', … ) are shared across every variant, but two dates built with different patterns have different types and cannot be combined or compared.+--+-- For convenience each pattern has a type synonym — 'IslamicBcl' (the Base16 default), 'IslamicBase15', 'IslamicIndian' and 'IslamicHabashAlHasib' — and the constructors come in two forms:+--+-- * 'calendarDate', 'fromNthDay' and 'fromWeekDate' build the default 'IslamicBcl' calendar and need no annotation.+--+-- * @calendarDate'@, @fromNthDay'@ and @fromWeekDate'@ are polymorphic in the pattern; choose one with a type annotation or @TypeApplications@, e.g. @calendarDate' \@Base15 d m y@ or+-- @calendarDate' d m y :: Maybe ('CalendarDate' 'IslamicBase15')@.+---------------------------------------------------------------------------- module Data.HodaTime.Calendar.Islamic (+ -- * Constructors (default 'IslamicBcl' calendar)+ calendarDate+ ,fromNthDay+ ,fromWeekDate+ -- * Constructors (choose the leap pattern)+ ,calendarDate'+ ,fromNthDay'+ ,fromWeekDate'+ -- * Types+ ,Month(..)+ ,DayOfWeek(..)+ ,Islamic+ ,LeapPattern(..)+ ,KnownLeap+ -- * Named calendars (leap-pattern type synonyms)+ ,IslamicBcl+ ,IslamicBase15+ ,IslamicBase16+ ,IslamicIndian+ ,IslamicHabashAlHasib ) where -data IslamicLeapYearPattern =- ILYPBase15- | ILYPBase16- | ILYPIndian- | ILYPHabashAlHasib- deriving (Eq, Show)- -data IslamicEpoch =- IslamicAstronomical- | IslamicCivil- deriving (Eq, Show)+import Data.HodaTime.CalendarDateTime.Internal (IsCalendar(..), IsCalendarDateTime(..), CalendarDate, DayNth, DayOfMonth, Year, WeekNumber, CalendarDateTime(..), LocalTime(..), Date)+import Control.DeepSeq (NFData(..))+import Data.Hashable (Hashable(..))+import Data.HodaTime.Instant.Internal (Instant(..))+import Data.HodaTime.Calendar.Internal (mkCommonDayLens, mkCommonMonthLens, mkYearLens, mkFromNthDay, mkFromWeekDate, moveByDow, dayOfWeekFromDays)+import Data.Bits ((.&.), shiftL, testBit, popCount)+import Data.Int (Int32)+import Data.Word (Word8)+import Control.Monad (guard)++-- constants++monthsPerYear :: Int+monthsPerYear = 12++daysPerNonLeapYear :: Int+daysPerNonLeapYear = 354++daysPerLeapYear :: Int+daysPerLeapYear = 355++-- | Days in one 30-year leap cycle: 19 common years of 354 days plus 11 leap years of 355.+daysPerCycle :: Int+daysPerCycle = 19 * daysPerNonLeapYear + 11 * daysPerLeapYear -- 10631++-- | The four tabular leap-year patterns in common use, used as the (kind-'LeapPattern') type parameter of 'Islamic'.+-- Each names which 11 of the 30 cycle years carry the extra day; 'Base16' is the .NET BCL \/ NodaTime default (see+-- the module header).+data LeapPattern = Base15 | Base16 | Indian | HabashAlHasib++-- | Reflects a 'LeapPattern' type down to its leap-year bit set: bit @n@ is set when year @n@ of the 30-year cycle+-- (0-based, so @year \`mod\` 30@) is a leap year. Use @TypeApplications@ to read it, e.g. @'leapPatternBits' \@Base16@.+class KnownLeap (l :: LeapPattern) where+ leapPatternBits :: Int++instance KnownLeap 'Base15 where leapPatternBits = 623158436 -- leap years 2,5,7,10,13,15,18,21,24,26,29+instance KnownLeap 'Base16 where leapPatternBits = 623191204 -- leap years 2,5,7,10,13,16,18,21,24,26,29 (.NET BCL / NodaTime)+instance KnownLeap 'Indian where leapPatternBits = 690562340 -- leap years 2,5,8,10,13,16,19,21,24,27,29+instance KnownLeap 'HabashAlHasib where leapPatternBits = 153692453 -- leap years 2,5,8,11,13,16,19,21,24,27,30++-- | Days elapsed before each 0-based month, ignoring the leap day (which only affects the final month's own length).+-- Odd-numbered (1-based) months have 30 days and even-numbered months 29.+islamicMonthDayOffsets :: [Int]+islamicMonthDayOffsets = [0, 30, 59, 89, 118, 148, 177, 207, 236, 266, 295, 325]++-- | Universal flat day (day 0 = 1.Mar.2000 Gregorian) of 1.Muharram.1 — the astronomical (\"Thursday\") epoch, Julian+-- day 1948439 = 18.Jul.622 CE (proleptic Gregorian). Islamic dates are stored directly on the universal timeline, so+-- the 'Instant' bridge is the identity and this constant appears only inside the day\/date conversions.+islamicEpoch :: Int+islamicEpoch = -503166++firstIslDayTuple :: (Integral a, Integral b, Integral c) => (a, b, c)+firstIslDayTuple = (1, 0, 1) -- NOTE: 1.Muharram.1++-- | 1.Muharram.1 sits exactly on the epoch (year 1 has no preceding days and Muharram is the first month), so a day is+-- \"before the calendar starts\" when it is earlier than the epoch. This threshold is independent of the leap pattern.+invalidDayThresh :: Integral a => a+invalidDayThresh = fromIntegral (pred islamicEpoch)++-- | Islamic dates are stored directly on the universal timeline (day 0 = 1.Mar.2000 Gregorian = Wednesday), so the+-- 'Instant' bridge is the identity and the epoch weekday is that of the shared day 0. It is shared by every leap+-- pattern (the parameter @l@ is phantom).+epochDayOfWeek :: DayOfWeek (Islamic l)+epochDayOfWeek = Wednesday++-- types++-- | The Islamic (Hijri) calendar, parameterised by its leap-year pattern (see 'LeapPattern' and the module header).+data Islamic (l :: LeapPattern)++-- | The Base15 tabular calendar.+type IslamicBase15 = Islamic 'Base15+-- | The Base16 tabular calendar (same as 'IslamicBcl').+type IslamicBase16 = Islamic 'Base16+-- | The Indian tabular calendar.+type IslamicIndian = Islamic 'Indian+-- | The Habash al-Hasib tabular calendar.+type IslamicHabashAlHasib = Islamic 'HabashAlHasib+-- | The default Islamic calendar: the Base16 leap pattern, matching the .NET BCL @HijriCalendar@ and NodaTime's @IslamicBcl@.+type IslamicBcl = Islamic 'Base16++instance KnownLeap l => IsCalendar (Islamic l) where+ data Date (Islamic l) = IslamicDate {-# UNPACK #-} !Int32 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Int32+ deriving (Eq, Ord)++ data DayOfWeek (Islamic l) = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++ data Month (Islamic l) = Muharram | Safar | RabiAlAwwal | RabiAlThani | JumadaAlAwwal | JumadaAlThani | Rajab | Shaban | Ramadan | Shawwal | DhulQadah | DhulHijjah+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++ fromDays = islamicFromDays (leapPatternBits @l)+ toDays = islamicToDays+ toYmd = islamicToYmd+ calendarName _ = "Islamic"++ day' = let b = leapPatternBits @l in mkCommonDayLens invalidDayThresh (yearMonthDayToDays b) (islamicFromDays b) islamicToYmd+ {-# INLINE day' #-}++ month' (IslamicDate _ _ m _) = toEnum . fromIntegral $ m++ monthl' = let b = leapPatternBits @l in mkCommonMonthLens monthsPerYear firstIslDayTuple (maxDaysInMonth b) (yearMonthDayToDays b) islamicToYmd (islamicFromDays b)+ {-# INLINE monthl' #-}++ year' = let b = leapPatternBits @l in mkYearLens firstIslDayTuple (maxDaysInMonth b) (yearMonthDayToDays b) islamicToYmd (islamicFromDays b)+ {-# INLINE year' #-}++ dayOfWeek' (IslamicDate days _ _ _) = toEnum . dayOfWeekFromDays epochDayOfWeek . fromIntegral $ days++ next' n dow (IslamicDate days _ _ _) = moveByDow (islamicFromDays (leapPatternBits @l)) epochDayOfWeek n dow (-) (+) (>) (fromIntegral days)++ previous' n dow (IslamicDate days _ _ _) = moveByDow (islamicFromDays (leapPatternBits @l)) epochDayOfWeek n dow subtract (-) (<) (fromIntegral days) -- NOTE: subtract is (-) with the arguments flipped++instance NFData (Date (Islamic l)) where+ rnf (IslamicDate days d m y) = rnf days `seq` rnf d `seq` rnf m `seq` rnf y++instance Hashable (Date (Islamic l)) where+ hashWithSalt s (IslamicDate days d m y) = s `hashWithSalt` days `hashWithSalt` d `hashWithSalt` m `hashWithSalt` y++instance NFData (Month (Islamic l)) where+ rnf m = m `seq` ()++instance Hashable (Month (Islamic l)) where+ hashWithSalt s = hashWithSalt s . fromEnum++instance NFData (DayOfWeek (Islamic l)) where+ rnf d = d `seq` ()++instance Hashable (DayOfWeek (Islamic l)) where+ hashWithSalt s = hashWithSalt s . fromEnum++instance KnownLeap l => IsCalendarDateTime (Islamic l) where+ fromAdjustedInstant (Instant days secs nsecs) = CalendarDateTime (islamicFromDays (leapPatternBits @l) days) (LocalTime secs nsecs)+ toUnadjustedInstant (CalendarDateTime isd (LocalTime secs nsecs)) = Instant (islamicToDays isd) secs nsecs++-- | Build the flat Islamic date (denormalized: keeps the day count plus the decoded day\/month\/year).+islamicFromDays :: Int -> Int32 -> Date (Islamic l)+islamicFromDays bits days = IslamicDate days d m y+ where (y, m, d) = daysToYearMonthDay bits days++islamicToDays :: Date (Islamic l) -> Int32+islamicToDays (IslamicDate days _ _ _) = days++islamicToYmd :: Date (Islamic l) -> (Int32, Word8, Word8)+islamicToYmd (IslamicDate _ d m y) = (y, m, d)++-- Constructors++-- | Smart constructor for the default 'IslamicBcl' calendar date. Returns 'Nothing' if the day is out of range for the+-- month or the year is before the epoch (year 1). Use @calendarDate'@ to pick a different leap pattern.+calendarDate :: DayOfMonth -> Month IslamicBcl -> Year -> Maybe (CalendarDate IslamicBcl)+calendarDate = calendarDate'++-- | Smart constructor for an 'Islamic' calendar date in any leap pattern (chosen by the result type). Returns 'Nothing'+-- if the day is out of range for the month or the year is before the epoch (year 1).+calendarDate' :: forall l. KnownLeap l => DayOfMonth -> Month (Islamic l) -> Year -> Maybe (CalendarDate (Islamic l))+calendarDate' d m y = do+ guard $ d > 0 && d <= maxDaysInMonth bits m y+ let days = fromIntegral $ yearMonthDayToDays bits y m d+ guard $ days > invalidDayThresh+ return $ islamicFromDays bits days+ where bits = leapPatternBits @l++-- | Smart constructor for the default 'IslamicBcl' calendar date given as a day relative to a month (e.g. the third Monday of the month). Returns 'Nothing' if the resulting date is invalid.+fromNthDay :: DayNth -> DayOfWeek IslamicBcl -> Month IslamicBcl -> Year -> Maybe (CalendarDate IslamicBcl)+fromNthDay = fromNthDay'++-- | As 'fromNthDay', but in any leap pattern (chosen by the result type).+fromNthDay' :: forall l. KnownLeap l => DayNth -> DayOfWeek (Islamic l) -> Month (Islamic l) -> Year -> Maybe (CalendarDate (Islamic l))+fromNthDay' = mkFromNthDay invalidDayThresh epochDayOfWeek (yearMonthDayToDays bits) (maxDaysInMonth bits) (islamicFromDays bits)+ where bits = leapPatternBits @l++-- | Smart constructor for the default 'IslamicBcl' calendar date given as a week date. Note that this method assumes weeks start on Saturday (as in the Islamic calendar) and the first week of the year is+-- the one which has at least one day in the new year.+fromWeekDate :: WeekNumber -> DayOfWeek IslamicBcl -> Year -> Maybe (CalendarDate IslamicBcl)+fromWeekDate = fromWeekDate'++-- | As 'fromWeekDate', but in any leap pattern (chosen by the result type).+fromWeekDate' :: forall l. KnownLeap l => WeekNumber -> DayOfWeek (Islamic l) -> Year -> Maybe (CalendarDate (Islamic l))+fromWeekDate' = mkFromWeekDate invalidDayThresh epochDayOfWeek (yearMonthDayToDays bits) (islamicFromDays bits) 1 Saturday+ where bits = leapPatternBits @l++-- helper functions++-- | A year is a leap year when the bit at @year \`mod\` 30@ of the given leap-pattern bit set is set.+isLeapYear :: Int -> Year -> Bool+isLeapYear bits y = testBit bits (fromIntegral (y `mod` 30))++maxDaysInMonth :: Int -> Month (Islamic l) -> Year -> Int+maxDaysInMonth bits DhulHijjah y+ | isLeapYear bits y = 30+ | otherwise = 29+maxDaysInMonth _ m _+ | even (fromEnum m) = 30 -- odd (1-based) months: Muharram, RabiAlAwwal, …+ | otherwise = 29 -- even (1-based) months: Safar, RabiAlThani, …++-- | Number of leap years among the first @r@ years of a cycle (cycle positions 1 .. @r@, for @r@ in 0 .. 29).+leapsInFirst :: Int -> Int -> Int+leapsInFirst bits r = popCount (bits .&. ((1 `shiftL` (r + 1)) - 2))++-- | Universal flat day (day 0 = 1.Mar.2000 Gregorian) of the given Islamic date, for the given leap-pattern bit set.+yearMonthDayToDays :: Int -> Year -> Month (Islamic l) -> DayOfMonth -> Int+yearMonthDayToDays bits y m d = islamicEpoch + daysBeforeYear + islamicMonthDayOffsets !! fromEnum m + d - 1+ where+ (c, r) = (fromIntegral y - 1) `divMod` 30+ daysBeforeYear = c * daysPerCycle + r * daysPerNonLeapYear + leapsInFirst bits r++daysToYearMonthDay :: Int -> Int32 -> (Int32, Word8, Word8)+daysToYearMonthDay bits flatDays = (fromIntegral y, fromIntegral m, fromIntegral d)+ where+ n = fromIntegral flatDays - islamicEpoch -- days since 1.Muharram.1 (>= 0 for valid dates)+ (cycles, remCycle) = n `divMod` daysPerCycle -- 10631-day, 30-year cycle+ (yearInCycle, dayOfYear) = findYear 0 0+ y = cycles * 30 + yearInCycle + 1+ (m, d)+ | dayOfYear == daysPerNonLeapYear = (11, 30) -- 355th day: DhulHijjah 30 (leap years only)+ | otherwise = (dayOfYear * 2 `div` 59, (dayOfYear `mod` 59) `mod` 30 + 1)+ -- Walk the (at most 30) years of the cycle, subtracting each year's length until the remaining days fall inside one.+ findYear i acc+ | acc + diy > remCycle = (i, remCycle - acc)+ | otherwise = findYear (i + 1) (acc + diy)+ where diy = if testBit bits ((i + 1) `mod` 30) then daysPerLeapYear else daysPerNonLeapYear
src/Data/HodaTime/Calendar/Iso.hs view
@@ -1,3 +1,17 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.Calendar.Iso+-- Copyright : (C) 2017 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- This is the module for 'CalendarDate' and 'CalendarDateTime' in the ISO 8601 calendar. For every date the ISO calendar is identical to 'Data.HodaTime.Calendar.Gregorian' \- the same months, the+-- same leap year rule and the same 15 October 1582 cut-off \- and it reuses the Gregorian types directly. The two differ only in how week dates are numbered: ISO weeks start on Monday and week 1 is+-- the first week containing at least four days of the new year (equivalently, the week holding that year's first Thursday). Use this module's 'fromWeekDate' for ISO-8601 week numbering; the Gregorian+-- module provides the alternative Sunday-based, at-least-one-day rule.+---------------------------------------------------------------------------- module Data.HodaTime.Calendar.Iso ( fromWeekDate@@ -6,9 +20,9 @@ import Data.HodaTime.Calendar.Gregorian.Internal hiding (fromWeekDate) import qualified Data.HodaTime.Calendar.Gregorian.Internal as GI-import Data.HodaTime.CalendarDateTime.Internal (CalendarDate(..), Year, WeekNumber)+import Data.HodaTime.CalendarDateTime.Internal (CalendarDate, Year, WeekNumber) --- | Smart constuctor for ISO calendar date based day within year week. Note that this method assumes weeks start on Monday and the first week of the year is the one+-- | Smart constructor for an ISO 8601 week date. Note that this method assumes weeks start on Monday and the first week of the year is the one -- which has at least four days in the new year. See the Gregorian module for alternative behavior fromWeekDate :: WeekNumber -> DayOfWeek Gregorian -> Year -> Maybe (CalendarDate Gregorian) fromWeekDate = GI.fromWeekDate 4 Monday
+ src/Data/HodaTime/Calendar/Julian.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.Calendar.Julian+-- Copyright : (C) 2017 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- This is the module for 'CalendarDate' and 'CalendarDateTime' in the 'Julian' calendar. The Julian calendar has a simple leap year rule \- every fourth year is a leap year, with none of the century+-- exceptions that 'Data.HodaTime.Calendar.Gregorian' later added to keep the calendar aligned to the solar year. Years use astronomical numbering, so year 1 is AD 1, year 0 is 1 BC, year -1 is 2 BC+-- and so on; dates run from the calendar's introduction on 1.January.45 BC (year -44) onward, with no upper bound. Dates share the same absolute timeline as every other calendar, so in the modern era+-- a Julian date reads 13 days behind the same instant's Gregorian date. The Julian calendar is not merely historical \- the Eastern Orthodox churches still use it liturgically, so it stays useful for+-- both past dates and current and future feast-day calculations.+--+-- == Proleptic every-fourth-year rule+--+-- This implementation applies the clean every-fourth-year rule uniformly from 45 BC onward. It deliberately does /not/ reproduce the calendar's messy early history, in which the priests who+-- administered it inserted a leap day every three years by mistake (the "triennial error") until Augustus suspended leap years to realign it, the regular rule only settling in by around AD 8. We omit+-- that for two reasons:+--+-- * The exact sequence of long years during 45 BC \- AD 7 is genuinely disputed: Scaliger, Ideler and Bennett each reconstruct it differently, so an "accurate" version would just bake one contested+-- interpretation in as fact.+--+-- * By long-standing convention historians and astronomers already cite ancient dates in the /proleptic/ Julian calendar (the clean rule), precisely because the real sequence is uncertain. For example+-- "15.March.44 BC" for Caesar's assassination is a proleptic Julian date; modelling the errors would make this library disagree with the way such dates are normally written.+----------------------------------------------------------------------------+module Data.HodaTime.Calendar.Julian+(+ -- * Constructors+ calendarDate+ ,fromNthDay+ ,fromWeekDate+ -- * Types+ ,Month(..)+ ,DayOfWeek(..)+ ,Julian+)+where++import Data.HodaTime.CalendarDateTime.Internal (IsCalendar(..), IsCalendarDateTime(..), CalendarDate, DayNth, DayOfMonth, Year, WeekNumber, CalendarDateTime(..), LocalTime(..), Date)+import Control.DeepSeq (NFData(..))+import Data.Hashable (Hashable(..))+import Data.HodaTime.Instant.Internal (Instant(..))+import Data.HodaTime.Calendar.Internal (mkCommonDayLens, mkCommonMonthLens, mkYearLens, mkFromNthDay, mkFromWeekDate, moveByDow, dayOfWeekFromDays, commonMonthDayOffsets, borders, daysPerStandardYear, daysPerFourYears)+import Data.Int (Int32)+import Data.Word (Word8)+import Control.Arrow ((>>>), (***), (&&&))+import Control.Monad (guard)+import Data.Maybe (fromJust)+import Data.List (findIndex)++-- constants++-- | Julian dates are valid from the calendar's introduction, 1.January.45 BC (astronomical year -44), onward; earlier+-- dates are rejected \- the calendar did not exist and this implementation does not extend it backwards. There is no+-- upper bound beyond the 'Int32' day representation. This tuple is also the floor the shared lens\/constructor+-- helpers clamp to.+firstJulDayTuple :: (Integral a, Integral b, Integral c) => (a, b, c)+firstJulDayTuple = (-44, 0, 1) -- NOTE: 1.Jan.45 BC++invalidDayThresh :: Integral a => a+invalidDayThresh = fromIntegral $ pred day0+ where+ (y, m, d) = firstJulDayTuple :: (Year, Int, DayOfMonth)+ day0 = yearMonthDayToDays y (toEnum m) d++epochDayOfWeek :: DayOfWeek Julian+epochDayOfWeek = Tuesday++-- | Julian works in its own frame: internal flat day 0 is 1.Mar.2000 in the Julian calendar. Only the 'Instant'+-- bridge crosses to the universal timeline (day 0 = 1.Mar.2000 Gregorian), where Julian's epoch sits 13 days later+-- (the Julian\/Gregorian divergence), so 'toUnadjustedInstant' adds this offset and 'fromAdjustedInstant' subtracts+-- it. Because it is the gap between two fixed absolute days, the offset is constant for all of time.+julianEpochOffset :: Num a => a+julianEpochOffset = 13++-- In case we ever decide to generate a 28 year table to store cycles+-- daysPerSolarCycle :: Num a => a+-- daysPerSolarCycle = 10227 -- NOTE: 28 Julian years = 10227 days = 1461 * 7 weeks exactly (dates and weekdays repeat)++-- types+ +data Julian+ +instance IsCalendar Julian where+ data Date Julian = JulianDate {-# UNPACK #-} !Int32 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Int32+ deriving (Eq, Ord)++ data DayOfWeek Julian = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++ data Month Julian = January | February | March | April | May | June | July | August | September | October | November | December+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++ fromDays = julianFromDays+ toDays = julianToDays+ toYmd = julianToYmd+ calendarName _ = "Julian"++ day' = mkCommonDayLens invalidDayThresh yearMonthDayToDays julianFromDays julianToYmd+ {-# INLINE day' #-}++ month' (JulianDate _ _ m _) = toEnum . fromIntegral $ m++ monthl' = mkCommonMonthLens 12 firstJulDayTuple maxDaysInMonth yearMonthDayToDays julianToYmd julianFromDays+ {-# INLINE monthl' #-}++ year' = mkYearLens firstJulDayTuple maxDaysInMonth yearMonthDayToDays julianToYmd julianFromDays+ {-# INLINE year' #-}++ dayOfWeek' (JulianDate days _ _ _) = toEnum . dayOfWeekFromDays epochDayOfWeek . fromIntegral $ days++ next' n dow (JulianDate days _ _ _) = moveByDow julianFromDays epochDayOfWeek n dow (-) (+) (>) (fromIntegral days)++ previous' n dow (JulianDate days _ _ _) = moveByDow julianFromDays epochDayOfWeek n dow subtract (-) (<) (fromIntegral days) -- NOTE: subtract is (-) with the arguments flipped++instance NFData (Date Julian) where+ rnf (JulianDate days d m y) = rnf days `seq` rnf d `seq` rnf m `seq` rnf y++instance Hashable (Date Julian) where+ hashWithSalt s (JulianDate days d m y) = s `hashWithSalt` days `hashWithSalt` d `hashWithSalt` m `hashWithSalt` y++instance NFData (Month Julian) where+ rnf m = m `seq` ()++instance Hashable (Month Julian) where+ hashWithSalt s = hashWithSalt s . fromEnum++instance NFData (DayOfWeek Julian) where+ rnf d = d `seq` ()++instance Hashable (DayOfWeek Julian) where+ hashWithSalt s = hashWithSalt s . fromEnum++instance IsCalendarDateTime Julian where+ fromAdjustedInstant (Instant days secs nsecs) = CalendarDateTime (julianFromDays (days - julianEpochOffset)) (LocalTime secs nsecs)+ toUnadjustedInstant (CalendarDateTime jd (LocalTime secs nsecs)) = Instant (julianToDays jd + julianEpochOffset) secs nsecs++-- | Build the flat Julian date (denormalized: keeps the day count plus the decoded day\/month\/year).+julianFromDays :: Int32 -> Date Julian+julianFromDays days = JulianDate days d m y+ where (y, m, d) = daysToYearMonthDay days++julianToDays :: Date Julian -> Int32+julianToDays (JulianDate days _ _ _) = days++julianToYmd :: Date Julian -> (Int32, Word8, Word8)+julianToYmd (JulianDate _ d m y) = (y, m, d)++-- Constructors++-- | Smart constructor for a 'Julian' calendar date.+calendarDate :: DayOfMonth -> Month Julian -> Year -> Maybe (CalendarDate Julian)+calendarDate d m y = do+ guard $ d > 0 && d <= maxDaysInMonth m y+ let days = fromIntegral $ yearMonthDayToDays y m d+ guard $ days > invalidDayThresh+ return $ julianFromDays days++-- | Smart constructor for a 'Julian' calendar date given as a day relative to a month (e.g. the third Monday of the month). Returns 'Nothing' if the resulting date is invalid.+fromNthDay :: DayNth -> DayOfWeek Julian -> Month Julian -> Year -> Maybe (CalendarDate Julian)+fromNthDay = mkFromNthDay invalidDayThresh epochDayOfWeek yearMonthDayToDays maxDaysInMonth julianFromDays++-- | Smart constructor for a 'Julian' calendar date given as a week date. Note that this method assumes weeks start on Sunday and the first week of the year is the one+-- which has at least one day in the new year.+fromWeekDate :: WeekNumber -> DayOfWeek Julian -> Year -> Maybe (CalendarDate Julian)+fromWeekDate = mkFromWeekDate invalidDayThresh epochDayOfWeek yearMonthDayToDays julianFromDays 1 Sunday++-- helper functions++maxDaysInMonth :: Month Julian -> Year -> Int+maxDaysInMonth February y+ | isLeap = 29+ | otherwise = 28+ where+ isLeap = 0 == y `mod` 4+maxDaysInMonth m _+ | m == April || m == June || m == September || m == November = 30+ | otherwise = 31++yearMonthDayToDays :: Year -> Month Julian -> DayOfMonth -> Int+yearMonthDayToDays y m d = days+ where+ m' = if m > February then fromEnum m - 2 else fromEnum m + 10+ years = if m < March then y - 2001 else y - 2000+ yearDays = years * daysPerStandardYear + years `div` 4+ days = yearDays + commonMonthDayOffsets !! m' + d - 1++daysToYearMonthDay :: Int32 -> (Int32, Word8, Word8)+daysToYearMonthDay days = (fromIntegral y, fromIntegral m'', fromIntegral d')+ where+ (fourYears, (remaining, isLeapDay)) = flip divMod daysPerFourYears >>> (* 4) *** id &&& borders daysPerFourYears $ days+ (oneYears, yearDays) = remaining `divMod` daysPerStandardYear+ -- NOTE: the sentinel 'daysPerStandardYear' lets February (yearDays >= the last real offset) be found; without it+ -- 'findIndex' returns Nothing and 'fromJust' crashes for any late-February date.+ m = pred . fromJust . findIndex (\mo -> yearDays < mo) $ commonMonthDayOffsets ++ [daysPerStandardYear]+ (m', startDate) = if m >= 10 then (m - 10, 2001) else (m + 2, 2000)+ d = yearDays - commonMonthDayOffsets !! m + 1+ (m'', d') = if isLeapDay then (1, 29) else (m', d)+ y = startDate + fourYears + oneYears
src/Data/HodaTime/Calendar/Persian.hs view
@@ -1,4 +1,207 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.Calendar.Persian+-- Copyright : (C) 2017 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- This is the module for 'CalendarDate' and 'CalendarDateTime' in the 'Persian' (Solar Hijri) calendar, the official calendar of Iran and Afghanistan. It is a solar calendar whose year begins at the+-- vernal equinox (Nowruz, around 20\/21 March): the first six months ('Farvardin' through 'Shahrivar') have 31 days, the next five ('Mehr' through 'Bahman') have 30, and the final month ('Esfand') has+-- 29, or 30 in a leap year. Year 1 begins on 22.Mar.622 CE (proleptic Gregorian), the year of the Hijra; dates share the same absolute timeline as every other calendar.+--+-- == Leap years: the astronomical calendar+--+-- This is the /astronomical/ Solar Hijri calendar — the official civil calendar of Iran (equivalent to the .NET @PersianCalendar@ from 4.6 onwards and NodaTime's @PersianAstronomical@). Rather than an+-- arithmetic cycle, a year is a leap year exactly when the astronomical rule places the following Nowruz 366 days later. Nowruz is the day on which the March equinox occurs if the equinox is before true+-- noon at the reference meridian (52.5°E, Iran Standard Time), otherwise the next day. The equinox and leap years are computed in "Data.HodaTime.Calendar.Persian.Astronomical"; the table is built lazily,+-- so programs that don't use the Persian calendar pay nothing for it.+--+-- == Supported range and why it is capped at 1500+--+-- The calendar is vouched for over Persian years 1 .. 1500 (≈ 622 .. 2121 CE); 'calendarDate' rejects years outside that range. This is a deliberately narrower window than NodaTime's+-- @PersianAstronomical@, which spans years 1 .. 9377 (≈ 622 .. 9999 CE). The difference is not an oversight but a consequence of /how/ each library determines Nowruz:+--+-- * NodaTime embeds a fixed lookup table of leap-year bits that was generated once from the .NET 4.6 BCL @PersianCalendar@. Every year up to 9377 therefore has a /frozen, deterministic/ answer,+-- even far-future years for which the "astronomical" leap flag is really just whatever value the BCL happened to precompute.+--+-- * We instead compute each Nowruz on demand from first principles: the March equinox (Meeus, /Astronomical Algorithms/ ch. 27\/28), the equation of time (to reduce mean noon to apparent noon at+-- the Iranian reference meridian), and ΔT — the difference between Terrestrial Time and Universal Time caused by the slow, irregular change in the Earth's rotation.+--+-- ΔT is the limiting factor. It can only be /measured/ for the past and /extrapolated/ for the future, and the standard Espenak–Meeus polynomials are only trustworthy through roughly 2150 CE; beyond+-- that the extrapolation error grows without bound and can shift the computed equinox — and hence a borderline Nowruz — by a whole day. Capping at Persian year 1500 (≈ 2121 CE) keeps every result+-- inside the range where the astronomy is genuinely well constrained, so every leap year we report is defensible rather than speculative. Over this range our results match NodaTime exactly, including+-- all of the documented years where the astronomical calendar diverges from the arithmetic one (e.g. Persian 1404 = 21.Mar.2025, where the arithmetic calendar gives the 20th).+--+-- If you need dates past 2121 CE, prefer the arithmetic (Birashk) Solar Hijri calendar, whose leap rule is exact by definition and carries no astronomical uncertainty.+---------------------------------------------------------------------------- module Data.HodaTime.Calendar.Persian (+ -- * Constructors+ calendarDate+ ,fromNthDay+ ,fromWeekDate+ -- * Types+ ,Month(..)+ ,DayOfWeek(..)+ ,Persian ) where++import Data.HodaTime.CalendarDateTime.Internal (IsCalendar(..), IsCalendarDateTime(..), CalendarDate, DayNth, DayOfMonth, Year, WeekNumber, CalendarDateTime(..), LocalTime(..), Date)+import Control.DeepSeq (NFData(..))+import Data.Hashable (Hashable(..))+import Data.HodaTime.Instant.Internal (Instant(..))+import Data.HodaTime.Calendar.Internal (mkCommonDayLens, mkCommonMonthLens, mkYearLens, mkFromNthDay, mkFromWeekDate, moveByDow, dayOfWeekFromDays)+import Data.HodaTime.Calendar.Persian.Astronomical (newYearDay, minPersianYear, maxPersianYear)+import Data.Int (Int32)+import Data.Word (Word8)+import Control.Monad (guard)++-- constants++monthsPerYear :: Int+monthsPerYear = 12++-- | Days elapsed before each 0-based month. Months 1-6 have 31 days, months 7-11 have 30, 'Esfand' has 29 (30 in a leap year).+persianMonthDayOffsets :: [Int]+persianMonthDayOffsets = [0, 31, 62, 93, 124, 155, 186, 216, 246, 276, 306, 336]++firstPerDayTuple :: (Integral a, Integral b, Integral c) => (a, b, c)+firstPerDayTuple = (1, 0, 1) -- NOTE: 1.Farvardin.1++invalidDayThresh :: Integral a => a+invalidDayThresh = fromIntegral $ pred day0+ where+ (y, m, d) = firstPerDayTuple :: (Year, Int, DayOfMonth)+ day0 = yearMonthDayToDays y (toEnum m) d++-- | Persian dates are stored directly on the universal timeline (day 0 = 1.Mar.2000 Gregorian = Wednesday), so the+-- 'Instant' bridge is the identity and the epoch weekday is that of the shared day 0.+epochDayOfWeek :: DayOfWeek Persian+epochDayOfWeek = Wednesday++-- types++data Persian++instance IsCalendar Persian where+ data Date Persian = PersianDate {-# UNPACK #-} !Int32 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Int32+ deriving (Eq, Ord)++ data DayOfWeek Persian = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++ data Month Persian = Farvardin | Ordibehesht | Khordad | Tir | Mordad | Shahrivar | Mehr | Aban | Azar | Dey | Bahman | Esfand+ deriving (Show, Read, Eq, Ord, Enum, Bounded)++ fromDays = persianFromDays+ toDays = persianToDays+ toYmd = persianToYmd+ calendarName _ = "Persian"++ day' = mkCommonDayLens invalidDayThresh yearMonthDayToDays persianFromDays persianToYmd+ {-# INLINE day' #-}++ month' (PersianDate _ _ m _) = toEnum . fromIntegral $ m++ monthl' = mkCommonMonthLens monthsPerYear firstPerDayTuple maxDaysInMonth yearMonthDayToDays persianToYmd persianFromDays+ {-# INLINE monthl' #-}++ year' = mkYearLens firstPerDayTuple maxDaysInMonth yearMonthDayToDays persianToYmd persianFromDays+ {-# INLINE year' #-}++ dayOfWeek' (PersianDate days _ _ _) = toEnum . dayOfWeekFromDays epochDayOfWeek . fromIntegral $ days++ next' n dow (PersianDate days _ _ _) = moveByDow persianFromDays epochDayOfWeek n dow (-) (+) (>) (fromIntegral days)++ previous' n dow (PersianDate days _ _ _) = moveByDow persianFromDays epochDayOfWeek n dow subtract (-) (<) (fromIntegral days) -- NOTE: subtract is (-) with the arguments flipped++instance NFData (Date Persian) where+ rnf (PersianDate days d m y) = rnf days `seq` rnf d `seq` rnf m `seq` rnf y++instance Hashable (Date Persian) where+ hashWithSalt s (PersianDate days d m y) = s `hashWithSalt` days `hashWithSalt` d `hashWithSalt` m `hashWithSalt` y++instance NFData (Month Persian) where+ rnf m = m `seq` ()++instance Hashable (Month Persian) where+ hashWithSalt s = hashWithSalt s . fromEnum++instance NFData (DayOfWeek Persian) where+ rnf d = d `seq` ()++instance Hashable (DayOfWeek Persian) where+ hashWithSalt s = hashWithSalt s . fromEnum++instance IsCalendarDateTime Persian where+ fromAdjustedInstant (Instant days secs nsecs) = CalendarDateTime (persianFromDays days) (LocalTime secs nsecs)+ toUnadjustedInstant (CalendarDateTime pd (LocalTime secs nsecs)) = Instant (persianToDays pd) secs nsecs++-- | Build the flat Persian date (denormalized: keeps the day count plus the decoded day\/month\/year).+persianFromDays :: Int32 -> Date Persian+persianFromDays days = PersianDate days d m y+ where (y, m, d) = daysToYearMonthDay days++persianToDays :: Date Persian -> Int32+persianToDays (PersianDate days _ _ _) = days++persianToYmd :: Date Persian -> (Int32, Word8, Word8)+persianToYmd (PersianDate _ d m y) = (y, m, d)++-- Constructors++-- | Smart constructor for a 'Persian' calendar date. Returns 'Nothing' if the day is out of range for the month or the+-- year is outside the supported range (1 .. 1500).+calendarDate :: DayOfMonth -> Month Persian -> Year -> Maybe (CalendarDate Persian)+calendarDate d m y = do+ guard $ y >= fromIntegral minPersianYear && y <= fromIntegral maxPersianYear+ guard $ d > 0 && d <= maxDaysInMonth m y+ return $ persianFromDays (fromIntegral $ yearMonthDayToDays y m d)++-- | Smart constructor for a 'Persian' calendar date given as a day relative to a month (e.g. the third Monday of the month). Returns 'Nothing' if the resulting date is invalid.+fromNthDay :: DayNth -> DayOfWeek Persian -> Month Persian -> Year -> Maybe (CalendarDate Persian)+fromNthDay = mkFromNthDay invalidDayThresh epochDayOfWeek yearMonthDayToDays maxDaysInMonth persianFromDays++-- | Smart constructor for a 'Persian' calendar date given as a week date. Note that this method assumes weeks start on Saturday (as in the Persian calendar) and the first week of the year is the+-- one which has at least one day in the new year.+fromWeekDate :: WeekNumber -> DayOfWeek Persian -> Year -> Maybe (CalendarDate Persian)+fromWeekDate = mkFromWeekDate invalidDayThresh epochDayOfWeek yearMonthDayToDays persianFromDays 1 Saturday++-- helper functions++-- | A year is a leap year exactly when the astronomical rule places the next Nowruz 366 days later.+isLeapYear :: Year -> Bool+isLeapYear y = newYearDay (fromIntegral y + 1) - newYearDay (fromIntegral y) == 366++maxDaysInMonth :: Month Persian -> Year -> Int+maxDaysInMonth Esfand y+ | isLeapYear y = 30+ | otherwise = 29+maxDaysInMonth m _+ | fromEnum m < 6 = 31 -- Farvardin .. Shahrivar+ | otherwise = 30 -- Mehr .. Bahman++-- | Universal flat day (day 0 = 1.Mar.2000 Gregorian) of the given Persian date.+yearMonthDayToDays :: Year -> Month Persian -> DayOfMonth -> Int+yearMonthDayToDays y m d = newYearDay (fromIntegral y) + persianMonthDayOffsets !! fromEnum m + d - 1++daysToYearMonthDay :: Int32 -> (Int32, Word8, Word8)+daysToYearMonthDay flatDays = (fromIntegral y, fromIntegral m, fromIntegral d)+ where+ day = fromIntegral flatDays :: Int -- universal flat day+ yEst = minPersianYear + (day - newYearDay minPersianYear) `div` 365+ y = adjust yEst+ adjust yy+ | newYearDay yy > day = adjust (yy - 1)+ | newYearDay (yy + 1) <= day = adjust (yy + 1)+ | otherwise = yy+ dayOfYear = day - newYearDay y+ (m, d)+ | dayOfYear == 365 = (11, 30) -- Esfand 30 (leap years only)+ | dayOfYear < 6 * 31 = let (mm, dd) = dayOfYear `divMod` 31 in (mm, dd + 1)+ | otherwise = let (mm, dd) = (dayOfYear - 6 * 31) `divMod` 30 in (mm + 6, dd + 1)
+ src/Data/HodaTime/Calendar/Persian/Astronomical.hs view
@@ -0,0 +1,149 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.Calendar.Persian.Astronomical+-- Copyright : (C) 2017 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- Astronomical determination of the Persian (Solar Hijri) new year, Nowruz. The official Iranian calendar begins each+-- year on the day whose (apparent) noon at the reference meridian (52.5°E, i.e. Iran Standard Time, UTC+3:30) most+-- closely follows the March equinox: Nowruz is the day on which the equinox occurs if it is before true noon in Tehran,+-- otherwise the following day.+--+-- The equinox is computed with the method of Meeus (/Astronomical Algorithms/, ch. 27), corrected to Universal Time with+-- the Espenak–Meeus ΔT polynomials, and compared against true (apparent) noon using the equation of time (Meeus ch. 28).+-- The results are validated against the published modern Nowruz dates and the official leap-year sequence, and against+-- NodaTime's astronomical data (e.g. the epoch 1.Farvardin.1 = 22.Mar.622 CE, and the years where the astronomical and+-- arithmetic calendars diverge). Accuracy is vouched for over 'minPersianYear' .. 'maxPersianYear'; the functions remain+-- total outside that range but the leap assignment there is an extrapolation.+----------------------------------------------------------------------------+module Data.HodaTime.Calendar.Persian.Astronomical+(+ newYearDay+ ,minPersianYear+ ,maxPersianYear+)+where++import Data.Array.Unboxed (UArray, listArray, (!))++-- | First Persian year the calendar covers (the era begins in 622 CE).+minPersianYear :: Int+minPersianYear = 1++-- | Last Persian year for which the astronomical calendar is vouched for (≈ 2121 CE). The equinox and ΔT models are+-- well grounded through this range.+maxPersianYear :: Int+maxPersianYear = 1500++-- | The universal flat day (day 0 = 1.Mar.2000 Gregorian, the 'Data.HodaTime.Instant.Instant' epoch) of Nowruz+-- (1 Farvardin) of the given Persian year. Cached for the supported range and computed on demand outside it, so the+-- calendar is total for every year.+newYearDay :: Int -> Int+newYearDay y+ | y >= minPersianYear && y <= maxPersianYear + 1 = cache ! y+ | otherwise = computeNewYearDay y++-- | Lazy cache of the new-year day for the supported range. As a CAF it is built once, on the first Persian-calendar+-- operation, and never at all in programs that don't touch the Persian calendar.+cache :: UArray Int Int+cache = listArray (minPersianYear, maxPersianYear + 1) [computeNewYearDay y | y <- [minPersianYear .. maxPersianYear + 1]]+{-# NOINLINE cache #-}++-- | 1.Mar.2000 Gregorian (the universal flat day 0) as a Julian Day Number.+baseJDN :: Int+baseJDN = gregorianToJDN 2000 3 1++computeNewYearDay :: Int -> Int+computeNewYearDay pYear = nowruzJDN pYear - baseJDN++-- | The Julian Day Number of Nowruz for the given Persian year, via the astronomical rule described in the module header.+nowruzJDN :: Int -> Int+nowruzJDN pYear = if frac <= threshold then jdn else jdn + 1+ where+ gregYear = pYear + 621 -- Nowruz of Persian year Y falls in Gregorian year Y + 621+ jde = marchEquinoxJDE gregYear -- equinox in Terrestrial Time+ jdUT = jde - deltaT gregYear / 86400 -- convert to Universal Time+ jdTehran = jdUT + 3.5 / 24 -- Iran Standard Time (UTC+3:30, meridian 52.5°E)+ x = jdTehran + 0.5 -- shift so the integer part is the civil day, 0.5 = noon+ jdn = floor x :: Int+ frac = x - fromIntegral jdn -- fraction of the day from midnight (0.5 = mean noon)+ threshold = 0.5 - eotDays jde -- true (apparent) noon differs from mean noon by the equation of time++-- | The March (northward) equinox as a Julian Ephemeris Day (Terrestrial Time), per Meeus /Astronomical Algorithms/ ch. 27.+marchEquinoxJDE :: Int -> Double+marchEquinoxJDE year+ | year <= 1000 = correct $ 1721139.29189 + 365242.13740 * y1 + 0.06134 * y1 ** 2 + 0.00111 * y1 ** 3 - 0.00071 * y1 ** 4+ | otherwise = correct $ 2451623.80984 + 365242.37404 * y2 + 0.05169 * y2 ** 2 - 0.00411 * y2 ** 3 - 0.00057 * y2 ** 4+ where+ y1 = fromIntegral year / 1000+ y2 = (fromIntegral year - 2000) / 1000+ correct jde0 = jde0 + (0.00001 * s) / dl+ where+ t = (jde0 - 2451545.0) / 36525+ w = 35999.373 * t - 2.47+ dl = 1 + 0.0334 * cos (d2r w) + 0.0007 * cos (d2r (2 * w))+ s = sum [ a * cos (d2r (b + c * t)) | (a, b, c) <- periodicTerms ]++-- | The 24 periodic terms (A, B, C) of Meeus table 27.C, used to refine the mean equinox.+periodicTerms :: [(Double, Double, Double)]+periodicTerms =+ [ (485, 324.96, 1934.136), (203, 337.23, 32964.467), (199, 342.08, 20.186)+ , (182, 27.85, 445267.112), (156, 73.14, 45036.886), (136, 171.52, 22518.443)+ , ( 77, 222.54, 65928.934), ( 74, 296.72, 3034.906), ( 70, 243.58, 9037.513)+ , ( 58, 119.81, 33718.147), ( 52, 297.17, 150.678), ( 50, 21.02, 2281.226)+ , ( 45, 247.54, 29929.562), ( 44, 325.15, 31555.956), ( 29, 60.93, 4443.417)+ , ( 18, 155.12, 67555.328), ( 17, 288.79, 4562.452), ( 16, 198.04, 62894.029)+ , ( 14, 199.76, 31436.921), ( 12, 95.39, 14577.848), ( 12, 287.11, 31931.756)+ , ( 12, 320.81, 34777.259), ( 9, 227.73, 1222.114), ( 8, 15.45, 16859.074)+ ]++-- | ΔT (Terrestrial Time − Universal Time), in seconds, from the Espenak & Meeus polynomial expressions.+deltaT :: Int -> Double+deltaT yr+ | y < 500 = let u = y / 100 in 10583.6 - 1014.41 * u + 33.78311 * u^.2 - 5.952053 * u^.3 - 0.1798452 * u^.4 + 0.022174192 * u^.5 + 0.0090316521 * u^.6+ | y < 1600 = let u = (y - 1000) / 100 in 1574.2 - 556.01 * u + 71.23472 * u^.2 + 0.319781 * u^.3 - 0.8503463 * u^.4 - 0.005050998 * u^.5 + 0.0083572073 * u^.6+ | y < 1700 = let t = y - 1600 in 120 - 0.9808 * t - 0.01532 * t^.2 + t^.3 / 7129+ | y < 1800 = let t = y - 1700 in 8.83 + 0.1603 * t - 0.0059285 * t^.2 + 0.00013336 * t^.3 - t^.4 / 1174000+ | y < 1860 = let t = y - 1800 in 13.72 - 0.332447 * t + 0.0068612 * t^.2 + 0.0041116 * t^.3 - 0.00037436 * t^.4 + 0.0000121272 * t^.5 - 0.0000001699 * t^.6 + 0.000000000875 * t^.7+ | y < 1900 = let t = y - 1860 in 7.62 + 0.5737 * t - 0.251754 * t^.2 + 0.01680668 * t^.3 - 0.0004473624 * t^.4 + t^.5 / 233174+ | y < 1920 = let t = y - 1900 in -2.79 + 1.494119 * t - 0.0598939 * t^.2 + 0.0061966 * t^.3 - 0.000197 * t^.4+ | y < 1941 = let t = y - 1920 in 21.20 + 0.84493 * t - 0.076100 * t^.2 + 0.0020936 * t^.3+ | y < 1961 = let t = y - 1950 in 29.07 + 0.407 * t - t^.2 / 233 + t^.3 / 2547+ | y < 1986 = let t = y - 1975 in 45.45 + 1.067 * t - t^.2 / 260 - t^.3 / 718+ | y < 2005 = let t = y - 2000 in 63.86 + 0.3345 * t - 0.060374 * t^.2 + 0.0017275 * t^.3 + 0.000651814 * t^.4 + 0.00002373599 * t^.5+ | y < 2050 = let t = y - 2000 in 62.92 + 0.32217 * t + 0.005589 * t^.2+ | y <= 2150 = -20 + 32 * ((y - 1820) / 100)^.2 - 0.5628 * (2150 - y)+ | otherwise = let u = (y - 1820) / 100 in -20 + 32 * u^.2+ where y = fromIntegral yr :: Double++-- | The equation of time (apparent − mean solar time), in days, at the given instant (Meeus ch. 28, low-accuracy form).+eotDays :: Double -> Double+eotDays jde = bigE / (2 * pi)+ where+ t = (jde - 2451545.0) / 36525+ l0 = d2r $ 280.46646 + 36000.76983 * t + 0.0003032 * t^.2+ m = d2r $ 357.52911 + 35999.05029 * t - 0.0001537 * t^.2+ e = 0.016708634 - 0.000042037 * t - 0.0000001267 * t^.2+ eps = d2r $ 23.439291 - 0.0130042 * t+ yy = tan (eps / 2) ^. 2+ bigE = yy * sin (2 * l0) - 2 * e * sin m + 4 * e * yy * sin m * cos (2 * l0) - 0.5 * yy^.2 * sin (4 * l0) - 1.25 * e^.2 * sin (2 * m)++d2r :: Double -> Double+d2r x = x * pi / 180++-- | Integer power with a fixed 'Int' exponent, avoiding the type defaulting of the exponent (which @-Wtype-defaults@+-- would otherwise flag) in the polynomial expressions above.+(^.) :: Double -> Int -> Double+(^.) = (^)+infixr 8 ^.++-- | Julian Day Number for a proleptic Gregorian date.+gregorianToJDN :: Int -> Int -> Int -> Int+gregorianToJDN y m d = d + (153 * m' + 2) `div` 5 + 365 * y' + y' `div` 4 - y' `div` 100 + y' `div` 400 - 32045+ where+ a = (14 - m) `div` 12+ y' = y + 4800 - a+ m' = m + 12 * a - 3
src/Data/HodaTime/CalendarDate.hs view
@@ -1,3 +1,59 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.CalendarDate+-- Copyright : (C) 2017 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- This is the module for 'CalendarDate'. A 'CalendarDate' represents a date within the calendar system that is part of its type. It has no reference to a particular time zone or time of day.+--+-- === Construction+--+-- To construct one of these types, see the Calendar module you wish to construct the date in (typically "Data.HodaTime.Calendar.Gregorian")+--+-- === Cookbook+--+-- ==== Building and inspecting a date+--+-- Dates are built with a calendar's smart constructor, which returns 'Nothing' for a date that does not exist.+-- Read-only components (such as the day of the week) are plain functions.+--+-- >>> calendarDate 14 February 2024+-- Just (fromJust (Gregorian.calendarDate 14 February 2024))+-- >>> calendarDate 30 February 2024+-- Nothing+-- >>> dayOfWeek <$> calendarDate 14 February 2024+-- Just Wednesday+--+-- ==== Re-expressing a date in another calendar+--+-- 'withCalendar' re-expresses a date in another calendar, preserving the same day on the absolute timeline; the+-- target calendar is chosen by the result type. Here the Gregorian Christmas becomes the Julian (\"Old Calendar\")+-- date still used liturgically, which the Julian calendar labels 12 December 2024 (it runs thirteen days behind).+--+-- >>> withCalendar <$> calendarDate 25 December 2024 :: Maybe (CalendarDate Julian.Julian)+-- Just (fromJust (Julian.calendarDate 12 December 2024))+--+-- ==== USA holidays for a given year+--+-- > import Data.Maybe (catMaybes)+-- > import Data.HodaTime.CalendarDate (DayNth(..))+-- > import Data.HodaTime.Calendar.Gregorian (calendarDate, fromNthDay, Month(..), DayOfWeek(..))+-- >+-- > usaHolidays y = catMaybes $ (\$ y) \<$\>+-- > [+-- > calendarDate 1 January -- New Year+-- > ,calendarDate 4 July -- Independence Day+-- > ,calendarDate 25 December -- Christmas+-- > ,fromNthDay First Monday September -- Labor day+-- > ,fromNthDay Third Monday January -- MLK day+-- > ,fromNthDay Second Tuesday February -- Presidents day+-- > ,fromNthDay Fourth Thursday November -- Thanksgiving+-- > ,calendarDate 29 February -- Leap day (not a real holiday, but shows a date that may not exist)+-- > ]+---------------------------------------------------------------------------- module Data.HodaTime.CalendarDate ( DayNth(..)@@ -6,7 +62,20 @@ ,DayOfMonth ,CalendarDate ,HasDate(..)+ ,withCalendar ) where -import Data.HodaTime.CalendarDateTime.Internal (CalendarDate(..), DayNth(..), DayOfMonth, Year, WeekNumber, HasDate(..))+import Data.HodaTime.CalendarDateTime.Internal (CalendarDate, DayNth(..), DayOfMonth, Year, WeekNumber, HasDate(..), CalendarDateTime(..), IsCalendarDateTime(..), at)+import Data.HodaTime.LocalTime.Internal (midnight)++-- $setup+-- >>> import Data.HodaTime.Calendar.Gregorian (calendarDate, Month(..))+-- >>> import qualified Data.HodaTime.Calendar.Julian as Julian++-- | Re-express a 'CalendarDate' in a different calendar, preserving the same day on the absolute timeline. For+-- example, convert a Gregorian date to the Julian (\"Old Calendar\") date still used liturgically by the Eastern+-- Orthodox church. The target calendar is chosen by the result type (via @TypeApplications@ or a type annotation).+withCalendar :: (IsCalendarDateTime a, IsCalendarDateTime b) => CalendarDate a -> CalendarDate b+withCalendar date = date'+ where CalendarDateTime date' _ = fromAdjustedInstant (toUnadjustedInstant (date `at` midnight))
src/Data/HodaTime/CalendarDateTime.hs view
@@ -1,19 +1,31 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.CalendarDate+-- Copyright : (C) 2017 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- This is the module for 'CalendarDateTime'. A 'CalendarDateTime' represents a date and time within the calendar system that is part of its type. It has no reference to a particular time zone and is therefor not+-- a globally unique value as June 3rd 2020 10:05pm occurred at different 'Instant's around the world.+--+-- === Construction+--+-- To construct one of these types you will need a 'CalendarDate' and a 'LocalTime'+---------------------------------------------------------------------------- module Data.HodaTime.CalendarDateTime ( -- * Types- DayNth(..)- ,Year- ,WeekNumber- ,DayOfMonth- ,CalendarDate- ,CalendarDateTime+ CalendarDateTime ,IsCalendar(..) ,HasDate(..)- ,LocalTime -- * Constructors ,on ,at ,atStartOfDay+ -- * Conversion+ ,withCalendar ) where @@ -27,3 +39,9 @@ -- | Returns the first valid time in the day specified by 'CalendarDate' within the given 'TimeZone' atStartOfDay :: CalendarDate cal -> CalendarDateTime cal atStartOfDay = flip at midnight++-- | Re-express a 'CalendarDateTime' in a different calendar, preserving the same instant on the absolute timeline+-- (including the time of day). The target calendar is chosen by the result type (via @TypeApplications@ or a type+-- annotation).+withCalendar :: (IsCalendarDateTime a, IsCalendarDateTime b) => CalendarDateTime a -> CalendarDateTime b+withCalendar = fromAdjustedInstant . toUnadjustedInstant
src/Data/HodaTime/CalendarDateTime/Internal.hs view
@@ -1,4 +1,8 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-} module Data.HodaTime.CalendarDateTime.Internal (@@ -6,7 +10,7 @@ ,Year ,WeekNumber ,DayOfMonth- ,CalendarDate(..)+ ,CalendarDate ,CalendarDateTime(..) ,IsCalendar(..) ,HasDate(..)@@ -17,11 +21,21 @@ where import Data.HodaTime.Instant.Internal (Instant)+import Data.Functor.Const (Const(..)) import Data.Int (Int32) import Data.Word (Word8, Word32)+import Control.DeepSeq (NFData(..))+import Data.Hashable (Hashable(..)) +-- $setup+-- >>> import Data.Maybe (fromJust)+-- >>> import Data.HodaTime.Internal.Lens (modify)+-- >>> import qualified Data.HodaTime.Calendar.Gregorian as Gregorian+-- >>> import Data.HodaTime.Calendar.Gregorian (Month(..), DayOfWeek(..))+ -- CalendarDate +-- | Used by several smart constructors to chose a day relative to the start or end of the month. data DayNth = FourthToLast | ThirdToLast@@ -38,29 +52,33 @@ type DayOfMonth = Int type WeekNumber = Int --- TODO: We may want to add a "cycle" field to the calendarDate that counts 400 year cyles. This would allow days to be non-negative--- and it would mean that one table can translate all possible days since they repeat each cycle---- | Represents a specific date within its calendar system, with no reference to any time zone or time of day.--- Note: We keep the date in 2 formats, redundantly. We depend on lazy evaluation to only produce the portion that is actually used-data CalendarDate calendar = CalendarDate { cdDays :: Int32, cdDay :: Word8, cdMonth :: Word8, cdYear :: Word32 }- deriving (Eq, Show, Ord) -- TODO: Get rid of Show and define the other instances to only use cdDays---- NOTE: This is a test form of the calendar date that only stores the cycle. Everything else will be pulled from the date cache table, as required---data CalendarDate o calendar = CalendarDate { cdDays :: Int32, cdCycle :: Word8, ldOptions :: o }--- deriving (Eq, Show, Ord)+-- | A calendar date in the calendar system @cal@. This is a public synonym for the per-calendar representation+-- 'Date': each calendar defines its own @data instance Date cal@ (see 'IsCalendar'), so unrelated calendars+-- (e.g. Gregorian and Hebrew) need share nothing in how a date is stored.+type CalendarDate cal = Date cal class IsCalendar cal where- type Date cal+ -- | The per-calendar date representation. Each calendar picks whatever packing is most natural/efficient for it.+ data Date cal data DayOfWeek cal data Month cal- day' :: Functor f => (DayOfMonth -> f DayOfMonth) -> CalendarDate cal -> f (CalendarDate cal)- month' :: CalendarDate cal -> Month cal- monthl' :: Functor f => (Int -> f Int) -> CalendarDate cal -> f (CalendarDate cal)- year' :: Functor f => (Year -> f Year) -> CalendarDate cal -> f (CalendarDate cal)- dayOfWeek' :: CalendarDate cal -> DayOfWeek cal- next' :: Int -> DayOfWeek cal -> CalendarDate cal -> CalendarDate cal- previous' :: Int -> DayOfWeek cal -> CalendarDate cal -> CalendarDate cal+ -- | Build a date from a flat, epoch-relative day count (the calendar's own epoch).+ fromDays :: Int32 -> Date cal+ -- | Extract the flat, epoch-relative day count from a date.+ toDays :: Date cal -> Int32+ -- | Decode a date to @(year, zero-based month, day-of-month)@. The year is signed so calendars can represent+ -- pre-epoch (e.g. BC) years without wraparound.+ toYmd :: Date cal -> (Int32, Word8, Word8)+ -- | The calendar's display name (e.g. @"Gregorian"@), used by 'Show' to render a date as the+ -- smart-constructor call that builds it.+ calendarName :: Date cal -> String+ day' :: Functor f => (DayOfMonth -> f DayOfMonth) -> Date cal -> f (Date cal)+ month' :: Date cal -> Month cal+ monthl' :: Functor f => (Int -> f Int) -> Date cal -> f (Date cal)+ year' :: Functor f => (Year -> f Year) -> Date cal -> f (Date cal)+ dayOfWeek' :: Date cal -> DayOfWeek cal+ next' :: Int -> DayOfWeek cal -> Date cal -> Date cal+ previous' :: Int -> DayOfWeek cal -> Date cal -> Date cal class HasDate d where type DoW d@@ -73,21 +91,46 @@ -- please note that the day will be unaffected except in the case of "end of month" days which may clamp. Note that this clamping will only occur as a final step, -- so that --- -- >>> modify (+ 2) monthl $ Gregorian.calendarDate 31 January 2000- -- CalendarDate 31 March 2000+ -- >>> modify monthl (+ 2) <$> Gregorian.calendarDate 31 January 2000+ -- Just (fromJust (Gregorian.calendarDate 31 March 2000)) -- -- and not 29th of March as would happen with some libraries. monthl :: Functor f => (Int -> f Int) -> d -> f d -- | Lens for the year component of a 'HasDate'. Please note that the rest of the date is left as is, with two exceptions: Feb 29 will clamp to 28 in a non-leapyear -- and if the new year is earlier than the earliest supported year it will clamp back to that year year :: Functor f => (Year -> f Year) -> d -> f d+ -- | Accessor for the Day of the week enum of a 'HasDate', for example:+ --+ -- >>> dayOfWeek . fromJust $ Gregorian.calendarDate 31 January 2000+ -- Monday dayOfWeek :: d -> DoW d+ -- | Returns a 'HasDate' shifted to the nth next Day of Week from the current 'HasDate', for example:+ --+ -- >>> next 1 Monday . fromJust $ Gregorian.calendarDate 31 January 2000+ -- fromJust (Gregorian.calendarDate 7 February 2000) next :: Int -> DoW d -> d -> d+ -- | Returns a 'HasDate' shifted to the nth previous Day of Week from the current 'HasDate', for example:+ --+ -- >>> previous 1 Monday . fromJust $ Gregorian.calendarDate 31 January 2000+ -- fromJust (Gregorian.calendarDate 24 January 2000) previous :: Int -> DoW d -> d -> d+ -- | Access the year, month and day-of-month components together in a single call, returned as a+ -- @(year, month, day)@ tuple.+ --+ -- This is purely an access optimization for code that needs more than one date component at once. Reading the+ -- components individually with 'year', 'month' and 'day' is perfectly correct, but for a packed representation+ -- (such as the Gregorian 'Date', which stores a cycle\/century\/day-in-century triple) each of those accessors+ -- independently decodes the stored value, so asking for all three separately decodes it three times.+ -- 'yearMonthDay' decodes once and hands back every component, which is noticeably cheaper on hot paths (for+ -- example date formatting). For representations that already store the components separately (such as the Julian+ -- 'Date') there is nothing to decode and this is simply the three field reads, so it is never slower than the+ -- individual accessors and callers can use it unconditionally.+ yearMonthDay :: d -> (Year, MoY d, DayOfMonth)+ yearMonthDay d = (getConst (year Const d), month d, getConst (day Const d)) -instance (IsCalendar cal) => HasDate (CalendarDate cal) where- type DoW (CalendarDate cal) = DayOfWeek cal- type MoY (CalendarDate cal) = Month cal+instance (IsCalendar cal) => HasDate (Date cal) where+ type DoW (Date cal) = DayOfWeek cal+ type MoY (Date cal) = Month cal day = day' month = month' monthl = monthl'@@ -96,21 +139,73 @@ next = next' previous = previous' +-- | Renders the (partial) smart-constructor call that produces a date, e.g. @Gregorian.calendarDate 31 March 2000@,+-- without the surrounding 'fromJust'. Shared by the 'Show' instances for 'Date' and 'CalendarDateTime'.+showsDateCon :: (IsCalendar cal, Show (Month cal)) => Date cal -> ShowS+showsDateCon date =+ showString (calendarName date) . showString ".calendarDate "+ . showsPrec 11 (fromIntegral dom :: Int) . showChar ' '+ . showsPrec 11 (month' date) . showChar ' '+ . showsPrec 11 (fromIntegral yr :: Int)+ where (yr, _m, dom) = toYmd date++-- | Renders a date as the (honest) smart-constructor call that produces it, e.g.+-- @fromJust (Gregorian.calendarDate 31 March 2000)@. This is a debug rendering, not code to paste back+-- verbatim (the calendar qualifier depends on how you imported it, and 'calendarDate' returns 'Maybe') \- it+-- is meant to tell you exactly what the value is.+instance (IsCalendar cal, Show (Month cal)) => Show (Date cal) where+ showsPrec p date = showParen (p > 10) $ showString "fromJust (" . showsDateCon date . showChar ')'+ -- LocalTime -- | Represents a specific time of day with no reference to any calendar, date or time zone. data LocalTime = LocalTime { ltSecs :: Word32, ltNsecs :: Word32 }- deriving (Eq, Ord, Show) -- TODO: Remove Show+ deriving (Eq, Ord) +-- | Renders the (partial) smart-constructor call that produces a 'LocalTime', e.g. @localTime 4 30 0 0@, without+-- the surrounding 'fromJust'. Shared by the 'Show' instances for 'LocalTime' and 'CalendarDateTime'.+showsLocalTimeCon :: LocalTime -> ShowS+showsLocalTimeCon (LocalTime secs nsecs) =+ showString "localTime "+ . showsPrec 11 h . showChar ' ' . showsPrec 11 m . showChar ' '+ . showsPrec 11 s . showChar ' ' . showsPrec 11 (fromIntegral nsecs :: Int)+ where+ (h, r) = (fromIntegral secs :: Int) `divMod` 3600+ (m, s) = r `divMod` 60++instance Show LocalTime where+ showsPrec p lt = showParen (p > 10) $ showString "fromJust (" . showsLocalTimeCon lt . showChar ')'++instance NFData LocalTime where+ rnf (LocalTime secs nsecs) = rnf secs `seq` rnf nsecs++instance Hashable LocalTime where+ hashWithSalt s (LocalTime secs nsecs) = s `hashWithSalt` secs `hashWithSalt` nsecs+ -- CalendarDateTime -- | Represents a specific date and time within its calendar system. NOTE: a CalendarDateTime does -- *not* represent a specific time on the global time line because e.g. "10.March.2006 4pm" is a different instant -- in most time zones. Convert it to a ZonedDateTime first if you wish to convert to an instant (or use a convenience -- function).-data CalendarDateTime calendar = CalendarDateTime (CalendarDate calendar) LocalTime- deriving (Eq, Show, Ord)+data CalendarDateTime calendar = CalendarDateTime (Date calendar) LocalTime +deriving instance Eq (Date cal) => Eq (CalendarDateTime cal)+deriving instance Ord (Date cal) => Ord (CalendarDateTime cal)++-- | Renders a 'CalendarDateTime' as the applicative construction that produces it, e.g.+-- @fromJust (at \<$\> Gregorian.calendarDate 31 March 2000 \<*\> localTime 4 30 0 0)@. A single 'fromJust'+-- wraps the whole thing because that is how one actually builds the value from the (partial) smart constructors.+instance (IsCalendar cal, Show (Month cal)) => Show (CalendarDateTime cal) where+ showsPrec p (CalendarDateTime d lt) = showParen (p > 10) $+ showString "fromJust (at <$> " . showsDateCon d . showString " <*> " . showsLocalTimeCon lt . showChar ')'++instance NFData (Date cal) => NFData (CalendarDateTime cal) where+ rnf (CalendarDateTime d lt) = rnf d `seq` rnf lt++instance Hashable (Date cal) => Hashable (CalendarDateTime cal) where+ hashWithSalt s (CalendarDateTime d lt) = s `hashWithSalt` d `hashWithSalt` lt+ instance (IsCalendar cal) => HasDate (CalendarDateTime cal) where type DoW (CalendarDateTime cal) = DayOfWeek cal type MoY (CalendarDateTime cal) = Month cal@@ -132,5 +227,5 @@ -- constructors -- | Returns a 'CalendarDateTime' of the 'CalendarDate' at the given 'LocalTime'-at :: CalendarDate cal -> LocalTime -> CalendarDateTime cal-at date time = CalendarDateTime date time+at :: Date cal -> LocalTime -> CalendarDateTime cal+at = CalendarDateTime
src/Data/HodaTime/Constants.hs view
@@ -1,11 +1,6 @@ module Data.HodaTime.Constants (- daysPerCycle- ,daysPerCentury- ,daysPerFourYears- ,monthsPerYear- ,daysPerWeek- ,hoursPerDay+ hoursPerDay ,minutesPerDay ,minutesPerHour ,secondsPerDay@@ -21,21 +16,6 @@ where -- Time constants--daysPerCycle :: Num a => a -- NOTE: A "cycle" is 400 years-daysPerCycle = 146097--daysPerCentury :: Num a => a-daysPerCentury = 36524--daysPerFourYears :: Num a => a-daysPerFourYears = 1461--monthsPerYear :: Num a => a-monthsPerYear = 12--daysPerWeek :: Num a => a-daysPerWeek = 7 hoursPerDay :: Num a => a hoursPerDay = 24
src/Data/HodaTime/Duration.hs view
@@ -5,9 +5,21 @@ -- License : BSD-style (see the file LICENSE) -- Maintainer : Jason Johnson <jason.johnson.081@gmail.com> -- Stability : experimental--- Portability : TBD+-- Portability : POSIX, Windows -- -- A 'Duration' is fixed period of time between global times.+--+-- === Cookbook+--+-- ==== Ninety minutes from now+--+-- > import Data.HodaTime.Instant (Instant, now, add)+-- > import Data.HodaTime.Duration (fromMinutes)+-- >+-- > ninetyMinutesFromNow :: IO Instant+-- > ninetyMinutesFromNow = do+-- > t <- now+-- > return (t `add` fromMinutes 90) ---------------------------------------------------------------------------- module Data.HodaTime.Duration (
+ src/Data/HodaTime/Exceptions.hs view
@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.Exceptions+-- Copyright : (C) 2016 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- Exceptions defined by this library.+----------------------------------------------------------------------------+module Data.HodaTime.Exceptions+(+ -- * Types+ DayRequiredException(..)+ ,MonthRequiredException(..)+ ,YearRequiredException(..)+)+where++import Control.Exception (Exception)+import Data.Typeable (Typeable)++-- Parsing++-- | Day is required for parse pattern+data DayRequiredException = DayRequiredException+ deriving (Typeable, Show)++instance Exception DayRequiredException++-- | Month is required for parse pattern+data MonthRequiredException = MonthRequiredException+ deriving (Typeable, Show)++instance Exception MonthRequiredException++-- | Year is required for parse pattern+data YearRequiredException = YearRequiredException+ deriving (Typeable, Show)++instance Exception YearRequiredException
src/Data/HodaTime/Instant.hs view
@@ -5,7 +5,7 @@ -- License : BSD-style (see the file LICENSE) -- Maintainer : Jason Johnson <jason.johnson.081@gmail.com> -- Stability : experimental--- Portability : TBD+-- Portability : POSIX, Windows -- -- An 'Instant' is universal fixed moment in time. ----------------------------------------------------------------------------@@ -15,6 +15,11 @@ Instant -- * Constructors ,fromSecondsSinceUnixEpoch+ -- | The current time as an 'Instant'.+ --+ -- Note: Hoda Time does not model leap seconds, so 'now' follows POSIX time semantics — the returned 'Instant'+ -- does not include leap seconds (every day is treated as exactly 86400 seconds). This keeps @now@ consistent with+ -- the rest of the library: round-tripping through a 'ZonedDateTime' never adds or removes leap seconds. ,now -- * Math ,add@@ -22,20 +27,17 @@ ,minus -- * Conversion ,inTimeZone- -- * Debug - to be removed ) where --- TODO - BUG: now is based on calling gettimeofday. The question is if this returns a number with leap seconds removed or not. If it does not then we will have--- TODO - BUG: an issue if we go: now -> ZoneDateTime -> Instant because the last conversion will remove leap seconds.- import Data.HodaTime.Instant.Internal import Data.HodaTime.Instant.Platform (now) import Data.HodaTime.TimeZone.Internal (TimeZone)-import Data.HodaTime.ZonedDateTime.Internal (ZonedDateTime(..))+import Data.HodaTime.ZonedDateTime.Internal (ZonedDateTime(..), fromInstant)+import Data.HodaTime.CalendarDateTime.Internal (IsCalendarDateTime) -- Conversion -- | Convert 'Instant' to a 'ZonedDateTime' in the specified time zone. The calendar must be derivable or specified in the type explicitly-inTimeZone :: Instant -> TimeZone -> ZonedDateTime cal-inTimeZone _instant _tz = undefined+inTimeZone :: IsCalendarDateTime cal => Instant -> TimeZone -> ZonedDateTime cal+inTimeZone instant tz = fromInstant instant tz
src/Data/HodaTime/Instant/Internal.hs view
@@ -13,7 +13,8 @@ import Data.Word (Word32) import Data.Int (Int32)-import Data.List (intercalate)+import Control.DeepSeq (NFData(..))+import Data.Hashable (Hashable(..)) import Data.HodaTime.Constants (secondsPerDay, nsecsPerSecond, nsecsPerMicrosecond, unixDaysOffset) import Control.Arrow ((>>>), first) @@ -21,20 +22,39 @@ -- | Represents a point on a global time line. An Instant has no concept of time zone or -- calendar. It is nothing more than the number of nanoseconds since epoch (1.March.2000)-data Instant = Instant { iDays :: Int32, iSecs :: Word32, iNsecs :: Word32 } -- TODO: Would this be better with only days and Word64 Nanos? See if the math is easier+data Instant = Instant { iDays :: {-# UNPACK #-} !Int32, iSecs :: {-# UNPACK #-} !Word32, iNsecs :: {-# UNPACK #-} !Word32 } deriving (Eq, Ord) +instance NFData Instant where+ rnf (Instant days secs nsecs) = rnf days `seq` rnf secs `seq` rnf nsecs++instance Hashable Instant where+ hashWithSalt s (Instant days secs nsecs) = s `hashWithSalt` days `hashWithSalt` secs `hashWithSalt` nsecs+ -- | Represents a duration of time between instants. It can be from days to nanoseconds, -- but anything longer is not representable by a duration because e.g. Months are calendar -- specific concepts. newtype Duration = Duration { getInstant :: Instant } {- NOTE: Defined here to avoid circular dependancy with Duration.Internal -}- deriving (Eq, Show) -- TODO: Remove Show+ deriving (Eq, Ord) +instance NFData Duration where+ rnf (Duration i) = rnf i++instance Hashable Duration where+ hashWithSalt s (Duration i) = hashWithSalt s i++-- | A debug rendering exposing the internal epoch-relative fields (epoch is 1.March.2000). There is no clean+-- total constructor to reproduce an arbitrary 'Instant', so this is deliberately a labelled view, not a call. instance Show Instant where- show (Instant days secs nsecs) = intercalate "." [show (abs days), show secs, show nsecs, sign]- where- sign = if signum days == -1 then "BE" else "E"+ showsPrec p (Instant days secs nsecs) = showParen (p > 10) $+ showString "Instant " . shows days . showString "d "+ . shows secs . showString "s " . shows nsecs . showString "ns" +instance Show Duration where+ showsPrec p (Duration (Instant days secs nsecs)) = showParen (p > 10) $+ showString "Duration " . shows days . showString "d "+ . shows secs . showString "s " . shows nsecs . showString "ns"+ -- interface -- Smallest possible instant@@ -45,7 +65,7 @@ fromSecondsSinceUnixEpoch :: Int -> Instant fromSecondsSinceUnixEpoch s = fromUnixGetTimeOfDay s 0 --- | Add a 'Duration' to an 'Instant' to get a future 'Instant'. /NOTE: does not handle all negative durations, use 'minus'/+-- | Add a 'Duration' to an 'Instant' to get a future 'Instant'. add :: Instant -> Duration -> Instant add (Instant ldays lsecs lnsecs) (Duration (Instant rdays rsecs rnsecs)) = Instant days' secs'' nsecs' where@@ -71,7 +91,7 @@ | x < 0 = (pred bigger, x + size) | otherwise = (bigger, x) --- | Subtract a 'Duration' from an 'Instant' to get an 'Instant' in the past. /NOTE: does not handle negative durations, use 'add'/+-- | Subtract a 'Duration' from an 'Instant' to get an 'Instant' in the past. minus :: Instant -> Duration -> Instant minus linstant (Duration rinstant) = getInstant $ difference linstant rinstant
+ src/Data/HodaTime/Internal/Lens.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE RankNTypes #-}++module Data.HodaTime.Internal.Lens+(+ Lens+ ,view+ ,set+ ,modify+)+where++import Control.Applicative++-- This module is copied almost word for word from the basic-lens package. We would use that instead but it's not supported by this version of stack lts+-- which means we have to use stack only features to get it to work. So for now, we just make our own version.++-- TODO: Get rid of this and use the package when we upgrade to where it is supported++type Lens s t a b = forall f. Functor f => (a -> f b) -> (s -> f t)++newtype Id a = Id { runId :: a }++instance Functor Id where fmap f = Id . f . runId++view :: Lens s t a b -> s -> a+view l = getConst . l Const++modify :: Lens s t a b -> (a -> b) -> s -> t+modify l f = runId . l (Id . f)++set :: Lens s t a b -> b -> s -> t+set l a = runId . l (Id . const a)
src/Data/HodaTime/Interval.hs view
@@ -5,7 +5,7 @@ -- License : BSD-style (see the file LICENSE) -- Maintainer : Jason Johnson <jason.johnson.081@gmail.com> -- Stability : experimental--- Portability : TBD+-- Portability : POSIX, Windows -- -- An 'Interval' is a period of time between two 'Instant's. ----------------------------------------------------------------------------@@ -27,9 +27,21 @@ import Data.HodaTime.Instant.Internal (Instant) import Data.HodaTime.Duration.Internal (Duration) import Data.HodaTime.Instant (difference)+import Control.DeepSeq (NFData(..))+import Data.Hashable (Hashable(..)) data Interval = Interval Instant Instant- deriving (Eq, Ord, Show) -- TODO: Remove Show+ deriving (Eq, Ord)++instance Show Interval where+ showsPrec p (Interval s e) = showParen (p > 10) $+ showString "interval " . showsPrec 11 s . showChar ' ' . showsPrec 11 e++instance NFData Interval where+ rnf (Interval s e) = rnf s `seq` rnf e++instance Hashable Interval where+ hashWithSalt salt (Interval s e) = salt `hashWithSalt` s `hashWithSalt` e interval :: Instant -> Instant -> Interval interval = Interval -- TODO: We probably need some checks here
src/Data/HodaTime/LocalTime.hs view
@@ -5,7 +5,7 @@ -- License : BSD-style (see the file LICENSE) -- Maintainer : Jason Johnson <jason.johnson.081@gmail.com> -- Stability : experimental--- Portability : TBD+-- Portability : POSIX, Windows -- -- An 'LocalTime' represents a time of day, with no reference to a particular calendar, time zone or date. -- This module contains constructors and functions for working with 'LocalTime'.@@ -16,30 +16,21 @@ ---------------------------------------------------------------------------- module Data.HodaTime.LocalTime (+ -- * Types LocalTime ,HasLocalTime(..) ,Hour ,Minute ,Second ,Nanosecond+ -- * Constructors ,localTime+ -- * Exceptions+ ,InvalidHourException+ ,InvalidMinuteException+ ,InvalidSecondException+ ,InvalidNanoSecondException ) where import Data.HodaTime.LocalTime.Internal-import Data.HodaTime.Internal (secondsFromHours, secondsFromMinutes)-import Control.Monad (guard)---- Construction---- | Create a new 'LocalTime' from an hour, minute, second and nanosecond if values are valid, nothing otherwise-localTime :: Hour -> Minute -> Second -> Nanosecond -> Maybe LocalTime-localTime h m s ns = do- guard $ h < 24 && h >= 0- guard $ m < 60 && m >= 0- guard $ s < 60 && m >= 0- guard $ ns >= 0- return $ LocalTime (h' + m' + fromIntegral s) (fromIntegral ns)- where- h' = secondsFromHours h- m' = secondsFromMinutes m
src/Data/HodaTime/LocalTime/Internal.hs view
@@ -6,16 +6,53 @@ ,Minute ,Second ,Nanosecond+ ,localTime ,midnight+ ,InvalidHourException(..)+ ,InvalidMinuteException(..)+ ,InvalidSecondException(..)+ ,InvalidNanoSecondException(..) ) where import Data.HodaTime.CalendarDateTime.Internal (LocalTime(..), CalendarDateTime(..), CalendarDate, day, IsCalendar(..))-import Data.HodaTime.Internal (hoursFromSecs, minutesFromSecs, secondsFromSecs)+import Data.HodaTime.Internal (hoursFromSecs, minutesFromSecs, secondsFromSecs, secondsFromHours, secondsFromMinutes) import Data.HodaTime.Constants (secondsPerDay) import Data.Functor.Identity (Identity(..)) import Data.Word (Word32)+import Control.Monad (unless)+import Control.Monad.Catch (MonadThrow, throwM)+import Control.Exception (Exception)+import Data.Typeable (Typeable) +-- Exceptions++-- | Given hour was not valid+data InvalidHourException = InvalidHourException+ deriving (Typeable, Show)++instance Exception InvalidHourException++-- | Given minute was not valid+data InvalidMinuteException = InvalidMinuteException+ deriving (Typeable, Show)++instance Exception InvalidMinuteException++-- | Given second was not valid+data InvalidSecondException = InvalidSecondException+ deriving (Typeable, Show)++instance Exception InvalidSecondException++-- | Given nanosecond was not valid+data InvalidNanoSecondException = InvalidNanoSecondException+ deriving (Typeable, Show)++instance Exception InvalidNanoSecondException++-- Types+ type Hour = Int type Minute = Int type Second = Int@@ -69,6 +106,10 @@ nanosecond f (CalendarDateTime cd lt) = CalendarDateTime cd <$> nanosecond f lt {-# INLINE nanosecond #-} +-- NOTE: AM/PM is handled in the pattern layer (see Data.HodaTime.Pattern.LocalTime), not as a lens here: the+-- designator and the 12-hour hour each rewrite only their half of the 'hour' via div/mod 12, which keeps+-- them order independent when composed.+ -- | Private function for constructing a localtime at midnight midnight :: LocalTime midnight = LocalTime 0 0@@ -85,3 +126,17 @@ where (d, secs') = secs `divMod` secondsPerDay date' = if d == 0 then date else runIdentity . day (Identity . (+ fromIntegral d)) $ date -- NOTE: inlining the modify lens here++-- constructors++-- | Create a new 'LocalTime' from an hour, minute, second and nanosecond if values are valid+localTime :: MonadThrow m => Hour -> Minute -> Second -> Nanosecond -> m LocalTime+localTime h m s ns = do+ unless (h < 24 && h >= 0) $ throwM InvalidHourException+ unless (m < 60 && m >= 0) $ throwM InvalidMinuteException+ unless (s < 60 && m >= 0) $ throwM InvalidSecondException+ unless (ns >= 0) $ throwM InvalidNanoSecondException+ return $ LocalTime (h' + m' + fromIntegral s) (fromIntegral ns)+ where+ h' = secondsFromHours h+ m' = secondsFromMinutes m
+ src/Data/HodaTime/Locale.hs view
@@ -0,0 +1,116 @@+-- |+-- Module : Data.HodaTime.Locale+-- Copyright : (C) 2016 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- Provides culture-specific names (month and weekday names, AM\/PM designators) and layout strings for dates and times.+-- A 'Locale' can be read from the operating system's locale database — in the same spirit as the time-zone support,+-- the data lives on the machine and is read on demand rather than being bundled — or you can use one of the built-in+-- locales ('enUS', 'deDE', 'jaJP') when you want a fixed, pure one with no @IO@.+--+-- 'Locale' is /abstract/: you never construct one yourself, you obtain it from 'currentLocale', 'localeByName' or a+-- built-in, and then hand it to the culture-aware patterns. Those live in "Data.HodaTime.Pattern.Locale" (whole-layout+-- patterns — @localeDatePattern@ \/ @localeTimePattern@) and in "Data.HodaTime.Pattern.CalendarDate" \/+-- "Data.HodaTime.Pattern.LocalTime" (individual name fields — @pMMMM'@, @pdddd'@, @ppp'@).+--+-- ==== __Getting a locale__+--+-- Three ways to obtain one — a built-in (pure, no @IO@), a specific installed locale by name, or the machine's own+-- current locale — each then handed to a culture-aware pattern:+--+-- > import Data.HodaTime.Locale (deDE, localeByName, currentLocale)+-- > import Data.HodaTime.Pattern (format)+-- > import Data.HodaTime.Pattern.Locale (localeDatePattern)+-- >+-- > -- a built-in: pure, formats the German way (15.03.2020)+-- > fromBuiltin = do+-- > p <- localeDatePattern deDE+-- > pure (format p someDate)+-- >+-- > -- a named locale installed on the machine+-- > fromName = do+-- > loc <- localeByName "de_DE.UTF-8"+-- > p <- localeDatePattern loc+-- > pure (format p someDate)+-- >+-- > -- whatever the machine's LC_TIME is set to+-- > fromCurrent = do+-- > loc <- currentLocale+-- > p <- localeDatePattern loc+-- > pure (format p someDate)+module Data.HodaTime.Locale+(+ -- * Locale+ Locale+ -- * Built-in locales+ ,enUS+ ,deDE+ ,jaJP+ -- * Reading the machine's locale+ ,currentLocale+ ,localeByName+ ,LocaleException(..)+ -- * Inspecting a locale+ ,localeId+ ,monthNames+ ,monthNamesShort+ ,dayNames+ ,dayNamesShort+ ,amName+ ,pmName+)+where++import Data.HodaTime.Locale.Internal (Locale, enUS, deDE, jaJP)+import qualified Data.HodaTime.Locale.Internal as I+import qualified Data.HodaTime.Locale.Platform as Platform+import Control.Exception (Exception, throwIO)++-- | Thrown by 'localeByName' when the requested locale is not installed on the machine.+newtype LocaleException = LocaleNotFound String+ deriving (Show)++instance Exception LocaleException++-- | Read the process's current locale, as selected by the environment (@LC_ALL@ \/ @LC_TIME@ \/ @LANG@), falling back+-- to the POSIX @C@ locale.+currentLocale :: IO Locale+currentLocale = Platform.loadCurrentLocale++-- | Read a specific locale by name, e.g. @\"de_DE.UTF-8\"@. Throws 'LocaleNotFound' if it is not installed.+localeByName :: String -> IO Locale+localeByName name = Platform.loadLocaleByName name >>= maybe (throwIO (LocaleNotFound name)) return++-- The accessors below are read-only wrappers over the (hidden) representation, so a 'Locale' can be inspected but never+-- constructed or modified from outside the library.++-- | The identifier this locale was loaded from (e.g. @\"de_DE.UTF-8\"@), or the short code of a built-in.+localeId :: Locale -> String+localeId = I.localeId++-- | Full month names, January-first (12 entries for the Gregorian calendar).+monthNames :: Locale -> [String]+monthNames = I.monthNames++-- | Abbreviated month names, January-first.+monthNamesShort :: Locale -> [String]+monthNamesShort = I.monthNamesShort++-- | Full weekday names, Sunday-first (7 entries).+dayNames :: Locale -> [String]+dayNames = I.dayNames++-- | Abbreviated weekday names, Sunday-first.+dayNamesShort :: Locale -> [String]+dayNamesShort = I.dayNamesShort++-- | The AM designator (may be empty in 24-hour cultures such as German).+amName :: Locale -> String+amName = I.amName++-- | The PM designator (may be empty in 24-hour cultures such as German).+pmName :: Locale -> String+pmName = I.pmName
+ src/Data/HodaTime/Locale/Internal.hs view
@@ -0,0 +1,122 @@+module Data.HodaTime.Locale.Internal+(+ Locale(..)+ ,enUS+ ,deDE+ ,jaJP+ ,windowsPictureToStrftime+)+where++-- | The culture-specific names used when formatting and parsing dates and times, as read from the operating system's+-- locale database (see "Data.HodaTime.Locale").+--+-- The month and weekday name lists describe the /Gregorian/ calendar, which is all the operating system's @LC_TIME@+-- category knows about. The lists are ordered to line up directly with the calendar enumerations: 'monthNames' is+-- January-first (indexed by @fromEnum@ of the month) and 'dayNames' is Sunday-first (indexed by @fromEnum@ of the+-- 'Data.HodaTime.CalendarDateTime.Internal.DayOfWeek', which also starts at Sunday).+--+-- The @raw*Format@ fields hold the operating system's own layout strings as POSIX @strftime@ strings, consumed by+-- @localeDatePattern@ and friends in "Data.HodaTime.Pattern.Locale". On POSIX they come straight from @D_FMT@ \/+-- @T_FMT@ \/ @D_T_FMT@; on Windows they are translated from the Windows /picture/ strings (e.g. @dd.MM.yyyy@) by+-- 'windowsPictureToStrftime'.+data Locale = Locale+ { localeId :: String -- ^ the identifier this locale was loaded from (e.g. @\"de_DE.UTF-8\"@)+ , monthNames :: [String] -- ^ full month names, January-first (12 entries for the Gregorian calendar)+ , monthNamesShort :: [String] -- ^ abbreviated month names, January-first+ , dayNames :: [String] -- ^ full weekday names, Sunday-first (7 entries)+ , dayNamesShort :: [String] -- ^ abbreviated weekday names, Sunday-first+ , amName :: String -- ^ the AM designator+ , pmName :: String -- ^ the PM designator+ , rawDateFormat :: String -- ^ the date layout as a POSIX @strftime@ string (from @D_FMT@, or translated on Windows)+ , rawTimeFormat :: String -- ^ the time layout as a POSIX @strftime@ string (from @T_FMT@, or translated on Windows)+ , rawDateTimeFormat :: String -- ^ the combined layout as a POSIX @strftime@ string (from @D_T_FMT@, or translated on Windows)+ }+ deriving (Eq, Show)++-- | Translate a Windows date\/time /picture/ string (as returned by @GetLocaleInfoEx@, e.g. @dd.MM.yyyy@) into the+-- equivalent POSIX @strftime@ string, so the locale-layout patterns can consume a Windows-read locale. Recognised+-- fields: @d@\/@dd@ (day), @ddd@\/@dddd@ (weekday name), @M@\/@MM@ (month), @MMM@\/@MMMM@ (month name), @yy@ (2-digit+-- year) and @yyyy@+ (full year), @h@\/@hh@ (12-hour), @H@\/@HH@ (24-hour), @m@\/@mm@ (minute), @s@\/@ss@ (second),+-- @t@\/@tt@ (AM\/PM). Text inside single quotes is literal (@''@ is a literal quote) and any other character is+-- copied through (with @%@ escaped as @%%@).+--+-- NOTE: Windows' no-pad @d@\/@M@ have no exact @strftime@ counterpart in the supported set, so single @d@ maps to the+-- space-padded @%e@ and single @M@ to @%m@ (approximations); the common two-digit @dd@\/@MM@ are exact.+windowsPictureToStrftime :: String -> String+windowsPictureToStrftime [] = []+windowsPictureToStrftime ('\'' : rest) = winLiteral rest+windowsPictureToStrftime (c : rest)+ | c `elem` "dMyHhmst" = winField c (1 + length same) ++ windowsPictureToStrftime rest'+ | c == '%' = '%' : '%' : windowsPictureToStrftime rest+ | otherwise = c : windowsPictureToStrftime rest+ where+ (same, rest') = span (== c) rest++-- | Map a Windows field letter and its repeat count to a @strftime@ specifier.+winField :: Char -> Int -> String+winField 'd' n | n >= 4 = "%A" | n == 3 = "%a" | n == 2 = "%d" | otherwise = "%e"+winField 'M' n | n >= 4 = "%B" | n == 3 = "%b" | otherwise = "%m"+winField 'y' n | n >= 3 = "%Y" | otherwise = "%y"+winField 'H' _ = "%H"+winField 'h' _ = "%I"+winField 'm' _ = "%M"+winField 's' _ = "%S"+winField 't' _ = "%p"+winField _ _ = ""++-- | Continue a Windows picture inside a single-quoted literal run.+winLiteral :: String -> String+winLiteral [] = []+winLiteral ('\'' : '\'' : rest) = '\'' : winLiteral rest+winLiteral ('\'' : rest) = windowsPictureToStrftime rest+winLiteral (c : rest)+ | c == '%' = '%' : '%' : winLiteral rest+ | otherwise = c : winLiteral rest++-- | A built-in United States English locale (@en_US@), offered so patterns can be produced without reading the machine.+-- Mirrors the @en_US@ @LC_TIME@ data: month-first dates and a 12-hour @%r@ time.+enUS :: Locale+enUS = Locale+ { localeId = "en_US"+ , monthNames = ["January","February","March","April","May","June","July","August","September","October","November","December"]+ , monthNamesShort = ["Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec"]+ , dayNames = ["Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday"]+ , dayNamesShort = ["Sun","Mon","Tue","Wed","Thu","Fri","Sat"]+ , amName = "AM"+ , pmName = "PM"+ , rawDateFormat = "%m/%d/%Y"+ , rawTimeFormat = "%r"+ , rawDateTimeFormat = "%a %d %b %Y %r %Z"+ }++-- | A built-in German locale (@de_DE@): day-first dates, 24-hour time, and \(as on a real @de_DE@\) /empty/ AM\/PM+-- designators.+deDE :: Locale+deDE = Locale+ { localeId = "de_DE"+ , monthNames = ["Januar","Februar","März","April","Mai","Juni","Juli","August","September","Oktober","November","Dezember"]+ , monthNamesShort = ["Jan","Feb","Mär","Apr","Mai","Jun","Jul","Aug","Sep","Okt","Nov","Dez"]+ , dayNames = ["Sonntag","Montag","Dienstag","Mittwoch","Donnerstag","Freitag","Samstag"]+ , dayNamesShort = ["So","Mo","Di","Mi","Do","Fr","Sa"]+ , amName = ""+ , pmName = ""+ , rawDateFormat = "%d.%m.%Y"+ , rawTimeFormat = "%T"+ , rawDateTimeFormat = "%a %d %b %Y %T %Z"+ }++-- | A built-in Japanese locale (@ja_JP@): @年\/月\/日@-punctuated numeric dates and @午前\/午後@ AM\/PM designators.+jaJP :: Locale+jaJP = Locale+ { localeId = "ja_JP"+ , monthNames = ["1月","2月","3月","4月","5月","6月","7月","8月","9月","10月","11月","12月"]+ , monthNamesShort = ["1月","2月","3月","4月","5月","6月","7月","8月","9月","10月","11月","12月"]+ , dayNames = ["日曜日","月曜日","火曜日","水曜日","木曜日","金曜日","土曜日"]+ , dayNamesShort = ["日","月","火","水","木","金","土"]+ , amName = "午前"+ , pmName = "午後"+ , rawDateFormat = "%Y年%m月%d日"+ , rawTimeFormat = "%H時%M分%S秒"+ , rawDateTimeFormat = "%Y年%m月%d日 %H時%M分%S秒"+ }
+ src/Data/HodaTime/Locale/Posix.hsc view
@@ -0,0 +1,145 @@+{-# LANGUAGE ForeignFunctionInterface #-}++-- | POSIX implementation of the locale reader, shared by the Linux and macOS platform shims. It reads the locale+-- database through the C library's per-locale query functions (@newlocale@ \/ @nl_langinfo_l@ \/ @freelocale@),+-- which are thread-safe and never mutate the global @setlocale@ state.+module Data.HodaTime.Locale.Posix+(+ loadCurrentLocale+ ,loadLocaleByName+)+where++import Data.HodaTime.Locale.Internal (Locale(..))+import Foreign.Ptr (Ptr, nullPtr)+import Foreign.C.Types (CInt(..))+import Foreign.C.String (CString, withCString)+import Control.Exception (bracket)+import Control.Monad (when)+import System.Environment (lookupEnv)+import Data.Maybe (catMaybes)+import qualified Data.ByteString as B+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Encoding.Error as TEE++#ifndef _GNU_SOURCE+#define _GNU_SOURCE+#endif+#include <locale.h>+#include <langinfo.h>+-- macOS declares the per-locale query functions (newlocale / freelocale / nl_langinfo_l) in <xlocale.h> rather than+-- in <locale.h> / <langinfo.h>.+#ifdef __APPLE__+#include <xlocale.h>+#endif++-- | An opaque POSIX @locale_t@ handle.+type CLocale = Ptr ()++foreign import ccall unsafe "newlocale"+ c_newlocale :: CInt -> CString -> CLocale -> IO CLocale++foreign import ccall unsafe "freelocale"+ c_freelocale :: CLocale -> IO ()++foreign import ccall unsafe "nl_langinfo_l"+ c_nl_langinfo_l :: CInt -> CLocale -> IO CString++lcAllMask :: CInt+lcAllMask = #{const LC_ALL_MASK}++monthItems :: [CInt]+monthItems =+ [ #{const MON_1}, #{const MON_2}, #{const MON_3}, #{const MON_4}+ , #{const MON_5}, #{const MON_6}, #{const MON_7}, #{const MON_8}+ , #{const MON_9}, #{const MON_10}, #{const MON_11}, #{const MON_12} ]++abMonthItems :: [CInt]+abMonthItems =+ [ #{const ABMON_1}, #{const ABMON_2}, #{const ABMON_3}, #{const ABMON_4}+ , #{const ABMON_5}, #{const ABMON_6}, #{const ABMON_7}, #{const ABMON_8}+ , #{const ABMON_9}, #{const ABMON_10}, #{const ABMON_11}, #{const ABMON_12} ]++dayItems :: [CInt]+dayItems =+ [ #{const DAY_1}, #{const DAY_2}, #{const DAY_3}, #{const DAY_4}+ , #{const DAY_5}, #{const DAY_6}, #{const DAY_7} ]++abDayItems :: [CInt]+abDayItems =+ [ #{const ABDAY_1}, #{const ABDAY_2}, #{const ABDAY_3}, #{const ABDAY_4}+ , #{const ABDAY_5}, #{const ABDAY_6}, #{const ABDAY_7} ]++itemAM, itemPM, itemDFmt, itemTFmt, itemDTFmt :: CInt+itemAM = #{const AM_STR}+itemPM = #{const PM_STR}+itemDFmt = #{const D_FMT}+itemTFmt = #{const T_FMT}+itemDTFmt = #{const D_T_FMT}++-- | Query one @nl_item@ from a locale and decode it as UTF-8 (leniently). The result is copied into a Haskell 'String'+-- immediately, so it remains valid after the locale is freed.+peekItem :: CLocale -> CInt -> IO String+peekItem loc item = do+ cs <- c_nl_langinfo_l item loc+ if cs == nullPtr+ then return ""+ else T.unpack . TE.decodeUtf8With TEE.lenientDecode <$> B.packCString cs++buildLocale :: String -> CLocale -> IO Locale+buildLocale lid loc = do+ mons <- mapM (peekItem loc) monthItems+ amons <- mapM (peekItem loc) abMonthItems+ days <- mapM (peekItem loc) dayItems+ adays <- mapM (peekItem loc) abDayItems+ am <- peekItem loc itemAM+ pm <- peekItem loc itemPM+ df <- peekItem loc itemDFmt+ tf <- peekItem loc itemTFmt+ dtf <- peekItem loc itemDTFmt+ return Locale+ { localeId = lid+ , monthNames = mons+ , monthNamesShort = amons+ , dayNames = days+ , dayNamesShort = adays+ , amName = am+ , pmName = pm+ , rawDateFormat = df+ , rawTimeFormat = tf+ , rawDateTimeFormat = dtf+ }++-- | Create a fresh @locale_t@ for the given name, run the action, and always free the handle. Returns 'Nothing' when+-- the name does not resolve to an installed locale.+withNewLocale :: String -> (CLocale -> IO a) -> IO (Maybe a)+withNewLocale name act =+ withCString name $ \cname ->+ bracket (c_newlocale lcAllMask cname nullPtr) freeIfNonNull $ \loc ->+ if loc == nullPtr then return Nothing else Just <$> act loc+ where+ freeIfNonNull l = when (l /= nullPtr) (c_freelocale l)++-- | Read a specific locale by name (e.g. @\"de_DE.UTF-8\"@). 'Nothing' if it is not installed on the machine.+loadLocaleByName :: String -> IO (Maybe Locale)+loadLocaleByName name = withNewLocale name (buildLocale name)++-- | Read the process's current locale, as selected by the environment (@LC_ALL@ \/ @LC_TIME@ \/ @LANG@), falling back+-- to the POSIX @C@ locale.+loadCurrentLocale :: IO Locale+loadCurrentLocale = do+ lid <- currentLocaleId+ m <- withNewLocale "" (buildLocale lid)+ case m of+ Just l -> return l+ Nothing -> loadLocaleByName "C" >>= maybe (ioError (userError "loadCurrentLocale: could not load the POSIX C locale")) return++-- | The identifier of the current locale, taken from the first of @LC_ALL@, @LC_TIME@ or @LANG@ that is set to a+-- non-empty value, defaulting to @\"C\"@.+currentLocaleId :: IO String+currentLocaleId = do+ vals <- mapM lookupEnv ["LC_ALL", "LC_TIME", "LANG"]+ return $ case filter (not . null) (catMaybes vals) of+ (x:_) -> x+ [] -> "C"
src/Data/HodaTime/Offset.hs view
@@ -5,13 +5,43 @@ -- License : BSD-style (see the file LICENSE) -- Maintainer : Jason Johnson <jason.johnson.081@gmail.com> -- Stability : experimental--- Portability : TBD+-- Portability : POSIX, Windows -- -- An 'Offset' is a period of time offset from UTC time. This module contains constructors and functions for working with 'Offsets'. -- -- === Clamping -- -- An offset must be between 18 hours and -18 hours (inclusive). If you go outside this range the functions will clamp to the nearest value.+--+-- === Technical discussion: why the components are read-only functions, not lenses+--+-- 'hours', 'minutes' and 'seconds' are plain functions, not lenses. In this library a lens exists to /modify/ a+-- value, and there is no honest way to modify a single component of an 'Offset' in isolation, because an 'Offset' is+-- a single /signed/ count of seconds: the sign belongs to the whole value, not to any one component.+--+-- The subtle part is that /additive/ modification would actually work. Under an increment the component's current+-- value cancels out, so @over minutes (+45)@ reduces to adding 45 minutes to the whole offset — it turns @-01:30@+-- into @-00:45@, exactly as you would hope. But that also makes it /identical/ to @'addClamped' o ('fromMinutes'+-- 45)@: as a lens it would buy nothing over the arithmetic that is already here.+--+-- What a lens /would/ add over those functions is precisely the part that is not well defined for a signed value:+--+-- * Reading a component in isolation (@view minutes@ of @-01:30@): is the minutes part @30@ or @-30@? We answer+-- that for reads by making the accessors /sign-consistent/ — each component carries the offset's sign, so+-- @-01:30@ gives @-1@ hours and @-30@ minutes and @hours*3600 + minutes*60 + seconds@ always reconstructs the+-- total. That is a getter, hence a function.+-- * An /absolute/ set (@set minutes 45@) or a non-additive change (@over minutes (*2)@): here the old value does+-- /not/ cancel, and the minutes slot of a negative offset has no canonical meaning, so there is no honest+-- implementation to offer.+--+-- We also considered a single lens over the whole value (its total seconds). It is coherent, but redundant: an+-- 'Offset' is already just a signed scalar, so 'fromSeconds', 'fromMinutes' and 'fromHours' construct one and+-- 'addClamped' \/ 'minusClamped' do the arithmetic; modifying an 'Offset' embedded in a larger structure is done by+-- using those inside that structure's own modify, so a value lens would not compose any better. It would only save+-- constructing a throwaway 'Offset' for a bit of math — not enough to justify a second way to do the same thing.+--+-- So: read a component with the functions here; build or adjust an 'Offset' as a whole with the constructors and+-- 'addClamped' \/ 'minusClamped'. (Display is the job of "Data.HodaTime.Pattern", not of these accessors.) ---------------------------------------------------------------------------- module Data.HodaTime.Offset (@@ -22,7 +52,9 @@ ,fromSeconds ,fromMinutes ,fromHours- -- * Lenses+ -- * Accessors+ --+ -- | Read-only functions (not lenses); see the /Technical discussion/ in the module header for why. ,seconds ,minutes ,hours@@ -33,7 +65,8 @@ where import Data.HodaTime.Offset.Internal-import Data.HodaTime.Internal (secondsFromMinutes, secondsFromHours, clamp, hoursFromSecs, minutesFromSecs, secondsFromSecs)+import Data.HodaTime.Internal (secondsFromMinutes, secondsFromHours, clamp)+import Data.HodaTime.Constants (secondsPerHour, secondsPerMinute) -- Offset specific constants @@ -54,17 +87,20 @@ fromHours :: Integral a => a -> Offset fromHours = Offset . secondsFromHours . clamp minOffsetHours maxOffsetHours --- | Lens for the seconds component of the 'Offset'-seconds :: Functor f => (Int -> f Int) -> Offset -> f Offset-seconds f (Offset secs) = secondsFromSecs fromSeconds f secs-{-# INLINE seconds #-}+-- Accessors (read-only functions, not lenses; see the Technical discussion in the module header for the full+-- rationale). Implementation note: these are sign-consistent -- each component carries the offset's sign, computed+-- with truncate-toward-zero `quot`/`rem`, NOT the floor `div`/`mod` used by the shared LocalTime helper (which is+-- correct there because a LocalTime's seconds are never negative, but would give the wrong split for a negative+-- offset, e.g. -01:30 -> hours -2, minutes +30). --- | Lens for the minutes component of the 'Offset'-minutes :: Functor f => (Int -> f Int) -> Offset -> f Offset-minutes f (Offset secs) = minutesFromSecs fromSeconds f secs-{-# INLINE minutes #-}+-- | The seconds component of the 'Offset' (carries the sign; e.g. @-1@ for a @-00:00:01@ offset).+seconds :: Offset -> Int+seconds (Offset secs) = secs `rem` secondsPerMinute --- | Lens for the hours component of the 'Offset'-hours :: Functor f => (Int -> f Int) -> Offset -> f Offset-hours f (Offset secs) = hoursFromSecs fromSeconds f secs-{-# INLINE hours #-}+-- | The minutes component of the 'Offset' (carries the sign; e.g. @-30@ for a @-01:30@ offset).+minutes :: Offset -> Int+minutes (Offset secs) = secs `rem` secondsPerHour `quot` secondsPerMinute++-- | The hours component of the 'Offset' (carries the sign; e.g. @-1@ for a @-01:30@ offset).+hours :: Offset -> Int+hours (Offset secs) = secs `quot` secondsPerHour
src/Data/HodaTime/Offset/Internal.hs view
@@ -17,10 +17,21 @@ import qualified Data.HodaTime.Duration.Internal as D (fromSeconds) import Data.HodaTime.Constants (secondsPerHour) import Data.HodaTime.Internal (secondsFromSeconds, clamp)+import Control.DeepSeq (NFData(..))+import Data.Hashable (Hashable(..)) -- | An 'Offset' from UTC in seconds. newtype Offset = Offset { offsetSeconds :: Int } -- TODO: Any reason to make this 32 bit? We don't need more space than 32 bit- deriving (Eq, Ord, Show) -- TODO: Remove Show+ deriving (Eq, Ord)++instance Show Offset where+ showsPrec p (Offset s) = showParen (p > 10) $ showString "fromSeconds " . showsPrec 11 s++instance NFData Offset where+ rnf (Offset s) = rnf s++instance Hashable Offset where+ hashWithSalt s (Offset secs) = hashWithSalt s secs -- Offset specific constants
src/Data/HodaTime/OffsetDateTime.hs view
@@ -1,3 +1,17 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.OffsetDateTime+-- Copyright : (C) 2016 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- An 'OffsetDateTime' is a date and time combined with an offset from UTC time. 'OffsetDateTime' is the form that HTTP uses to deal with dates and times.+----------------------------------------------------------------------------+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-} module Data.HodaTime.OffsetDateTime ( -- * Types@@ -7,37 +21,64 @@ ,fromCalendarDateTimeWithOffset -- * Math -- * Conversion+ ,toCalendarDateTime+ ,offset ) where import Data.HodaTime.Offset.Internal import Data.HodaTime.Instant.Internal (Instant)-import Data.HodaTime.CalendarDateTime.Internal (CalendarDateTime, IsCalendarDateTime(..))+import Data.HodaTime.CalendarDateTime.Internal (CalendarDateTime, IsCalendarDateTime(..), Date) import Data.HodaTime.ZonedDateTime.Internal (ZonedDateTime(..))-import Data.HodaTime.TimeZone.Internal (TimeZone(..), TZIdentifier(..), TransitionInfo, fixedOffsetZone)+import Data.HodaTime.TimeZone.Internal (TimeZone(..), TZIdentifier(..), TransitionInfo, tiUtcOffset, fixedOffsetZone)+import Data.Hashable (Hashable(..)) -- | A 'CalendarDateTime' with a UTC offset. This is the format used by e.g. HTTP. This type has a fixed 'TimeZone' with the name "UTC(+/-)offset". If the offset is -- empty, the name of the 'TimeZone' will be UTC newtype OffsetDateTime cal = OffsetDateTime (ZonedDateTime cal)- deriving (Eq, Show) -- TODO: Remove Show +deriving instance Eq (Date cal) => Eq (OffsetDateTime cal)+deriving instance (IsCalendarDateTime cal, Eq (Date cal)) => Ord (OffsetDateTime cal)++-- | Renders an 'OffsetDateTime' as the 'fromInstantWithOffset' call that reconstructs it.+instance IsCalendarDateTime cal => Show (OffsetDateTime cal) where+ showsPrec p (OffsetDateTime (ZonedDateTime cdt _ ti)) = showParen (p > 10) $+ showString "fromInstantWithOffset " . showsPrec 11 inst . showChar ' ' . showsPrec 11 off+ where+ off = tiUtcOffset ti+ inst = adjustInstant (negateOffset off) (toUnadjustedInstant cdt)+ negateOffset (Offset s) = Offset (negate s)++-- NOTE: no 'NFData' instance is provided because 'OffsetDateTime' embeds a 'TimeZone', whose fingertree-based+-- transition maps cannot be forced (see 'Data.HodaTime.TimeZone.Internal').+instance Hashable (Date cal) => Hashable (OffsetDateTime cal) where+ hashWithSalt s (OffsetDateTime z) = hashWithSalt s z+ -- | Create an 'OffsetDateTime' from an 'Instant' and an 'Offset'. fromInstantWithOffset :: IsCalendarDateTime cal => Instant -> Offset -> OffsetDateTime cal-fromInstantWithOffset inst offset = OffsetDateTime $ ZonedDateTime cdt tz tInfo+fromInstantWithOffset inst offset' = OffsetDateTime $ ZonedDateTime cdt tz tInfo where- (tz, tInfo) = makeFixedTimeZone offset- cdt = fromAdjustedInstant . adjustInstant offset $ inst+ (tz, tInfo) = makeFixedTimeZone offset'+ cdt = fromAdjustedInstant . adjustInstant offset' $ inst -- | Create an 'OffsetDateTime' from a 'CalendarDateTime' and an 'Offset'. fromCalendarDateTimeWithOffset :: CalendarDateTime cal -> Offset -> OffsetDateTime cal-fromCalendarDateTimeWithOffset cdt offset = OffsetDateTime $ ZonedDateTime cdt tz tInfo+fromCalendarDateTimeWithOffset cdt offset' = OffsetDateTime $ ZonedDateTime cdt tz tInfo where- (tz, tInfo) = makeFixedTimeZone offset+ (tz, tInfo) = makeFixedTimeZone offset' +-- | The local (wall-clock) 'CalendarDateTime' of the 'OffsetDateTime', before the offset is applied.+toCalendarDateTime :: OffsetDateTime cal -> CalendarDateTime cal+toCalendarDateTime (OffsetDateTime zdt) = zdtCalendarDateTime zdt++-- | The UTC 'Offset' of the 'OffsetDateTime'.+offset :: OffsetDateTime cal -> Offset+offset (OffsetDateTime zdt) = tiUtcOffset . zdtActiveTransition $ zdt+ -- helper functions makeFixedTimeZone :: Offset -> (TimeZone, TransitionInfo)-makeFixedTimeZone offset = (TimeZone (Zone tzName) utcM calDateM, tInfo)+makeFixedTimeZone offset' = (TimeZone (Zone tzName) utcM calDateM, tInfo) where- tzName = toStringRep offset- (utcM, calDateM, tInfo) = fixedOffsetZone tzName offset+ tzName = toStringRep offset'+ (utcM, calDateM, tInfo) = fixedOffsetZone tzName offset'
+ src/Data/HodaTime/Pattern.hs view
@@ -0,0 +1,56 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.Pattern+-- Copyright : (C) 2016 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- A 'Pattern' is used to parse and format types in this library.+--+-- === Cookbook+--+-- ==== Format and parse with a standard pattern+--+-- A 'Pattern' both formats and parses. @pR@ is the ISO-8601 round-trip date pattern.+--+-- >>> format pR <$> calendarDate 23 April 2024+-- Just "2024-04-23"+-- >>> parse pR "2024-04-23" :: Maybe (CalendarDate Gregorian)+-- Just (fromJust (Gregorian.calendarDate 23 April 2024))+--+-- ==== Build a custom pattern+--+-- Patterns compose: field patterns are joined with @\<>@ and literals inserted with @\<%@. This builds a custom+-- \"23 Apr 2024\" layout (day, abbreviated month, year):+--+-- >>> format (pdd <% char ' ' <> pMMM <% char ' ' <> pyyyy) <$> calendarDate 23 April 2024+-- Just "23 Apr 2024"+----------------------------------------------------------------------------+module Data.HodaTime.Pattern+(+ -- * Types+ Pattern(..)+ -- * Parsing / Formatting+ ,parse+ ,parse'+ ,format+ -- * Standard Patterns+ -- * Custom Patterns+ --+ -- | Used to create specialized patterns+ ,string+ ,char+ ,(<%)+ -- * Exceptions+ ,ParseFailedException+)+where++import Data.HodaTime.Pattern.Internal++-- $setup+-- >>> import Data.HodaTime.Calendar.Gregorian (calendarDate, Month(..), Gregorian)+-- >>> import Data.HodaTime.CalendarDate (CalendarDate)+-- >>> import Data.HodaTime.Pattern.CalendarDate (pR, pdd, pMMM, pyyyy)
+ src/Data/HodaTime/Pattern/ApplyParse.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+module Data.HodaTime.Pattern.ApplyParse+(+ DefaultForParse(..)+ ,ApplyParse(..)+ ,ZonedDateTimeInfo(..)+ ,DateTimeInfo(..)+ ,TimeInfo(..)+ ,DateInfo(..)+)+where++import Data.HodaTime.LocalTime.Internal (LocalTime(..), localTime)+import Data.HodaTime.CalendarDateTime.Internal (IsCalendar(..), Date, CalendarDateTime(..), at)+import Data.HodaTime.Instant.Internal (Instant(..), Duration(..))+import Data.HodaTime.Offset.Internal (Offset, empty)+import Data.HodaTime.OffsetDateTime (OffsetDateTime, fromCalendarDateTimeWithOffset)+import Data.HodaTime.Pattern.ParseTypes+import Control.Monad.Catch (MonadThrow)++defaultTime :: TimeInfo+defaultTime = TimeInfo 0 0 0 0++-- Class++class DefaultForParse d where+ getDefault :: d++instance DefaultForParse LocalTime where+ getDefault = LocalTime 0 0++instance IsCalendar cal => DefaultForParse (Date cal) where+ getDefault = fromDays 0 -- the calendar's epoch; parsing overwrites the fields, so any valid date works++instance IsCalendar cal => DefaultForParse (CalendarDateTime cal) where+ getDefault = getDefault `at` getDefault++instance DefaultForParse Instant where+ getDefault = Instant 0 0 0 -- the Instant epoch (1 March 2000); parsing overwrites the fields++instance DefaultForParse Offset where+ getDefault = empty -- UTC; a full offset pattern replaces this outright++instance IsCalendar cal => DefaultForParse (OffsetDateTime cal) where+ getDefault = fromCalendarDateTimeWithOffset getDefault empty -- fully replaced by the pattern++instance DefaultForParse Duration where+ getDefault = Duration (Instant 0 0 0) -- the zero duration; fully replaced by the pattern+++class ApplyParse a b | b -> a where+ applyParse :: MonadThrow m => (a -> a) -> m b++instance ApplyParse TimeInfo LocalTime where+ applyParse f = localTime (_hour ti) (_minute ti) (_second ti) (_nanoSecond ti)+ where+ ti = f defaultTime++instance IsCalendar cal => ApplyParse (DateInfo cal) (Date cal) where+ applyParse _ = undefined++{- class ApplyParse r where+ type StartData r+ getStartData :: StartData r+ applyParse :: StartData r -> r++instance ApplyParse LocalTime where+ type StartData LocalTime = TimeInfo+ getStartData = defaultTime++instance IsCalendar cal => ApplyParse (CalendarDate cal) where+ type StartData LocalTime = DateInfo cal+ getStartData = defaultDate++instance IsCalendar cal => ApplyParse (CalendarDateTime cal) where+ type StartData r = DateTimeInfo+ getStartData = defaultDateTime++instance IsCalendar cal => ApplyParse (ZonedDateTimeInfo cal) where+ type StartData r = ZonedDateTimeInfo+ getStartData = defaultDateTime "UTC" -}
+ src/Data/HodaTime/Pattern/CalendarDate.hs view
@@ -0,0 +1,213 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.Pattern.CalendarDate+-- Copyright : (C) 2017 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- Patterns for a 'Data.HodaTime.CalendarDate.CalendarDate': the standard date layouts (@pd@, @pD@, @pR@) together with+-- the individual field patterns (@pyyyy@, @pMM@, @pMMMM@, @pdd@, @pdddd@ and friends) from which custom date patterns+-- are built. The primed variants (@pMMMM'@, @pddd'@ …) take a 'Data.HodaTime.Locale.Locale' and use its+-- month\/weekday names.+----------------------------------------------------------------------------+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+module Data.HodaTime.Pattern.CalendarDate+(+ -- * Standard Patterns+ pd+ ,pD+ ,pR+ ,pmonthDay+ ,pyearMonth+ -- * Custom Patterns+ --+ -- | Used to create specialized patterns.+ ,pyear+ ,pyyyy+ ,pyy+ ,pmonthNum+ ,pMM+ ,pMMM+ ,pMMMM+ ,pMMM'+ ,pMMMM'+ ,pMonthName+ ,pday+ ,pdd+ ,pdaySpace+ ,pddd+ ,pdddd+ ,pddd'+ ,pdddd'+ ,pDayName+)+where++import Data.HodaTime.Pattern.Internal+import Data.HodaTime.CalendarDateTime.Internal (HasDate, Month, IsCalendar, monthl, dayOfWeek, DoW)+import qualified Data.HodaTime.CalendarDateTime.Internal as CDT (day, year)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as TLB+import Text.Parsec (choice, try, (<?>))+import Formatting (later)+import Data.HodaTime.Internal.Lens (view, set)+import Data.HodaTime.Locale.Internal (Locale(..))++-- d1 = maybe (error "duh") id $ calendarDate 1 January 2000+-- d2 = maybe (error "duh") id $ calendarDate 3 March 2020+-- format Data.HodaTime.Pattern.CalendarDate.date d1+-- format Data.HodaTime.Pattern.CalendarDate.date d2+-- parse Data.HodaTime.Pattern.CalendarDate.date "2000/March/01" :: IO (CalendarDate Gregorian)++-- | Absolute year of at least @w@ digits. Width @1@ is the no-padding case (reads 1-4 digits, so both @"3"@ and+-- @"2020"@ parse; formats with no leading zeros); width @n >= 2@ reads exactly @n@ digits. The value is always the+-- literal year and is never truncated, so this is the /strict/ counterpart to 'pyy' (which does two-digit century+-- inference). Values 0-9999 (note: not all dates will be valid in all calendars, if the date is too early it will+-- clamp to earliest valid date)+pyear :: HasDate d => Int -> Pattern (d -> d) (d -> String) String+pyear w = pat_lens CDT.year (pDigits w 4 0 9999) (f_shown_pad w) "year: 0-9999"++-- | Absolute year in exactly 4 digits (@'pyear' 4@); values 0000-9999.+pyyyy :: HasDate d => Pattern (d -> d) (d -> String) String+pyyyy = pyear 4++-- | Two-digit year of the era with the century inferred, mirroring Noda Time's @yy@ specifier (contrast with the+-- strict, absolute 'pyear'). Formatting emits @year `mod` 100@ zero-padded to two digits, so @2020@ becomes @"20"@+-- and @2005@ becomes @"05"@. Parsing reads exactly two digits and expands them to the year with those final two+-- digits that is closest to the parse /template/ (the default passed to 'parse', whose year is 2000 for the Gregorian+-- epoch), breaking ties toward the future. With the default template this maps @"20"@ to @2020@ and @"99"@ to+-- @1999@; supply a different template via 'parse'' to slide the 100-year window.+pyy :: HasDate d => Pattern (d -> d) (d -> String) String+pyy = Pattern par fmt+ where+ par = expand <$> pDigits 2 2 0 99 <?> "year: two digits (century inferred)"+ expand v d = set CDT.year (fullYear (view CDT.year d) v) d+ fmt = f_shown_pad 2 (\d -> view CDT.year d `mod` 100)+ fullYear t v = base + k * 100+ where+ base = (t `div` 100) * 100 + v+ k = (t - base + 50) `div` 100++-- | Month of year as a number of @w@ digits, zero-padded; a width of @1@ means /no padding/. Values 1-12.+pmonthNum :: HasDate d => Int -> Pattern (d -> d) (d -> String) String+pmonthNum w = pat_lens monthl (subtract 1 <$> pDigits w 2 1 12) fmt "month: 1-12"+ where+ fmt x = f_shown_pad w (succ . x)++-- | Month of year as a zero-padded number (@'pmonthNum' 2@); values 01-12.+pMM :: HasDate d => Pattern (d -> d) (d -> String) String+pMM = pmonthNum 2++-- | Full month name, parsed case-insensitively. Formats in title case+pMMMM :: forall cal d c. (d ~ c cal, IsCalendar cal, HasDate d, Bounded (Month cal), Read (Month cal), Show (Month cal), Enum (Month cal)) => Pattern (d -> d) (d -> String) String+pMMMM = pat_lens monthl p' fmt' $ "month: " ++ show fm ++ "-" ++ show lm+ where+ fm = minBound :: Month cal+ lm = maxBound :: Month cal+ months = choice . fmap (try . caseInsensitiveString . show) $ [fm..lm]+ p' = (fromEnum :: Month cal -> Int) . read <$> months+ fmt' x = later (TLB.fromText . T.pack . show . (toEnum :: Int -> Month cal) . x)+-- | Abbreviated month name (e.g. @Jan@), parsed case-insensitively and formatted in title case.+--+-- NOTE: the abbreviation is simply the first three letters of the month name, so in calendars where two months share+-- a three-letter prefix (e.g. the Hebrew @AdarI@ and @Adar@) parsing is ambiguous and resolves to the first match in+-- month order. Use 'pMMMM' (full name) or 'pMM' (number) when you need an unambiguous round-trip.+pMMM :: forall cal d c. (d ~ c cal, IsCalendar cal, HasDate d, Bounded (Month cal), Show (Month cal), Enum (Month cal)) => Pattern (d -> d) (d -> String) String+pMMM = pat_lens monthl p' fmt' $ "month: " ++ abbr fm ++ "-" ++ abbr lm+ where+ fm = minBound :: Month cal+ lm = maxBound :: Month cal+ abbr = take 3 . show+ p' = choice . fmap (\m -> fromEnum m <$ try (caseInsensitiveString (abbr m))) $ [fm..lm]+ fmt' x = later (TLB.fromText . T.pack . abbr . (toEnum :: Int -> Month cal) . x)+-- | Day of month of @w@ digits, zero-padded; a width of @1@ means /no padding/. Values 1-31.+pday :: HasDate d => Int -> Pattern (d -> d) (d -> String) String+pday w = pat_lens CDT.day (pDigits w 2 1 31) (f_shown_pad w) "day: 1-31"++-- | Day of month, zero-padded (@'pday' 2@); values 01-31.+pdd :: HasDate d => Pattern (d -> d) (d -> String) String+pdd = pday 2++-- | Day of month, /space/-padded to two characters (the @strftime@ @%e@ convention), e.g. @\" 3\"@ or @\"15\"@. On+-- parse it also accepts the bare and zero-padded forms.+pdaySpace :: HasDate d => Pattern (d -> d) (d -> String) String+pdaySpace = pat_lens CDT.day (pDigitsSpace 2 1 31) (f_shown_spad 2) "day: 1-31 (space padded)"++-- | Abbreviated day of week name (e.g. @Mon@), parsed case-insensitively and formatted in title case. Note: on parse+-- this only /consumes/ the weekday, it is not validated against the day\/month\/year (which fully determine the date).+pddd :: forall d. (HasDate d, Show (DoW d), Enum (DoW d), Bounded (DoW d)) => Pattern (d -> d) (d -> String) String+pddd = Pattern par fmt+ where+ names = [minBound .. maxBound] :: [DoW d]+ abbr = take 3 . show+ par = id <$ (choice . fmap (try . caseInsensitiveString . abbr) $ names)+ fmt = later (TLB.fromText . T.pack . abbr . dayOfWeek)++-- | Full day of week name (e.g. @Monday@), parsed case-insensitively and formatted in title case. Note: on parse this+-- only /consumes/ the weekday, it is not validated against the day\/month\/year (which fully determine the date).+pdddd :: forall d. (HasDate d, Show (DoW d), Enum (DoW d), Bounded (DoW d)) => Pattern (d -> d) (d -> String) String+pdddd = Pattern par fmt+ where+ names = [minBound .. maxBound] :: [DoW d]+ par = id <$ (choice . fmap (try . caseInsensitiveString . show) $ names)+ fmt = later (TLB.fromText . T.pack . show . dayOfWeek)++-- | This is the short date pattern, currently defined as "dd/MM/yyyy".+pd :: HasDate d => Pattern (d -> d) (d -> String) String+pd = pdd <% char '/' <> pMM <% char '/' <> pyyyy++-- | This is the long date pattern, currently defined as "dddd, dd MMMM yyyy".+pD :: (HasDate (c cal), IsCalendar cal, Bounded (Month cal), Read (Month cal), Show (Month cal), Enum (Month cal), Show (DoW (c cal)), Enum (DoW (c cal)), Bounded (DoW (c cal))) => Pattern (c cal -> c cal) (c cal -> String) String+pD = pdddd <% string ", " <> pdd <% char ' ' <> pMMMM <% char ' ' <> pyyyy++-- | The ISO-8601 round-trippable date pattern, "yyyy-MM-dd".+pR :: HasDate d => Pattern (d -> d) (d -> String) String+pR = pyyyy <% char '-' <> pMM <% char '-' <> pdd++-- | The month-and-day partial pattern (no year), currently "MMMM dd", e.g. @March 03@.+pmonthDay :: (HasDate (c cal), IsCalendar cal, Bounded (Month cal), Read (Month cal), Show (Month cal), Enum (Month cal)) => Pattern (c cal -> c cal) (c cal -> String) String+pmonthDay = pMMMM <% char ' ' <> pdd++-- | The year-and-month partial pattern (no day), currently "yyyy MMMM", e.g. @2020 March@.+pyearMonth :: (HasDate (c cal), IsCalendar cal, Bounded (Month cal), Read (Month cal), Show (Month cal), Enum (Month cal)) => Pattern (c cal -> c cal) (c cal -> String) String+pyearMonth = pyyyy <% char ' ' <> pMMMM++-- | Format and parse the month using an explicit list of names (index 0 is the calendar's first month), instead of the+-- calendar's built-in English constructor names. This is the calendar-agnostic core behind the locale-aware 'pMMMM''+-- and 'pMMM''; pass 'Data.HodaTime.Locale.monthNames' (or @monthNamesShort@) for OS locale names, or any list of the+-- right length for a custom calendar. Parsing is case-insensitive and, like 'pMMMM', tries the names in order.+pMonthName :: HasDate d => [String] -> Pattern (d -> d) (d -> String) String+pMonthName names = pat_lens monthl par fmt "month name"+ where+ par = choice . fmap (\(i, n) -> i <$ try (caseInsensitiveString n)) $ zip [0 :: Int ..] names+ fmt x = later (TLB.fromText . T.pack . (names !!) . x)++-- | Format and parse the day-of-week using an explicit list of names (index 0 = Sunday), instead of the calendar's+-- built-in English constructor names. This is the calendar-agnostic core behind 'pdddd'' \/ 'pddd''. As with+-- 'pdddd', parsing only /consumes/ the weekday; it is not validated against the day\/month\/year.+pDayName :: (HasDate d, Enum (DoW d)) => [String] -> Pattern (d -> d) (d -> String) String+pDayName names = Pattern par fmt+ where+ par = id <$ (choice . fmap (try . caseInsensitiveString) $ names)+ fmt = later (TLB.fromText . T.pack . (names !!) . fromEnum . dayOfWeek)++-- | Full month name in the given 'Locale' (e.g. @März@); the locale-aware counterpart to 'pMMMM'.+pMMMM' :: HasDate d => Locale -> Pattern (d -> d) (d -> String) String+pMMMM' = pMonthName . monthNames++-- | Abbreviated month name in the given 'Locale'; the locale-aware counterpart to 'pMMM'.+pMMM' :: HasDate d => Locale -> Pattern (d -> d) (d -> String) String+pMMM' = pMonthName . monthNamesShort++-- | Full weekday name in the given 'Locale' (e.g. @Sonntag@); the locale-aware counterpart to 'pdddd'.+pdddd' :: (HasDate d, Enum (DoW d)) => Locale -> Pattern (d -> d) (d -> String) String+pdddd' = pDayName . dayNames++-- | Abbreviated weekday name in the given 'Locale'; the locale-aware counterpart to 'pddd'.+pddd' :: (HasDate d, Enum (DoW d)) => Locale -> Pattern (d -> d) (d -> String) String+pddd' = pDayName . dayNamesShort
+ src/Data/HodaTime/Pattern/CalendarDateTime.hs view
@@ -0,0 +1,61 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.Pattern.CalendarDateTime+-- Copyright : (C) 2017 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- Patterns for a 'Data.HodaTime.CalendarDateTime.CalendarDateTime': the combined date-and-time layouts (@ps@, @po@,+-- @pf@\/@pF@, @pg@\/@pG@), each of which glues a date pattern to a time pattern.+----------------------------------------------------------------------------+{-# LANGUAGE FlexibleContexts #-}+module Data.HodaTime.Pattern.CalendarDateTime+(+ -- * Standard Patterns+ ps+ ,po+ ,pf+ ,pF+ ,pg+ ,pG+ -- * Custom Patterns+ --+ -- | Use combination of `Data.HodaTime.Pattern.CalendarDate` and `Data.HodaTime.Pattern.LocalTime` patterns+)+where++import Data.HodaTime.Pattern.Internal+import Data.HodaTime.CalendarDateTime.Internal (HasDate, Month, IsCalendar, DoW)+import Data.HodaTime.LocalTime.Internal (HasLocalTime)+import Data.HodaTime.Pattern.LocalTime+import Data.HodaTime.Pattern.CalendarDate++-- d1 = maybe (error "duh") id $ on <$> localTime 1 2 3 0 <*> calendarDate 1 January 2000+-- d2 = maybe (error "duh") id $ on <$> localTime 1 2 3 0 <*> calendarDate 3 March 2020+-- format ps d1+-- format ps d2+-- parse ps "2000/March/01" :: IO (CalendarDate Gregorian)++-- | The sortable pattern, which is always "yyyy'-'MM'-'dd'T'HH':'mm':'ss". (Note: this is only truly sortable for years within the range [0-9999].)+ps :: (HasLocalTime dt, HasDate dt) => Pattern (dt -> dt) (dt -> String) String+ps = pyyyy <% char '-' <> pMM <% char '-' <> pdd <% char 'T' <> pHH <% char ':' <> pmm <% char ':' <> pss+-- | The ISO-8601 round-trippable date\/time pattern, "yyyy'-'MM'-'dd'T'HH':'mm':'ss'.'fffffffff" (nanosecond precision).+po :: (HasLocalTime dt, HasDate dt) => Pattern (dt -> dt) (dt -> String) String+po = ps <% char '.' <> pfrac 9+-- | The long date pattern followed by a space, followed by the short time pattern.+pf :: (HasLocalTime (c cal), HasDate (c cal), IsCalendar cal, Bounded (Month cal), Read (Month cal), Show (Month cal), Enum (Month cal), Show (DoW (c cal)), Enum (DoW (c cal)), Bounded (DoW (c cal))) => Pattern (c cal -> c cal) (c cal -> String) String+pf = pD <% char ' ' <> pt++-- | The full date and time pattern. This is currently "dddd, dd MMMM yyyy HH:mm:ss".+pF :: (HasLocalTime (c cal), HasDate (c cal), IsCalendar cal, Bounded (Month cal), Read (Month cal), Show (Month cal), Enum (Month cal), Show (DoW (c cal)), Enum (DoW (c cal)), Bounded (DoW (c cal))) => Pattern (c cal -> c cal) (c cal -> String) String+pF = pD <% char ' ' <> pT++-- | The short date pattern followed by a space, followed by the short time pattern.+pg :: (HasLocalTime dt, HasDate dt) => Pattern (dt -> dt) (dt -> String) String+pg = pd <% char ' ' <> pt++-- | The short date pattern followed by a space, followed by the long time pattern.+pG :: (HasLocalTime dt, HasDate dt) => Pattern (dt -> dt) (dt -> String) String+pG = pd <% char ' ' <> pT
+ src/Data/HodaTime/Pattern/Duration.hs view
@@ -0,0 +1,99 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.Pattern.Duration+-- Copyright : (C) 2017 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- Patterns for a 'Data.HodaTime.Duration.Duration', rendered as @[-]D:HH:mm:ss@; @pDurationNano@ additionally carries+-- the fractional second down to the nanosecond.+----------------------------------------------------------------------------+module Data.HodaTime.Pattern.Duration+(+ -- * Standard Patterns+ pDuration+ ,pDurationNano+)+where++import Data.HodaTime.Pattern.Internal (Pattern(..), p_sixty)+import Data.HodaTime.Duration.Internal (Duration(..))+import qualified Data.HodaTime.Duration as Dur (fromSeconds, fromNanoseconds, add)+import Data.HodaTime.Instant.Internal (Instant(..))+import Data.HodaTime.Constants (secondsPerDay, nsecsPerSecond)+import Formatting (Format, later)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as TLB+import Text.Parsec (Parsec, many1, count, digit, option, (<?>))+import qualified Text.Parsec as P (char)++-- d1 = fromStandardDays 1 `Dur.add` fromSeconds 30+-- format pDuration d1 -- "1:00:00:30"+-- parse pDuration "-0:00:00:30"++type Parser a = Parsec String () a++-- DESIGN NOTE: like 'Data.HodaTime.Offset.Offset', a 'Duration' is a /signed/ quantity whose sign belongs to the+-- whole value, not to any one component — and it is stored floor-style (a signed day count plus /non-negative/+-- normalized sub-day seconds and nanoseconds, so e.g. -30s is stored as -1 day + 86370s). So we do not decompose it+-- with independent field lenses; instead both directions treat it as a whole: the signed total is computed once (in+-- 'Integer', to interpret the floor representation correctly and to avoid overflow), then formatting emits the sign+-- followed by the magnitude, and parsing reads the sign and all components and rebuilds via 'Dur.fromSeconds' /+-- 'Dur.fromNanoseconds' (which re-normalize). Hence the parser's setter is 'const': the text fully determines the+-- value.++-- | The duration pattern @[-]D:HH:mm:ss@ (days, hours, minutes, seconds; a leading @-@ only for negative durations),+-- e.g. @1:00:00:30@ or @-0:00:00:30@.+pDuration :: Pattern (Duration -> Duration) (Duration -> String) String+pDuration = Pattern (const <$> durationParser False <?> "duration: [-]D:HH:mm:ss") (durationFormat False)++-- | Like 'pDuration' but with a nanosecond fraction, @[-]D:HH:mm:ss.fffffffff@.+pDurationNano :: Pattern (Duration -> Duration) (Duration -> String) String+pDurationNano = Pattern (const <$> durationParser True <?> "duration: [-]D:HH:mm:ss.fffffffff") (durationFormat True)++-- helpers++-- | Decompose into @(isNegative, days, hours, minutes, seconds, nanoseconds)@ as non-negative magnitudes.+durComponents :: Duration -> (Bool, Integer, Integer, Integer, Integer, Integer)+durComponents (Duration (Instant days secs nsecs)) = (total < 0, d, h, m, s, ns)+ where+ nsPerSec = nsecsPerSecond :: Integer+ nsPerDay = (secondsPerDay :: Integer) * nsPerSec+ total = fromIntegral days * nsPerDay + fromIntegral secs * nsPerSec + fromIntegral nsecs+ a = abs total+ (totalSec, ns) = a `divMod` nsPerSec+ (totalMin, s) = totalSec `divMod` 60+ (totalHr, m) = totalMin `divMod` 60+ (d, h) = totalHr `divMod` 24++durationFormat :: Bool -> Format String (Duration -> String)+durationFormat withFrac = later (TLB.fromText . T.pack . render)+ where+ render dur = sign ++ show d ++ ":" ++ pad2 h ++ ":" ++ pad2 m ++ ":" ++ pad2 s ++ fracPart+ where+ (neg, d, h, m, s, ns) = durComponents dur+ sign = if neg then "-" else ""+ fracPart = if withFrac then "." ++ padN 9 ns else ""+ pad2 = padN 2+ padN n x = let str = show x in replicate (n - length str) '0' ++ str++durationParser :: Bool -> Parser Duration+durationParser withFrac = do+ neg <- option False (True <$ P.char '-')+ d <- readInt <$> many1 digit+ _ <- P.char ':'+ h <- twoDigit+ _ <- P.char ':'+ m <- p_sixty+ _ <- P.char ':'+ s <- p_sixty+ ns <- if withFrac then P.char '.' *> (readInt <$> count 9 digit) else pure 0+ let sign = if neg then -1 else 1+ totalSec = sign * (((d * 24 + h) * 60 + m) * 60 + s)+ signedNs = sign * ns+ return $ Dur.fromSeconds totalSec `Dur.add` Dur.fromNanoseconds signedNs+ where+ twoDigit = readInt <$> count 2 digit+ readInt = read :: String -> Int
+ src/Data/HodaTime/Pattern/Instant.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.Pattern.Instant+-- Copyright : (C) 2017 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- Patterns for an 'Data.HodaTime.Instant.Instant', rendered as ISO-8601 UTC (@yyyy-MM-ddTHH:mm:ssZ@); @pInstantNano@+-- additionally carries the fractional second down to the nanosecond.+----------------------------------------------------------------------------+{-# LANGUAGE FlexibleContexts #-}+module Data.HodaTime.Pattern.Instant+(+ -- * Standard Patterns+ pInstant+ ,pInstantNano+ -- * Custom Patterns+ --+ -- | Build an 'Instant' pattern from any Gregorian 'CalendarDateTime' pattern, treating the instant as UTC.+ ,instantPattern+)+where++import Data.HodaTime.Pattern.Internal (Pattern, dimapP, (<%), char)+import Data.HodaTime.Pattern.CalendarDateTime (ps, po)+import Data.HodaTime.Instant.Internal (Instant)+import Data.HodaTime.CalendarDateTime.Internal (CalendarDateTime, IsCalendarDateTime(..))+import Data.HodaTime.Calendar.Gregorian (Gregorian)++-- | Adapt a Gregorian 'CalendarDateTime' pattern into an 'Instant' pattern. The instant is treated as UTC: it is+-- projected to its unadjusted Gregorian 'CalendarDateTime' for formatting, and the parsed 'CalendarDateTime' is+-- taken back to an 'Instant' without any offset.+instantPattern+ :: Pattern (CalendarDateTime Gregorian -> CalendarDateTime Gregorian) (CalendarDateTime Gregorian -> String) String+ -> Pattern (Instant -> Instant) (Instant -> String) String+instantPattern = dimapP fromAdjustedInstant toUnadjustedInstant++-- | The ISO-8601 UTC instant pattern, @yyyy-MM-ddTHH:mm:ssZ@ (the trailing @Z@ marks it as UTC).+pInstant :: Pattern (Instant -> Instant) (Instant -> String) String+pInstant = instantPattern (ps <% char 'Z')++-- | Like 'pInstant' but carried down to the nanosecond, @yyyy-MM-ddTHH:mm:ss.fffffffffZ@.+pInstantNano :: Pattern (Instant -> Instant) (Instant -> String) String+pInstantNano = instantPattern (po <% char 'Z')
+ src/Data/HodaTime/Pattern/Internal.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}+{-# HLINT ignore "Use camelCase" #-}++module Data.HodaTime.Pattern.Internal+(+ Pattern(..)+ ,DefaultForParse(..)+ ,Parser+ ,parse+ ,parse'+ ,parse''+ ,format+ ,(<%)+ ,dimapP+ ,pairP+ ,string+ ,char+ ,pat_lens+ ,pat_lens'+ ,digitsToInt+ ,p_sixty+ ,f_shown+ ,f_shown_two+ ,f_shown_pad+ ,f_shown_spad+ ,pDigits+ ,pDigitsSpace+ ,caseInsensitiveString+ ,ParseFailedException(..)+)+where++import Control.Monad.Catch (MonadThrow, throwM)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as TLB+import Text.Parsec hiding (many, optional, (<|>), parse, string, char)+import qualified Text.Parsec as P (string, char)+import Control.Applicative ((<|>))+import Data.Char (toLower, toUpper)+import Formatting (Format, later, formatToString, left, (%.), (%), now)+import Data.String (fromString)+import Data.HodaTime.Internal.Lens (view, set, Lens)+import Data.HodaTime.Pattern.ApplyParse (DefaultForParse(..), ApplyParse(..))+import Control.Exception (Exception)+import Data.Typeable (Typeable)++-- Exceptions++-- | Parse failed on the given string+newtype ParseFailedException = ParseFailedException String+ deriving (Typeable, Show)++instance Exception ParseFailedException++type Parser a r = Parsec r () a++-- | Pattern for the data type which is used by the 'parse', 'format' and 'parse\'' functions+data Pattern a b r = Pattern+ {+ _patParse :: Parser a r+ ,_patFormat :: Format r b+ }++-- | Merge a pattern that operates on a data type with a static pattern+(<%) :: Pattern a b r -> Pattern c r r -> Pattern a b r+(Pattern parse1 format1) <% (Pattern parse2 format2) = Pattern par fmt+ where+ par = parse1 <* parse2+ fmt = format1 % format2++{-+-- | Merge a static pattern with one that operates on a data type++-- NOTE: The following doesn't work, I believe because of how much we're fixing the types removes the ability to apply (%) in either direction.+-- NOTE: But in fact, (<%) above is sufficient, the library can work fine without offering the other option++(%>) :: Pattern c r r -> Pattern a b r -> Pattern a b r+(Pattern parse1 format1) %> (Pattern parse2 format2) = Pattern par fmt+ where+ par = parse1 *> parse2+ fmt = format1 % format2+-}++instance Semigroup (Pattern (a -> a) (b -> r) r) where+ (Pattern parse1 format1) <> (Pattern parse2 format2) = Pattern par fmt+ where+ par = (.) <$> parse1 <*> parse2+ fmt = format1 `mappend` format2++-- | Parse a 'String' given by 'Pattern' for the data type 'a'. Will call 'throwM' on failure.+-- NOTE: A default 'a' will be used to determine what happens for fields which do not appear in+-- the parse+parse :: (MonadThrow m, DefaultForParse a) => Pattern (a -> a) b String -> SourceName -> m a+parse pat s = parse' pat s getDefault++-- | Like 'parse' above but lets the user provide an 'a' as the default to use+parse' :: MonadThrow m => Pattern (a -> a) b String -> SourceName -> a -> m a+parse' (Pattern p _) s def =+ case runParser p () s s of+ Left err -> throwM . ParseFailedException $ show err+ Right r -> return . r $ def++parse'' :: (MonadThrow m, ApplyParse a b) => Pattern (a -> a) (b -> String) String -> SourceName -> m b+parse'' (Pattern p _) s =+ case runParser p () s s of+ Left err -> throwM . ParseFailedException $ show err+ Right r -> applyParse r++-- | Use the given 'Pattern' to format the data type 'a' into a 'String'+format :: Pattern a r String -> r+format (Pattern _ fmt) = formatToString fmt++pat_lens :: Lens s s a a+ -> Parser a String+ -> ((s -> a) -> Format String (s -> String))+ -> String+ -> Pattern (s -> s) (s -> String) String+pat_lens l p f err = Pattern par fmt+ where+ fmt = f $ view l+ par = set l <$> p <?> err++pat_lens' :: Lens s s a a+ -> Lens s' s' a' a'+ -> Parser a String+ -> ((s' -> a') -> Format String (s' -> String))+ -> String+ -> Pattern (s -> s) (s' -> String) String+pat_lens' lp lf p f err = Pattern par fmt+ where+ fmt = f $ view lf+ par = set lp <$> p <?> err++digitsToInt :: (Num n, Read n) => Char -> Char -> n+digitsToInt a b = read [a, b]++p_sixty :: (Num n, Read n) => Parser n String+p_sixty = digitsToInt <$> oneOf ['0'..'5'] <*> digit++f_shown :: Show b => (a -> b) -> Format r (a -> r)+f_shown x = later (TLB.fromText . T.pack . show . x)++f_shown_two :: Show b => (a -> b) -> Format r (a -> r)+f_shown_two x = left 2 '0' %. f_shown x++-- | Format a numeric field @n@ characters wide, zero-padded. Width @1@ means no padding (every number is at least+-- one character, so @left 1 '0'@ never adds a zero).+f_shown_pad :: Show b => Int -> (a -> b) -> Format r (a -> r)+f_shown_pad n x = left n '0' %. f_shown x++-- | Format a numeric field @n@ characters wide, /space/-padded (the @strftime@ @%e@\/@%l@ convention), e.g. @" 3"@.+f_shown_spad :: Show b => Int -> (a -> b) -> Format r (a -> r)+f_shown_spad n x = left n ' ' %. f_shown x++-- | Parse a numeric field. Width @1@ is the /no-padding/ case: it reads 1 up to @maxW@ digits, so both @"3"@ and+-- @"31"@ are accepted. Width @n >= 2@ reads exactly @n@ digits. Either way the value is validated to lie within+-- @[lo, hi]@.+pDigits :: Int -> Int -> Int -> Int -> Parser Int String+pDigits w maxW lo hi = do+ ds <- if w <= 1 then upTo maxW else count w digit+ let x = read ds+ if lo <= x && x <= hi then return x else parserFail ("expected " ++ show lo ++ "-" ++ show hi)+ where+ upTo :: Int -> Parser [Char] String+ upTo k = (:) <$> digit <*> go (k - 1)+ go :: Int -> Parser [Char] String+ go j = if j <= 0 then return [] else option [] ((:) <$> digit <*> go (j - 1))++-- | Parse a /space/-padded numeric field (the @strftime@ @%e@\/@%l@ convention): skip any leading spaces, then read 1+-- up to @maxW@ digits, validated to lie within @[lo, hi]@. Accepts both the padded (@" 3"@) and bare (@"3"@) forms.+pDigitsSpace :: Int -> Int -> Int -> Parser Int String+pDigitsSpace maxW lo hi = skipMany (P.char ' ') *> pDigits 1 maxW lo hi++-- | Case-insensitive literal string parser, used by the name-based patterns (month\/weekday names, AM\/PM designators).+caseInsensitiveString :: String -> Parsec String () String+caseInsensitiveString = mapM caseInsensitiveChar+ where+ caseInsensitiveChar :: Char -> Parsec String () Char+ caseInsensitiveChar c = (P.char (toLower c) <|> P.char (toUpper c)) >> return c++string :: String -> Pattern String String String+string s = Pattern p_str f_str+ where+ p_str = P.string s+ f_str = now (fromString s)++char :: Char -> Pattern Char String String+char c = Pattern p_char f_char+ where+ p_char = P.char c+ f_char = now (TLB.singleton c)++-- | Adapt a pattern over @s@ into a pattern over @t@ given a conversion in each direction (an isomorphism as far as the+-- pattern is concerned). The parse setter is lifted through the conversion, and the formatter first projects the+-- @t@ down to an @s@. This lets a pattern written for one type drive another that is convertible to it — for+-- example an 'Data.HodaTime.Instant.Instant' formatted through its UTC 'CalendarDateTime' projection.+dimapP :: (t -> s) -> (s -> t) -> Pattern (s -> s) (s -> String) String -> Pattern (t -> t) (t -> String) String+dimapP toS fromS (Pattern pS fmtS) = Pattern pT fmtT+ where+ pT = (\f -> fromS . f . toS) <$> pS+ fmtT = later (TLB.fromText . T.pack . formatToString fmtS . toS)++-- | Combine two patterns over independent parts (@a@ and @b@) of a whole @w@: the formatter concatenates their output+-- (the @a@ part then the @b@ part) and the parser runs both in that order and rebuilds the whole with the supplied+-- function. Because @a@ and @b@ together fully determine @w@, the parsed setter is a 'const' (it does not build on+-- a default), so this produces whole values — e.g. an 'Data.HodaTime.OffsetDateTime.OffsetDateTime' from a+-- date\/time pattern and an offset pattern — rather than composable sub-fields.+pairP :: (DefaultForParse a, DefaultForParse b)+ => (w -> a) -> (w -> b) -> (a -> b -> w)+ -> Pattern (a -> a) (a -> String) String+ -> Pattern (b -> b) (b -> String) String+ -> Pattern (w -> w) (w -> String) String+pairP getA getB build (Pattern pa fa) (Pattern pb fb) = Pattern par fmt+ where+ par = (\sa sb -> const (build (sa getDefault) (sb getDefault))) <$> pa <*> pb+ fmt = later (\w -> TLB.fromText . T.pack $ formatToString fa (getA w) ++ formatToString fb (getB w))
+ src/Data/HodaTime/Pattern/LocalTime.hs view
@@ -0,0 +1,192 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.Pattern.LocalTime+-- Copyright : (C) 2017 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- Patterns for a 'Data.HodaTime.LocalTime.LocalTime': the standard time layouts (@pt@, @pT@, @pr@) together with the+-- individual field patterns (@pHH@, @phh@, @pmm@, @pss@, @pfrac@, @ppp@ and friends) from which custom time patterns are+-- built. The primed variant @ppp'@ takes a 'Data.HodaTime.Locale.Locale' for its AM\/PM designators.+----------------------------------------------------------------------------+module Data.HodaTime.Pattern.LocalTime+(+ -- * Standard Patterns+ pt+ ,pT+ ,pr+ -- * Custom Patterns+ --+ -- | Used to create specialized patterns+ ,phour+ ,pHH+ ,phh+ ,phhSpace+ ,pminute+ ,pmm+ ,psecond+ ,pss+ ,pfrac+ ,pp+ ,ppp+ ,ppp'+ ,pPeriod+ ,hour'+ ,minute'+ ,second'+)+where++import Data.HodaTime.Pattern.Internal+import Data.HodaTime.Pattern.ParseTypes (TimeInfo)+import qualified Data.HodaTime.Pattern.ParseTypes as PT(hour, minute, second)+import Data.HodaTime.LocalTime.Internal (HasLocalTime)+import qualified Data.HodaTime.LocalTime.Internal as LT(hour, minute, second, nanosecond)+import Data.HodaTime.Internal.Lens (view, set)+import Control.Applicative ((<|>))+import Formatting (Format, later, left, (%.))+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as TLB+import Text.Parsec (oneOf, digit, count, try, (<?>))+import qualified Text.Parsec as P (char)+import Data.HodaTime.Locale.Internal (Locale(..))++-- x = maybe (error "duh") id $ localTime 1 2 3 0+-- parse pT "01:01:01" :: IO LocalTime+-- format pT x+-- format pt x++-- | The double digit hour of day in the 12-hour clock; a value 01-12. When formatting, the underlying 24-hour+-- value is folded into the 1-12 range (e.g. both 00:00 and 12:00 render as @12@). When parsing, the value is+-- combined with an AM\/PM designator ('pp' \/ 'ppp') if one is present in the pattern; if no designator is+-- present the value is interpreted as the morning (so @12@ parses to midnight).+--+-- 'phh' and the AM\/PM designators are /order independent/: each only rewrites its own portion of the hour, so+-- @'phh' '<%' 'char' \' \' '<>' 'ppp'@ and @'ppp' '<%' 'char' \' \' '<>' 'phh'@ both round-trip correctly.+phh :: HasLocalTime lt => Pattern (lt -> lt) (lt -> String) String+phh = twelveHour paddedNum f_shown_two+ where+ paddedNum = (digitsToInt <$> P.char '0' <*> oneOf ['1'..'9']) <|> (digitsToInt <$> P.char '1' <*> oneOf ['0'..'2'])++-- | The hour of day in the 12-hour clock, /space/-padded to two characters (the @strftime@ @%l@ convention), e.g.+-- @\" 3\"@. Like 'phh' it folds the 24-hour value into 1-12 and combines with an AM\/PM designator on parse.+phhSpace :: HasLocalTime lt => Pattern (lt -> lt) (lt -> String) String+phhSpace = twelveHour (pDigitsSpace 2 1 12) (f_shown_spad 2)++-- | Shared builder for the 12-hour clock hour: @numP@ parses the 1-12 value and @mkFmt@ renders it (given a getter of+-- the folded 1-12 hour). Only the 1-12 position of the hour is rewritten on parse, preserving the AM\/PM half so it+-- stays order-independent with 'pp'\/'ppp'.+twelveHour :: HasLocalTime lt => Parser Int String -> ((lt -> Int) -> Format String (lt -> String)) -> Pattern (lt -> lt) (lt -> String) String+twelveHour numP mkFmt = Pattern par (mkFmt (to12 . view LT.hour))+ where+ par = (adjust <$> numP) <?> "hour: 01-12"+ adjust n lt = set LT.hour (12 * (view LT.hour lt `div` 12) + (n `mod` 12)) lt -- NOTE: replace only the 1-12 position, preserve the AM/PM half+ to12 h = if h' == 0 then 12 else h' where h' = h `mod` 12++-- | The hour of day in the 24-hour clock as @w@ digits, zero-padded; a width of @1@ means /no padding/. Values 00-23.+phour :: HasLocalTime lt => Int -> Pattern (lt -> lt) (lt -> String) String+phour w = pat_lens LT.hour (pDigits w 2 0 23) (f_shown_pad w) "hour: 00-23"++-- | The double digit hour of day in the 24-hour clock (@'phour' 2@); a value 00-23.+pHH :: HasLocalTime lt => Pattern (lt -> lt) (lt -> String) String+pHH = phour 2++hour' :: HasLocalTime lt => Pattern (TimeInfo -> TimeInfo) (lt -> String) String+hour' = pat_lens' PT.hour LT.hour (p_a <|> p_b) f_shown_two "hour: 00-23"+ where+ p_a = digitsToInt <$> oneOf ['0', '1'] <*> digit + p_b = digitsToInt <$> P.char '2' <*> oneOf ['0'..'3']++-- | The minute of the hour as @w@ digits, zero-padded; a width of @1@ means /no padding/. Values 00-59.+pminute :: HasLocalTime lt => Int -> Pattern (lt -> lt) (lt -> String) String+pminute w = pat_lens LT.minute (pDigits w 2 0 59) (f_shown_pad w) "minute: 00-59"++-- | The double digit minute of the hour (@'pminute' 2@); a value 00-59.+pmm :: HasLocalTime lt => Pattern (lt -> lt) (lt -> String) String+pmm = pminute 2++minute' :: HasLocalTime lt => Pattern (TimeInfo -> TimeInfo) (lt -> String) String+minute' = pat_lens' PT.minute LT.minute p_sixty f_shown_two "minute: 00-59"++-- | The second of the minute as @w@ digits, zero-padded; a width of @1@ means /no padding/. Values 00-59.+psecond :: HasLocalTime lt => Int -> Pattern (lt -> lt) (lt -> String) String+psecond w = pat_lens LT.second (pDigits w 2 0 59) (f_shown_pad w) "second: 00-59"++-- | The double digit second of the minute (@'psecond' 2@); a value 00-59.+pss :: HasLocalTime lt => Pattern (lt -> lt) (lt -> String) String+pss = psecond 2++second' :: HasLocalTime lt => Pattern (TimeInfo -> TimeInfo) (lt -> String) String+second' = pat_lens' PT.second LT.second p_sixty f_shown_two "second: 00-59"++-- | Fractional seconds of a fixed width @n@ (1-9 digits, since the underlying resolution is nanoseconds). Formatting+-- shows exactly @n@ zero-padded digits (dropping any finer resolution); parsing reads exactly @n@ digits and scales+-- them back up to nanoseconds (so @'pfrac' 3@ parses milliseconds). A width outside 1-9 is a programmer error.+--+-- NOTE: this is the first pattern that takes a parameter (all the others are nullary values). The parameterized form+-- was chosen because @pf@\/@pF@ are already taken by the standard date\/time patterns and because it covers every+-- width uniformly. If parameterized patterns stay rare we may revisit this; a trailing-zero-trimming variant (the+-- NodaTime @F@ specifier) could also be added later.+pfrac :: HasLocalTime lt => Int -> Pattern (lt -> lt) (lt -> String) String+pfrac n+ | n < 1 || n > 9 = error "pfrac: fractional second width must be between 1 and 9"+ | otherwise = Pattern par fmt+ where+ scale = 10 ^ (9 - n) :: Int+ par = ((set LT.nanosecond . (* scale) . read) <$> count n digit) <?> ("fractional second: " ++ show n ++ " digits")+ fmt = left n '0' %. f_shown (\lt -> view LT.nanosecond lt `div` scale)++-- | 12 hour clock time period designation short form; either @A@ or @P@. See 'ppp' for the long form.+pp :: HasLocalTime lt => Pattern (lt -> lt) (lt -> String) String+pp = Pattern par (amPmFormat render)+ where+ par = (amPmSetter <$> desig) <?> "period: A or P"+ desig = (True <$ oneOf "Pp") <|> (False <$ oneOf "Aa")+ render isPM = if isPM then "P" else "A"++-- | 12 hour clock time period designation full form; either @AM@ or @PM@. When parsing, this only sets whether the+-- hour is in the morning or afternoon; combine with 'phh' to parse a full 12-hour time.+ppp :: HasLocalTime lt => Pattern (lt -> lt) (lt -> String) String+ppp = Pattern par (amPmFormat render)+ where+ par = (amPmSetter <$> desig) <?> "period: AM or PM"+ desig = (\c -> c `elem` "Pp") <$> oneOf "AaPp" <* oneOf "Mm"+ render isPM = if isPM then "PM" else "AM"++-- | 12 hour clock time period designator using an explicit @(am, pm)@ pair, instead of the built-in @AM@\/@PM@ literals.+-- This is the calendar-agnostic core behind the locale-aware 'ppp''. Parsing matches either designator+-- case-insensitively (PM tried first); as with 'ppp' it only sets morning\/afternoon, so combine it with 'phh'.+pPeriod :: HasLocalTime lt => (String, String) -> Pattern (lt -> lt) (lt -> String) String+pPeriod (am, pm) = Pattern par (amPmFormat render)+ where+ par = (amPmSetter <$> desig) <?> "period"+ desig = (True <$ try (caseInsensitiveString pm)) <|> (False <$ try (caseInsensitiveString am))+ render isPM = if isPM then pm else am++-- | 12 hour clock time period designator in the given 'Locale' (e.g. the POSIX @AM_STR@\/@PM_STR@); the locale-aware+-- counterpart to 'ppp'. NOTE: some locales (e.g. German) leave these designators empty, in which case this pattern+-- cannot round-trip; prefer a 24-hour pattern there.+ppp' :: HasLocalTime lt => Locale -> Pattern (lt -> lt) (lt -> String) String+ppp' loc = pPeriod (amName loc, pmName loc)++-- | Rewrite only the AM\/PM half of the hour (morning \<-\> afternoon), preserving the 1-12 position set by 'phh'.+amPmSetter :: HasLocalTime lt => Bool -> lt -> lt+amPmSetter isPM lt = set LT.hour (h12 + if isPM then 12 else 0) lt+ where h12 = view LT.hour lt `mod` 12++-- | Render the AM\/PM designator, choosing the form via the supplied function (True == PM).+amPmFormat :: HasLocalTime lt => (Bool -> String) -> Format String (lt -> String)+amPmFormat render = later (TLB.fromText . T.pack . render . (>= (12 :: Int)) . view LT.hour)++-- | Short format pattern. Currently defined as "HH:mm" but should eventually follow the locale+pt :: HasLocalTime lt => Pattern (lt -> lt) (lt -> String) String+pt = pHH <% char ':' <> pmm++-- | Long format pattern. Currently defined as "HH:mm:ss" but should eventually follow locale+pT :: HasLocalTime lt => Pattern (lt -> lt) (lt -> String) String+pT = pHH <% char ':' <> pmm <% char ':' <> pss+-- | The round-trippable time pattern, "HH:mm:ss.fffffffff" (nanosecond precision).+pr :: HasLocalTime lt => Pattern (lt -> lt) (lt -> String) String+pr = pT <% char '.' <> pfrac 9
+ src/Data/HodaTime/Pattern/Locale.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module : Data.HodaTime.Pattern.Locale+-- Copyright : (C) 2016 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- Compiles the @strftime@ layout strings captured in a 'Locale' by "Data.HodaTime.Locale" (the operating system's+-- @D_FMT@ \/ @T_FMT@ on POSIX, translated from the equivalent Windows /picture/ strings) into hodatime 'Pattern's, so a+-- date or time can be formatted and parsed using the machine's own conventions.+--+-- ==== __Using the machine's own layout__+--+-- 'localeDatePattern' turns a locale's @D_FMT@ into a pattern, so the /same/ date renders the way each culture writes+-- it — month-first in the US, day-first in Germany (here @march15@ is 15 March 2020):+--+-- > do us <- localeByName "en_US.UTF-8"+-- > de <- localeByName "de_DE.UTF-8"+-- > usP <- localeDatePattern us+-- > deP <- localeDatePattern de+-- > pure (format usP march15, format deP march15) -- ("03/15/2020", "15.03.2020")+--+-- Use 'currentLocale' instead of 'localeByName' to follow the machine's own @LC_TIME@ setting, and 'parse' with the+-- same pattern to read that layout back:+--+-- > do loc <- currentLocale+-- > p <- localeDatePattern loc -- the current locale's short-date layout+-- > pure (format p march15) >>= parse p -- round-trips in whatever order the locale uses+--+-- 'localeTimePattern' does the same for the time-of-day layout (@T_FMT@), and 'localeDateTimePattern' for the combined+-- date-and-time layout (@D_T_FMT@) as a 'CalendarDateTime'.+--+-- ==== __On time zones__+--+-- 'localeDateTimePattern' /deliberately ignores/ the time zone. Most @D_T_FMT@ strings end with @%Z@ (a zone+-- abbreviation such as @CEST@) or @%z@ (a numeric offset); a 'CalendarDateTime' is /civil/ time with no zone attached,+-- so there is nothing to render there and nothing to interpret, and those specifiers are dropped from the compiled+-- pattern. In particular a zone-less datetime is /not/ assumed to be UTC — treating civil time as UTC is exactly the+-- accidental coupling the library is built to avoid; turning a 'CalendarDateTime' into an absolute instant always+-- requires you to attach an offset or time zone /on purpose/.+--+-- When you /do/ want the zone, use 'parseZonedDateTime' (below): it parses the locale's zoned layout into a+-- 'Data.HodaTime.ZonedDateTime.ZonedDateTime', capturing the @%Z@ abbreviation and resolving it through a /provider/+-- you supply (abbreviations are ambiguous, so the caller owns that mapping). It requires the layout to contain a zone,+-- throwing 'ZonelessLayoutException' otherwise — a layout with no zone is not a zoned value.+--+-- A layout that instead carries a /numeric/ offset (@%z@, e.g. @+0200@) is unambiguous, so+-- 'localeOffsetDateTimePattern' compiles it into an ordinary, pure, bidirectional+-- 'Data.HodaTime.OffsetDateTime.OffsetDateTime' pattern (used with 'parse' and 'format', no provider needed), throwing+-- 'OffsetlessLayoutException' if the layout has no @%z@.+module Data.HodaTime.Pattern.Locale+(+ StrftimeError(..)+ ,ZonelessLayoutException(..)+ ,OffsetlessLayoutException(..)+ ,localeDatePattern+ ,localeTimePattern+ ,localeDateTimePattern+ ,localeOffsetDateTimePattern+ ,parseZonedDateTime+)+where++import Data.HodaTime.Pattern.Internal (Pattern(..), (<%), string)+import Data.HodaTime.Pattern.CalendarDate (pyyyy, pyy, pMM, pdd, pdaySpace, pMMMM', pMMM', pdddd', pddd')+import Data.HodaTime.Pattern.OffsetDateTime (offsetDateTimePattern)+import Data.HodaTime.Pattern.Offset (pOffsetCompact)+import Data.HodaTime.Pattern.LocalTime (pHH, phh, phhSpace, pmm, pss, ppp')+import Data.HodaTime.Pattern.ZonedDateTime.Internal (parseZonedDateTimeWith)+import Data.HodaTime.Locale.Internal (Locale(..))+import Data.HodaTime.CalendarDateTime.Internal (HasDate, DoW, CalendarDateTime, IsCalendar)+import Data.HodaTime.LocalTime.Internal (HasLocalTime)+import Data.HodaTime.ZonedDateTime (ZonedDateTime)+import Data.HodaTime.OffsetDateTime (OffsetDateTime)+import Data.HodaTime.TimeZone (TimeZone)+import Control.Monad.Catch (MonadThrow, throwM)+import Control.Exception (Exception)+import Data.Typeable (Typeable)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as TLB+import qualified Text.Parsec as P (string)+import Formatting (later)++-- | Raised when a layout string uses a @strftime@ conversion that the compiler does not implement.+data StrftimeError+ = UnsupportedSpecifier Char -- ^ a conversion we do not support here (e.g. @%Z@, @%V@, or a width\/flag like @%-d@)+ | DanglingPercent -- ^ the layout string ended with a bare @%@+ deriving (Eq, Show, Typeable)++instance Exception StrftimeError++-- | A literal chunk of the layout as a field pattern: it consumes\/emits the given text and leaves the value untouched.+-- Because it has the ordinary field-pattern shape it composes with '<>' like any other field, so literals anywhere in+-- the layout (including at the very start) need no special handling.+litField :: String -> Pattern (a -> a) (a -> String) String+litField s = Pattern (id <$ P.string s) (later (const (TLB.fromText (T.pack s))))++-- | A single token of a layout string, after composite specifiers have been expanded.+data Tok = Lit Char | Conv Char++-- | A run of literal characters or a single conversion specifier.+data Frag = LitRun String | ConvF Char++-- | Tokenise a layout string, expanding the composite specifiers (@%T@, @%R@, @%r@, @%F@, @%D@) into their parts.+tokenize :: String -> Either StrftimeError [Tok]+tokenize [] = Right []+tokenize ('%':c:rest) = case c of+ '%' -> (Lit '%' :) <$> tokenize rest+ 'n' -> (Lit '\n' :) <$> tokenize rest+ 't' -> (Lit '\t' :) <$> tokenize rest+ 'T' -> tokenize ("%H:%M:%S" ++ rest)+ 'R' -> tokenize ("%H:%M" ++ rest)+ 'r' -> tokenize ("%I:%M:%S %p" ++ rest)+ 'F' -> tokenize ("%Y-%m-%d" ++ rest)+ 'D' -> tokenize ("%m/%d/%y" ++ rest)+ _ -> (Conv c :) <$> tokenize rest+tokenize ['%'] = Left DanglingPercent+tokenize (c:rest) = (Lit c :) <$> tokenize rest++-- | Merge adjacent literal characters into runs so each becomes a single 'litField'.+toFrags :: [Tok] -> [Frag]+toFrags = foldr step []+ where+ step (Lit c) (LitRun s : fs) = LitRun (c : s) : fs+ step (Lit c) fs = LitRun [c] : fs+ step (Conv c) fs = ConvF c : fs++-- | Assemble a list of fragments into a pattern, given a mapping from conversion specifiers to field patterns.+assemble+ :: (Char -> Either StrftimeError (Pattern (a -> a) (a -> String) String))+ -> [Frag]+ -> Either StrftimeError (Pattern (a -> a) (a -> String) String)+assemble mapConv frags = do+ ps <- mapM toPat frags+ case ps of+ [] -> Right (litField "")+ _ -> Right (foldr1 (<>) ps)+ where+ toPat (LitRun s) = Right (litField s)+ toPat (ConvF c) = mapConv c++-- | Compile a layout string into a pattern, given a specifier mapping.+compileWith+ :: (Char -> Either StrftimeError (Pattern (a -> a) (a -> String) String))+ -> String+ -> Either StrftimeError (Pattern (a -> a) (a -> String) String)+compileWith mapConv fmtStr = tokenize fmtStr >>= assemble mapConv . toFrags++-- | As 'compileWith' but first drops the zone specifiers (@%Z@\/@%z@) and a single preceding space; used for the+-- combined date-and-time layout, whose 'CalendarDateTime' target has no zone.+compileDroppingZones+ :: (Char -> Either StrftimeError (Pattern (a -> a) (a -> String) String))+ -> String+ -> Either StrftimeError (Pattern (a -> a) (a -> String) String)+compileDroppingZones mapConv fmtStr = tokenize fmtStr >>= assemble mapConv . stripZones . toFrags++-- | Drop the zone specifiers (@%Z@\/@%z@) and a single preceding space: a 'CalendarDateTime' has no zone to show.+stripZones :: [Frag] -> [Frag]+stripZones [] = []+stripZones (LitRun s : ConvF c : rest)+ | isZone c = [LitRun s' | not (null s')] ++ stripZones rest+ where s' = reverse (dropWhile (== ' ') (reverse s))+stripZones (ConvF c : rest)+ | isZone c = stripZones rest+stripZones (f : rest) = f : stripZones rest++isZone :: Char -> Bool+isZone c = c == 'Z' || c == 'z'++dateConv :: (HasDate d, Enum (DoW d)) => Locale -> Char -> Either StrftimeError (Pattern (d -> d) (d -> String) String)+dateConv loc c = case c of+ 'Y' -> Right pyyyy+ 'y' -> Right pyy+ 'm' -> Right pMM+ 'd' -> Right pdd+ 'e' -> Right pdaySpace+ 'B' -> Right (pMMMM' loc)+ 'b' -> Right (pMMM' loc)+ 'h' -> Right (pMMM' loc)+ 'A' -> Right (pdddd' loc)+ 'a' -> Right (pddd' loc)+ _ -> Left (UnsupportedSpecifier c)++timeConv :: HasLocalTime lt => Locale -> Char -> Either StrftimeError (Pattern (lt -> lt) (lt -> String) String)+timeConv loc c = case c of+ 'H' -> Right pHH+ 'I' -> Right phh+ 'l' -> Right phhSpace+ 'M' -> Right pmm+ 'S' -> Right pss+ 'p' -> Right (ppp' loc)+ _ -> Left (UnsupportedSpecifier c)++-- | Compile an explicit @strftime@ date layout against a 'Locale' (the locale supplies month\/weekday names for @%B@,+-- @%b@, @%A@, @%a@). Throws a 'StrftimeError' on an unsupported specifier.+compileDatePattern :: (MonadThrow m, HasDate d, Enum (DoW d)) => Locale -> String -> m (Pattern (d -> d) (d -> String) String)+compileDatePattern loc = either throwM return . compileWith (dateConv loc)++-- | Compile an explicit @strftime@ time layout against a 'Locale' (the locale supplies the AM\/PM designators for+-- @%p@). Throws a 'StrftimeError' on an unsupported specifier.+compileTimePattern :: (MonadThrow m, HasLocalTime lt) => Locale -> String -> m (Pattern (lt -> lt) (lt -> String) String)+compileTimePattern loc = either throwM return . compileWith (timeConv loc)++-- | The locale's short date pattern, compiled from its short-date layout (@rawDateFormat@; @D_FMT@ on POSIX).+localeDatePattern :: (MonadThrow m, HasDate d, Enum (DoW d)) => Locale -> m (Pattern (d -> d) (d -> String) String)+localeDatePattern loc = compileDatePattern loc (rawDateFormat loc)++-- | The locale's time pattern, compiled from its time layout (@rawTimeFormat@; @T_FMT@ on POSIX).+localeTimePattern :: (MonadThrow m, HasLocalTime lt) => Locale -> m (Pattern (lt -> lt) (lt -> String) String)+localeTimePattern loc = compileTimePattern loc (rawTimeFormat loc)++-- | Combined date-and-time mapping over 'CalendarDateTime': a date specifier resolves to its date field and a time+-- specifier to its time field (both are valid on a 'CalendarDateTime', which is 'HasDate' and 'HasLocalTime').+dateTimeConv :: (IsCalendar cal, Enum (DoW (CalendarDateTime cal))) => Locale -> Char -> Either StrftimeError (Pattern (CalendarDateTime cal -> CalendarDateTime cal) (CalendarDateTime cal -> String) String)+dateTimeConv loc c = case dateConv loc c of+ Right p -> Right p+ Left _ -> timeConv loc c++-- | The locale's combined date-and-time pattern, compiled from its combined layout (@rawDateTimeFormat@; @D_T_FMT@ on+-- POSIX) as a 'CalendarDateTime'. The zone specifiers @%Z@\/@%z@ are dropped — see the note on time zones in the+-- module header.+localeDateTimePattern :: (MonadThrow m, IsCalendar cal, Enum (DoW (CalendarDateTime cal))) => Locale -> m (Pattern (CalendarDateTime cal -> CalendarDateTime cal) (CalendarDateTime cal -> String) String)+localeDateTimePattern loc = either throwM return (compileDroppingZones (dateTimeConv loc) (rawDateTimeFormat loc))++-- | Thrown by 'parseZonedDateTime' when the locale's @D_T_FMT@ has no zone (@%Z@): such a layout describes civil time,+-- not a zoned value, so use 'localeDateTimePattern' for it instead.+newtype ZonelessLayoutException = ZonelessLayout String -- ^ carries the offending locale's id+ deriving (Eq, Show, Typeable)++instance Exception ZonelessLayoutException++-- | Parse a zoned date\/time written in the locale's @D_T_FMT@ into a 'ZonedDateTime'. The local part is read from the+-- layout and the trailing @%Z@ token is captured and handed to the /provider/ (abbreviations such as @CEST@ are+-- ambiguous, so you supply the mapping to a real 'TimeZone'); the /resolver/ then decides skipped\/ambiguous local+-- times (e.g. @fromCalendarDateTimeStrictly@). Throws 'ZonelessLayoutException' if the locale's layout has no @%Z@+-- (a layout with no zone is not a zoned value).+parseZonedDateTime+ :: (MonadThrow m, IsCalendar cal, Enum (DoW (CalendarDateTime cal)))+ => (String -> m TimeZone)+ -> (CalendarDateTime cal -> TimeZone -> m (ZonedDateTime cal))+ -> Locale+ -> String+ -> m (ZonedDateTime cal)+parseZonedDateTime provider resolve loc s+ | hasZoneSpecifier (rawDateTimeFormat loc) = localeDateTimePattern loc >>= \localPat -> parseZonedDateTimeWith localPat provider resolve s+ | otherwise = throwM (ZonelessLayout (localeId loc))++-- | Does a @strftime@ layout contain the zone specifier @%Z@ (respecting @%%@)?+hasZoneSpecifier :: String -> Bool+hasZoneSpecifier ('%':'%':rest) = hasZoneSpecifier rest+hasZoneSpecifier ('%':'Z':_) = True+hasZoneSpecifier ('%':_:rest) = hasZoneSpecifier rest+hasZoneSpecifier (_:rest) = hasZoneSpecifier rest+hasZoneSpecifier [] = False++-- | Thrown by 'localeOffsetDateTimePattern' when the locale's @D_T_FMT@ has no numeric offset (@%z@).+newtype OffsetlessLayoutException = OffsetlessLayout String -- ^ carries the offending locale's id+ deriving (Eq, Show, Typeable)++instance Exception OffsetlessLayoutException++-- | Compile the locale's @D_T_FMT@ into an 'OffsetDateTime' pattern, using its numeric offset (@%z@, e.g. @+0200@).+-- Unlike 'parseZonedDateTime' this is a plain, /pure/, bidirectional pattern (drive it with 'Data.HodaTime.Pattern.parse'+-- and 'Data.HodaTime.Pattern.format') because a numeric offset is unambiguous — no zone provider or resolver is+-- needed. Throws 'OffsetlessLayoutException' if the layout has no @%z@ (the abbreviation form @%Z@ is not an offset;+-- use 'parseZonedDateTime' for that).+localeOffsetDateTimePattern+ :: (MonadThrow m, IsCalendar cal, Enum (DoW (CalendarDateTime cal)))+ => Locale+ -> m (Pattern (OffsetDateTime cal -> OffsetDateTime cal) (OffsetDateTime cal -> String) String)+localeOffsetDateTimePattern loc+ | hasOffsetSpecifier fmt = either throwM return (compileOffsetDateTime (dateTimeConv loc) fmt)+ | otherwise = throwM (OffsetlessLayout (localeId loc))+ where fmt = rawDateTimeFormat loc++-- | Split a @%z@-bearing layout into its local part and the offset, compile the local part, and pair it with the+-- compact-offset field.+compileOffsetDateTime+ :: IsCalendar cal+ => (Char -> Either StrftimeError (Pattern (CalendarDateTime cal -> CalendarDateTime cal) (CalendarDateTime cal -> String) String))+ -> String+ -> Either StrftimeError (Pattern (OffsetDateTime cal -> OffsetDateTime cal) (OffsetDateTime cal -> String) String)+compileOffsetDateTime dtConv fmtStr = do+ toks <- tokenize fmtStr+ let (before, rest) = break isOffsetFrag (toFrags toks)+ localPat <- assemble dtConv before+ trailing <- trailingLits (drop 1 rest)+ return (offsetDateTimePattern localPat (pOffsetCompact <% string trailing))++isOffsetFrag :: Frag -> Bool+isOffsetFrag (ConvF 'z') = True+isOffsetFrag _ = False++-- | The literal text following @%z@ (normally none); a further field there is unsupported.+trailingLits :: [Frag] -> Either StrftimeError String+trailingLits [] = Right ""+trailingLits (LitRun s : rest) = (s ++) <$> trailingLits rest+trailingLits (ConvF c : _) = Left (UnsupportedSpecifier c)++-- | Does a @strftime@ layout contain the numeric-offset specifier @%z@ (respecting @%%@)?+hasOffsetSpecifier :: String -> Bool+hasOffsetSpecifier ('%':'%':rest) = hasOffsetSpecifier rest+hasOffsetSpecifier ('%':'z':_) = True+hasOffsetSpecifier ('%':_:rest) = hasOffsetSpecifier rest+hasOffsetSpecifier (_:rest) = hasOffsetSpecifier rest+hasOffsetSpecifier [] = False
+ src/Data/HodaTime/Pattern/Offset.hs view
@@ -0,0 +1,99 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.Pattern.Offset+-- Copyright : (C) 2017 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- Patterns for an 'Data.HodaTime.Offset.Offset' from UTC, rendered as @(+\/-)HH:mm@; @pOffsetFull@ adds seconds,+-- @pOffsetZ@ writes @Z@ for UTC, and @pOffsetCompact@ omits the colon (@+0200@).+----------------------------------------------------------------------------+module Data.HodaTime.Pattern.Offset+(+ -- * Standard Patterns+ pOffset+ ,pOffsetZ+ ,pOffsetFull+ ,pOffsetCompact+)+where++import Data.HodaTime.Pattern.Internal (Pattern(..), p_sixty)+import Data.HodaTime.Offset.Internal (Offset(..), fromSeconds)+import Data.HodaTime.Constants (secondsPerHour, secondsPerMinute)+import Formatting (Format, later)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as TLB+import Text.Parsec (Parsec, count, digit, (<|>), (<?>))+import qualified Text.Parsec as P (char, string)++-- o1 = fromHours 2+-- format pOffset o1 -- "+02:00"+-- parse pOffset "-05:30" -- Just (Offset -19800)++type Parser a = Parsec String () a++-- DESIGN NOTE (why this module doesn't build offsets from composable per-field patterns like the others do):+--+-- The date and time pattern modules build a value field by field: each field is an independent lens 'set' and the+-- '<>' combinator composes those setters. That works because those fields are independent and are backed by+-- read/write lenses.+--+-- An 'Offset' offers neither. Its 'hours'/'minutes'/'seconds' are read-only accessors, not lenses — there is no+-- coherent 'set' for a single component of a signed quantity (see the note in Data.HodaTime.Offset) — so there is+-- nothing for the field-composition machinery to drive. And the value is a single *signed* second count whose sign+-- belongs to the whole, not to any one component, so the components could not be set independently in any case.+--+-- So both directions treat the offset as a whole: format works from 'abs secs' and emits the sign as a separate+-- leading character; parse reads the sign and all components together and multiplies the combined magnitude by the+-- sign, building the 'Offset' through 'fromSeconds' (which also clamps to the +/-18h range). The parsed value is+-- therefore fully determined by the text (it does not build on a default), which is why the parser's setter is+-- 'const <$> ...' — and these are exposed only as complete patterns, not composable sub-fields.++-- | The ISO-8601 offset pattern, sign followed by @HH:mm@ (e.g. @+02:00@, @-05:30@, @+00:00@ for UTC).+pOffset :: Pattern (Offset -> Offset) (Offset -> String) String+pOffset = Pattern (const <$> offsetParser ":" False <?> "offset: (+/-)HH:mm") (offsetFormat ":" False)++-- | Like 'pOffset' but including seconds, sign followed by @HH:mm:ss@ (e.g. @-05:30:15@).+pOffsetFull :: Pattern (Offset -> Offset) (Offset -> String) String+pOffsetFull = Pattern (const <$> offsetParser ":" True <?> "offset: (+/-)HH:mm:ss") (offsetFormat ":" True)++-- | Like 'pOffset' but renders UTC (a zero offset) as @Z@ rather than @+00:00@, per ISO-8601 (and parses @Z@ back).+pOffsetZ :: Pattern (Offset -> Offset) (Offset -> String) String+pOffsetZ = Pattern (const <$> parZ <?> "offset: Z or (+/-)HH:mm") fmtZ+ where+ parZ = (fromSeconds (0 :: Int) <$ P.char 'Z') <|> offsetParser ":" False+ fmtZ = later (\o -> TLB.fromText . T.pack $ if offsetSeconds o == 0 then "Z" else renderOffset ":" False o)++-- | The @strftime@ @%z@ offset: sign followed by @HHmm@ with no separator (e.g. @+0200@, @-0530@, @+0000@ for UTC).+pOffsetCompact :: Pattern (Offset -> Offset) (Offset -> String) String+pOffsetCompact = Pattern (const <$> offsetParser "" False <?> "offset: (+/-)HHmm") (offsetFormat "" False)++-- helpers++offsetParser :: String -> Bool -> Parser Offset+offsetParser sep withSecs = do+ sign <- ((-1) <$ P.char '-') <|> (1 <$ P.char '+')+ h <- twoDigit+ _ <- P.string sep+ m <- p_sixty+ s <- if withSecs then P.string sep *> p_sixty else pure 0+ return . fromSeconds $ sign * (h * secondsPerHour + m * secondsPerMinute + s)+ where+ twoDigit = read <$> count 2 digit :: Parser Int++offsetFormat :: String -> Bool -> Format String (Offset -> String)+offsetFormat sep withSecs = later (TLB.fromText . T.pack . renderOffset sep withSecs)++renderOffset :: String -> Bool -> Offset -> String+renderOffset sep withSecs (Offset secs) = sign : pad2 h ++ sep ++ pad2 m ++ secPart+ where+ sign = if secs < 0 then '-' else '+'+ a = abs secs+ h = a `div` secondsPerHour+ m = (a `mod` secondsPerHour) `div` secondsPerMinute+ s = a `mod` secondsPerMinute+ secPart = if withSecs then sep ++ pad2 s else ""+ pad2 x = let str = show x in if length str < 2 then '0' : str else str
+ src/Data/HodaTime/Pattern/OffsetDateTime.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.Pattern.OffsetDateTime+-- Copyright : (C) 2017 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- Patterns for an 'Data.HodaTime.OffsetDateTime.OffsetDateTime' — a+-- 'Data.HodaTime.CalendarDateTime.CalendarDateTime' pinned by a fixed UTC 'Data.HodaTime.Offset.Offset' — rendered as+-- @yyyy-MM-ddTHH:mm:ss(+\/-)HH:mm@. Build your own with @offsetDateTimePattern@ from a date-time pattern and an offset+-- pattern.+----------------------------------------------------------------------------+{-# LANGUAGE FlexibleContexts #-}+module Data.HodaTime.Pattern.OffsetDateTime+(+ -- * Standard Patterns+ pOffsetDateTime+ -- * Custom Patterns+ --+ -- | Build an 'OffsetDateTime' pattern from a 'CalendarDateTime' pattern and an 'Offset' pattern.+ ,offsetDateTimePattern+)+where++import Data.HodaTime.Pattern.Internal (Pattern, pairP)+import Data.HodaTime.Pattern.CalendarDateTime (ps)+import Data.HodaTime.Pattern.Offset (pOffset)+import Data.HodaTime.OffsetDateTime (OffsetDateTime, offset, toCalendarDateTime, fromCalendarDateTimeWithOffset)+import Data.HodaTime.CalendarDateTime (CalendarDateTime)+import Data.HodaTime.CalendarDateTime.Internal (IsCalendar)+import Data.HodaTime.Offset (Offset)++-- | Join a Gregorian-or-other 'CalendarDateTime' pattern to an 'Offset' pattern, producing an 'OffsetDateTime'+-- pattern. The date\/time text comes first, immediately followed by the offset text.+offsetDateTimePattern+ :: IsCalendar cal+ => Pattern (CalendarDateTime cal -> CalendarDateTime cal) (CalendarDateTime cal -> String) String+ -> Pattern (Offset -> Offset) (Offset -> String) String+ -> Pattern (OffsetDateTime cal -> OffsetDateTime cal) (OffsetDateTime cal -> String) String+offsetDateTimePattern = pairP toCalendarDateTime offset fromCalendarDateTimeWithOffset++-- | The ISO-8601 offset date/time pattern, @yyyy-MM-ddTHH:mm:ss±HH:mm@ (e.g. @2024-04-23T09:00:00+02:00@).+pOffsetDateTime :: IsCalendar cal => Pattern (OffsetDateTime cal -> OffsetDateTime cal) (OffsetDateTime cal -> String) String+pOffsetDateTime = offsetDateTimePattern ps pOffset
+ src/Data/HodaTime/Pattern/ParseTypes.hs view
@@ -0,0 +1,50 @@+-- Intermediate types used by the parser portion of the Pattern+module Data.HodaTime.Pattern.ParseTypes+(+ TimeInfo(..)+ ,hour+ ,minute+ ,second+ ,DateInfo(..)+ ,DateTimeInfo(..)+ ,ZonedDateTimeInfo(..)+)+where++import Data.HodaTime.CalendarDateTime.Internal (Month)++data TimeInfo = TimeInfo+ {+ _hour :: Int+ ,_minute :: Int+ ,_second :: Int+ ,_nanoSecond :: Int+ }++hour :: Functor f => (Int -> f Int) -> TimeInfo -> f TimeInfo+hour k ti = fmap (\h -> ti { _hour = h }) (k (_hour ti))++minute :: Functor f => (Int -> f Int) -> TimeInfo -> f TimeInfo+minute k ti = fmap (\m -> ti { _minute = m }) (k (_minute ti))++second :: Functor f => (Int -> f Int) -> TimeInfo -> f TimeInfo+second k ti = fmap (\s -> ti { _second = s }) (k (_second ti))++data DateInfo cal = DateInfo+ {+ day :: Maybe Int+ ,month :: Maybe (Month cal)+ ,year :: Maybe Int+ }++data DateTimeInfo cal = DateTimeInfo+ {+ date :: DateInfo cal+ ,time :: TimeInfo+ }++data ZonedDateTimeInfo cal = ZonedDateTimeInfo+ {+ dateTime :: DateTimeInfo cal+ ,zone :: String+ }
+ src/Data/HodaTime/Pattern/ZonedDateTime.hs view
@@ -0,0 +1,78 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HodaTime.Pattern.ZonedDateTime+-- Copyright : (C) 2017 Jason Johnson+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>+-- Stability : experimental+-- Portability : POSIX, Windows+--+-- Patterns for 'ZonedDateTime'.+--+-- === Formatting, and effectful parsing+--+-- Formatting is direct: @pZonedDateTime@ renders a 'ZonedDateTime' as its local date\/time plus the zone id.+--+-- Parsing cannot use the pure @parse@, because building a 'ZonedDateTime' is effectful: it has to load the time-zone+-- rules for the parsed zone id and then /resolve/ the local time (which may be skipped or ambiguous). Use+-- @parseZonedDateTime@ instead — you supply a zone /provider/ (e.g. @timeZone@ in 'IO', or a pure lookup) and a+-- /resolver/ (e.g. @fromCalendarDateTimeStrictly@). Calling @parse@ on @pZonedDateTime@ is a type error by design;+-- @parseZonedDateTime@ is the only way to parse one.+----------------------------------------------------------------------------+{-# LANGUAGE FlexibleContexts #-}+module Data.HodaTime.Pattern.ZonedDateTime+(+ -- * Standard Patterns+ pZonedDateTime+ -- * Parsing+ ,parseZonedDateTime+ -- * Custom Patterns+ --+ -- | Build a (format-only) 'ZonedDateTime' pattern from a 'CalendarDateTime' pattern and a zone-rendering function.+ ,zonedDateTimePattern+)+where++import Data.HodaTime.Pattern.Internal (Pattern(..), format)+import Data.HodaTime.Pattern.ZonedDateTime.Internal (parseZonedDateTimeWith)+import Data.HodaTime.Pattern.CalendarDateTime (ps)+import Data.HodaTime.ZonedDateTime (ZonedDateTime, toCalendarDateTime, zoneId)+import Data.HodaTime.CalendarDateTime (CalendarDateTime)+import Data.HodaTime.CalendarDateTime.Internal (IsCalendar)+import Data.HodaTime.TimeZone (TimeZone)+import Control.Monad.Catch (MonadThrow)+import Formatting (later)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as TLB+import Text.Parsec (parserFail)++-- | Format a 'ZonedDateTime' using the given 'CalendarDateTime' pattern for the local date\/time, followed by the+-- result of the zone-rendering function (e.g. a leading space and the zone id).+--+-- Formatting only: the parse side deliberately fails (see the module note), so the pure+-- 'Data.HodaTime.Pattern.parse' cannot silently produce a wrong 'ZonedDateTime'.+zonedDateTimePattern+ :: Pattern (CalendarDateTime cal -> CalendarDateTime cal) (CalendarDateTime cal -> String) String+ -> (ZonedDateTime cal -> String)+ -> Pattern (ZonedDateTime cal -> ZonedDateTime cal) (ZonedDateTime cal -> String) String+zonedDateTimePattern cdtPat renderZone = Pattern par fmt+ where+ par = parserFail "ZonedDateTime cannot be parsed with parse; use parseZonedDateTime (it is effectful -- it loads the zone and resolves the local time)"+ fmt = later (\zdt -> TLB.fromText . T.pack $ format cdtPat (toCalendarDateTime zdt) ++ renderZone zdt)++-- | The ISO-8601 local date\/time followed by a space and the (unambiguous) IANA zone id, e.g.+-- @2024-04-23T09:00:00 Europe\/Zurich@.+pZonedDateTime :: IsCalendar cal => Pattern (ZonedDateTime cal -> ZonedDateTime cal) (ZonedDateTime cal -> String) String+pZonedDateTime = zonedDateTimePattern ps (\zdt -> " " ++ zoneId zdt)++-- | Parse a zoned date\/time and resolve it to a 'ZonedDateTime'. You supply a zone /provider/ (which loads the+-- 'TimeZone' for the parsed id — @timeZone@ in 'IO', or a pure lookup) and a /resolver/ (which turns the local time+-- into a 'ZonedDateTime', deciding the skipped\/ambiguous cases — e.g. @fromCalendarDateTimeStrictly@). This is the+-- only way to parse a 'ZonedDateTime'; the pure @parse@ cannot (it is a type error on 'pZonedDateTime').+parseZonedDateTime+ :: (MonadThrow m, IsCalendar cal)+ => (String -> m TimeZone)+ -> (CalendarDateTime cal -> TimeZone -> m (ZonedDateTime cal))+ -> String+ -> m (ZonedDateTime cal)+parseZonedDateTime = parseZonedDateTimeWith ps
+ src/Data/HodaTime/Pattern/ZonedDateTime/Internal.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE FlexibleContexts #-}++-- | Shared, non-user-facing machinery for parsing 'Data.HodaTime.ZonedDateTime.ZonedDateTime' values. It lives in its+-- own module so that both "Data.HodaTime.Pattern.ZonedDateTime" (the ISO parser) and "Data.HodaTime.Pattern.Locale"+-- (the locale-driven parser) can build on it without exposing the intermediate 'ZonedDateTimeInfo' to users.+module Data.HodaTime.Pattern.ZonedDateTime.Internal+(+ ZonedDateTimeInfo(..)+ ,resolveZonedDateTime+ ,parseZonedDateTimeWith+)+where++import Data.HodaTime.Pattern.Internal (Pattern(..), DefaultForParse(..), parse)+import Data.HodaTime.ZonedDateTime (ZonedDateTime)+import Data.HodaTime.CalendarDateTime (CalendarDateTime)+import Data.HodaTime.CalendarDateTime.Internal (IsCalendar)+import Data.HodaTime.TimeZone (TimeZone)+import Control.Monad.Catch (MonadThrow)+import Formatting (later)+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as TLB+import Data.Char (isSpace)+import Text.Parsec (many1, satisfy, skipMany, (<?>))++-- | The pure result of parsing a zoned date\/time: the local (wall-clock) 'CalendarDateTime' together with the zone+-- token (an IANA id for the ISO parser, or a @%Z@ abbreviation for the locale parser). Users never see this; the+-- parse functions turn text straight into a 'ZonedDateTime'.+data ZonedDateTimeInfo cal = ZonedDateTimeInfo+ { zdtLocal :: CalendarDateTime cal+ , zdtZoneId :: String+ }++instance IsCalendar cal => DefaultForParse (ZonedDateTimeInfo cal) where+ getDefault = ZonedDateTimeInfo getDefault ""++-- | Turn a parsed 'ZonedDateTimeInfo' into a 'ZonedDateTime': the /provider/ loads the 'TimeZone' for the parsed token+-- and the /resolver/ maps the local time into the zone (deciding skipped\/ambiguous cases).+resolveZonedDateTime+ :: Monad m+ => (String -> m TimeZone)+ -> (CalendarDateTime cal -> TimeZone -> m (ZonedDateTime cal))+ -> ZonedDateTimeInfo cal+ -> m (ZonedDateTime cal)+resolveZonedDateTime provider resolve info = do+ tz <- provider (zdtZoneId info)+ resolve (zdtLocal info) tz++-- | Parse a zoned date\/time using @localPat@ for the local part, then a trailing zone token (any run of non-space+-- characters, after optional whitespace), and resolve it with the given provider and resolver. The local pattern's+-- own format side is irrelevant here — only its parser is used.+parseZonedDateTimeWith+ :: (MonadThrow m, IsCalendar cal)+ => Pattern (CalendarDateTime cal -> CalendarDateTime cal) b String+ -> (String -> m TimeZone)+ -> (CalendarDateTime cal -> TimeZone -> m (ZonedDateTime cal))+ -> String+ -> m (ZonedDateTime cal)+parseZonedDateTimeWith localPat provider resolve s = parse infoPat s >>= resolveZonedDateTime provider resolve+ where+ infoPat = Pattern par fmt+ par = build <$> _patParse localPat <*> zoneToken+ zoneToken = skipMany (satisfy isSpace) *> (many1 (satisfy (not . isSpace)) <?> "zone")+ build setCdt z = const (ZonedDateTimeInfo (setCdt getDefault) z)+ fmt = later (\info -> TLB.fromText . T.pack $ zdtZoneId info)
src/Data/HodaTime/TimeZone.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Module : Data.HodaTime.Instant+-- Module : Data.HodaTime.TimeZone -- Copyright : (C) 2017 Jason Johnson -- License : BSD-style (see the file LICENSE) -- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>@@ -17,6 +17,7 @@ ,utc ,localZone ,timeZone+ ,availableZones ) where @@ -29,7 +30,7 @@ (utcM, calDateM) <- loadUTC return $ TimeZone UTC utcM calDateM --- | Load the specified time zone. The time zone name should be in the standard format (e.g. "Europe/Paris")+-- | Load the specified time zone. The time zone name should be in the format returned by `availableZones` timeZone :: String -> IO TimeZone timeZone tzName = do (utcM, calDateM) <- loadTimeZone tzName@@ -40,3 +41,7 @@ localZone = do (utcM, calDateM, tzName) <- loadLocalZone return $ TimeZone (Zone tzName) utcM calDateM++-- | List all time zones available to hodatime+availableZones :: IO [String]+availableZones = loadAvailableZones
src/Data/HodaTime/TimeZone/Internal.hs view
@@ -12,7 +12,6 @@ ,addUtcTransition ,addUtcTransitionExpression ,activeTransitionFor- ,nextTransition ,emptyCalDateTransitions ,addCalDateTransition ,addCalDateTransitionExpression@@ -28,27 +27,29 @@ import Data.HodaTime.Instant.Internal (Instant(..), minus, bigBang) import Data.HodaTime.Offset.Internal (Offset(..), adjustInstant) import Data.HodaTime.Duration.Internal (fromNanoseconds)-import Data.HodaTime.Calendar.Gregorian.Internal (nthDayToDayOfMonth, yearMonthDayToDays, instantToYearMonthDay)+import Data.HodaTime.Calendar.Gregorian.Internal (nthDayToDayOfMonth, yearMonthDayToDays, maxDaysInMonth, instantToYearMonthDay) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.IntervalMap.FingerTree (IntervalMap, Interval(..)) import qualified Data.IntervalMap.FingerTree as IMap+import Data.Hashable (Hashable(..)) -data TZIdentifier = UTC | Zone String+data TZIdentifier = UTC | Zone String deriving (Eq, Show) +instance Hashable TZIdentifier where+ hashWithSalt s UTC = hashWithSalt s (0 :: Int)+ hashWithSalt s (Zone n) = s `hashWithSalt` (1 :: Int) `hashWithSalt` n+ data TransitionInfo = TransitionInfo { tiUtcOffset :: Offset, tiIsDst :: Bool, tiAbbreviation :: String } deriving (Eq, Show) +instance Hashable TransitionInfo where+ hashWithSalt s (TransitionInfo off isDst abbr) = s `hashWithSalt` off `hashWithSalt` isDst `hashWithSalt` abbr+ data TransitionExpression =- NthDayExpression- {- teMonth :: Int- ,teNthDay :: Int- ,teDay :: Int- ,teSeconds :: Int- }- | JulianExpression { jeCountLeaps :: Bool, jeDay :: Int, jeSeconds :: Int }+ NthDayExpression Int Int Int Int -- ^ month, nthDay, day, seconds+ | JulianExpression Bool Int Int -- ^ countLeaps, day, seconds deriving (Eq, Show) data TransitionExpressionInfo = TransitionExpressionInfo@@ -83,13 +84,6 @@ where f (dstStart, dstEnd, stdTI, dstTI) = if i <= dstStart || i >= dstEnd then stdTI else dstTI --- TODO: We would need to get the next year to complete this function but let's see if it's actually used before doing more work-nextTransition :: Instant -> TimeZone -> (Instant, TransitionInfo)-nextTransition i (TimeZone _ utcM _) = f . fromMaybe (Map.findMax utcM) $ Map.lookupGT i utcM- where- f (i', ti) = fromTransInfo i g (\ti' -> (i', ti')) ti- g (dstStart, dstEnd, stdTI, dstTI) = if i < dstStart then (dstStart, dstTI) else if i < dstEnd then (dstEnd, stdTI) else error "nextTransition: need next year"- -- CalendarDate to transition data IntervalEntry a =@@ -119,20 +113,25 @@ search = IMap.search (Entry i) f = fmap snd . search . buildFixedTransIMap --- TODO: this function need major cleanup, this implementation is really nasty and almost certainly unsafe+-- NOTE: Only ever called (from 'resolve') when a local time falls in a spring-forward gap. This looks partial but is+-- total by construction: every zone's 'CalDateTransitionsMap' tiles [Smallest, Largest] (see the constructors), so the+-- 'IMap.splitAfter' below always yields a non-empty 'front' and 'back' — the 'IMap.bounds'\/'leastView' Nothing cases+-- cannot occur. A top-level empty search ('go []') only happens in the fixed (historical) region: the expression+-- region always returns a single interval and is handled by 'go [expr]', so the bracketing transitions are always+-- fixed ('bomb' is unreachable). aroundCalDateTransition :: Instant -> TimeZone -> (TransitionInfo, TransitionInfo) aroundCalDateTransition i (TimeZone _ _ cdtMap) = go . fmap snd . IMap.search (Entry i) $ cdtMap where go [] = (before, after) go [(TransitionInfoExpression (TransitionExpressionInfo _ _ stdTI dstTI))] = (stdTI, dstTI) -- NOTE: Should be the only way this happens- go x = error $ "aroundCalDateTransition: unexpected search result" ++ show x- before = fromTransInfo i bomb id . snd . go' . flip IMap.search cdtMap . IMap.high . fromMaybe (error "around.before: fixme") . IMap.bounds $ front- after = fromTransInfo i bomb id . snd . fst . fromMaybe (error "around.after: fixme") . IMap.leastView $ back+ go x = error $ "aroundCalDateTransition: unreachable - a gap search should return [] or a single expression, got: " ++ show x+ before = fromTransInfo i bomb id . snd . go' . flip IMap.search cdtMap . IMap.high . fromMaybe (error "aroundCalDateTransition: unreachable - empty 'front' (the map always tiles from Smallest)") . IMap.bounds $ front+ after = fromTransInfo i bomb id . snd . fst . fromMaybe (error "aroundCalDateTransition: unreachable - empty 'back' (the map always tiles to Largest)") . IMap.leastView $ back (front, back) = IMap.splitAfter (Entry i) cdtMap- go' [] = error "aroundCalDateTransition: no before transitions"+ go' [] = error "aroundCalDateTransition: unreachable - no interval before the gap (the map always tiles from Smallest)" go' [tei] = tei- go' _ = error "aroundCalDateTransition: too many before transitions"- bomb = error "aroundCalDateTransition: got expression when fixed expected"+ go' _ = error "aroundCalDateTransition: unreachable - more than one interval at the boundary before the gap"+ bomb = error "aroundCalDateTransition: unreachable - bracketing transition was an expression, not fixed ('go []' only fires in the fixed region)" -- | Represents a time zone. A 'TimeZone' can be used to instanciate a 'ZoneDateTime' from either and 'Instant' or a 'CalendarDateTime' data TimeZone =@@ -142,8 +141,27 @@ ,utcTransitionsMap :: UtcTransitionsMap ,calDateTransitionsMap :: CalDateTransitionsMap }- deriving (Eq, Show) +-- | Shows a 'TimeZone' by its identity only (the transition maps are a derived cache, not part of identity).+instance Show TimeZone where+ show tz = case zoneName tz of+ UTC -> "<TimeZone UTC>"+ Zone n -> "<TimeZone " ++ show n ++ ">"++-- | Two 'TimeZone's are equal when they denote the same zone (compared by identifier). The transition maps are a+-- derived lookup cache fully determined by the identifier, so they are not part of the zone's identity.+instance Eq TimeZone where+ a == b = zoneName a == zoneName b++instance Hashable TimeZone where+ hashWithSalt s = hashWithSalt s . zoneName++-- NOTE: 'TimeZone' deliberately has no 'NFData' instance. 'calDateTransitionsMap' is an 'IntervalMap' from the+-- 'fingertree' package, which depends only on 'base' and therefore provides no 'NFData' instance to force it. A+-- partial 'rnf' that forced only the identifier would silently leave the bulk of the value (the transition maps)+-- unevaluated, which would be a misleading 'NFData', so we omit it entirely. The same reasoning applies to+-- 'ZonedDateTime' and 'OffsetDateTime', which embed a 'TimeZone'.+ -- constructors fixedOffsetZone :: String -> Offset -> (UtcTransitionsMap, CalDateTransitionsMap, TransitionInfo)@@ -191,4 +209,14 @@ m' = toEnum m d = nthDayToDayOfMonth nth day m' y days' = fromIntegral $ yearMonthDayToDays y m' d- go (JulianExpression _cly _d _s) = error "need julian year day function"+ go (JulianExpression countLeaps day s) = Instant days' (fromIntegral s) 0+ where+ -- POSIX day-of-year transition. The @n@ form (countLeaps == True) is 0-based and counts 29.Feb; the @Jn@+ -- form (countLeaps == False) is 1-based and never counts 29.Feb, so 1.Mar is always day 60. NOTE: this is a+ -- day-of-year, unrelated to the Julian *calendar*.+ offset+ | countLeaps = day+ | isLeap && day >= 60 = day+ | otherwise = day - 1+ isLeap = maxDaysInMonth (toEnum 1) y == 29+ days' = fromIntegral $ yearMonthDayToDays y (toEnum 0) 1 + offset
src/Data/HodaTime/TimeZone/Olson.hs view
@@ -1,6 +1,7 @@ module Data.HodaTime.TimeZone.Olson ( getTransitions+ ,isOlsonFile ,ParseException(..) ) where@@ -17,10 +18,10 @@ import Control.Exception (Exception) import Control.Monad.Catch (MonadThrow, throwM) import Data.Typeable (Typeable)-import Data.HodaTime.Instant.Internal (Instant, fromSecondsSinceUnixEpoch, minus, bigBang)+import Data.HodaTime.Instant.Internal (Instant(..), fromSecondsSinceUnixEpoch, minus, bigBang) import Data.HodaTime.Duration.Internal (fromNanoseconds) import Data.HodaTime.Offset.Internal (Offset(..), adjustInstant)-import Data.HodaTime.Calendar.Gregorian.Internal (instantToYearMonthDay)+import Data.HodaTime.Calendar.Gregorian.Internal (instantToYearMonthDay, yearMonthDayToDays) data ParseException = ParseException String Int deriving (Typeable, Show)@@ -40,10 +41,10 @@ getTransitions' = do header@(Header magic version _ _ _ _ _ _) <- getHeader unless (magic == "TZif") (fail $ "unknown magic: " ++ magic)- (getInt, header'@(Header _ _ isGmtCount isStdCount _ _ typeCount _)) <- getCorrectHeader header+ (getInt, header'@(Header _ _ _ _ _ _ typeCount _)) <- getCorrectHeader header unless- (isGmtCount == isStdCount && isStdCount == typeCount)- (fail $ "format issue: sizes don't match: ttisgmtcnt = " ++ show isGmtCount ++ ", ttisstdcnt = " ++ show isStdCount ++ ", ttypecnt = " ++ show typeCount)+ (typeCount >= 1)+ (fail $ "format issue: ttypecnt must be at least 1 but is " ++ show typeCount) (transitions, indexes, tInfos) <- getPayload getInt header' tzString <- getTZString version finished <- isEmpty@@ -51,6 +52,15 @@ let (utcM, calDateM) = buildTransitionMaps (zip transitions indexes) tInfos tzString return (utcM, calDateM) +isOlsonFile :: L.ByteString -> Bool+isOlsonFile bs = case runGetOrFail getMagic bs of+ Left _ -> False -- If we can't load it for any reason, we wouldn't be able to use it as a time zone+ Right (_, _, x) -> x+ where+ getMagic = do+ (Header magic _ _ _ _ _ _ _) <- getHeader+ return $ magic == "TZif"+ -- Get combinators getCh :: Get Char@@ -128,9 +138,9 @@ getAbbr offset = takeWhile (/= '\NUL') . drop offset buildTransitionMaps :: [(Instant, Int)] -> [TransitionInfo] -> Maybe String -> (UtcTransitionsMap, CalDateTransitionsMap)-buildTransitionMaps transAndIndexes tInfos tzString = (utcMap, calDateMap')+buildTransitionMaps transAndIndexes tInfos tzString = (utcMap', calDateMap') where- calDateMap' = addLastCalDateEntry tzString' lastEntry lastTI calDateMap+ (utcMap', calDateMap') = addLastMapEntries tzString' lastEntry lastTI utcMap calDateMap tzString' = fmap parsePosixString tzString defaultTI = findDefaultTransInfo $ tInfos initialUtcTransitions = addUtcTransition bigBang defaultTI emptyUtcTransitions@@ -143,19 +153,20 @@ before = Entry . flip minus (fromNanoseconds 1) . adjustInstant (tiUtcOffset prevTI) $ tran tInfo = tInfos !! idx -addLastCalDateEntry :: Maybe (Either TransitionInfo TransitionExpressionInfo) -> IntervalEntry Instant -> TransitionInfo -> CalDateTransitionsMap- -> CalDateTransitionsMap-addLastCalDateEntry Nothing start ti calDateMap = addCalDateTransition start Largest ti calDateMap+addLastMapEntries :: Maybe (Either TransitionInfo TransitionExpressionInfo) -> IntervalEntry Instant -> TransitionInfo ->+ UtcTransitionsMap -> CalDateTransitionsMap -> (UtcTransitionsMap, CalDateTransitionsMap)+addLastMapEntries Nothing start ti utcMap calDateMap = (utcMap, addCalDateTransition start Largest ti calDateMap) -- NOTE: If the tzString does not have a time zone specification then the way we process the rest of the file should be correct (TODO: check offset) so we can ignore it-addLastCalDateEntry (Just (Left _)) start ti calDateMap = addCalDateTransition start Largest ti calDateMap-addLastCalDateEntry (Just (Right texpr@(TransitionExpressionInfo stdExpr _ stdTI _))) start ti calDateMap = calDateMap''+addLastMapEntries (Just (Left _)) start ti utcMap calDateMap = (utcMap, addCalDateTransition start Largest ti calDateMap)+addLastMapEntries (Just (Right texpr@(TransitionExpressionInfo _ _ stdTI _))) prevTran prevTI utcMap calDateMap = (utcMap', calDateMap'') where- calDateMap' = addCalDateTransition start before ti calDateMap- calDateMap'' = addCalDateTransitionExpression (Entry cdExprStart) Largest texpr calDateMap'- cdExprStart = adjustInstant (tiUtcOffset stdTI) $ exprStart- before = Entry . flip minus (fromNanoseconds 1) . adjustInstant (tiUtcOffset ti) $ exprStart- exprStart = yearExpressionToInstant (y + 1) stdExpr -- TODO: if we ever find the gap too large, we could add a check here before incrementing the year- y = case start of+ utcMap' = addUtcTransitionExpression exprStart texpr utcMap+ calDateMap' = addCalDateTransition prevTran before prevTI calDateMap+ calDateMap'' = addCalDateTransitionExpression (Entry exprStart) Largest texpr calDateMap'+ before = Entry . flip minus (fromNanoseconds 1) $ exprStart+ exprStart = adjustInstant (tiUtcOffset stdTI) $ Instant yearStart 0 0 -- time changes are usually once per year+ yearStart = fromIntegral $ yearMonthDayToDays (y+1) (toEnum 0) 1+ y = case prevTran of (Entry trans) -> let (yr, _, _) = instantToYearMonthDay trans in fromIntegral yr _ -> error "impossible: got non Entry for last valid transition"
src/Data/HodaTime/TimeZone/ParseTZ.hs view
@@ -22,15 +22,18 @@ stdOffset <- p_offset <?> "TZ Offset" p_dstExpression stdID stdOffset <|> (return . Left . TransitionInfo stdOffset False $ stdID) +-- NOTE: Transition times have to be UTC for the returned expressions p_dstExpression :: String -> Offset -> ExpParser (Either TransitionInfo TransitionExpressionInfo) p_dstExpression stdID stdOffset@(Offset stdOffsetSecs) = do dstID <- p_tzIdentifier dstOffset <- option (Offset $ stdOffsetSecs + toHour 1) p_offset- startExpr <- char ',' *> p_transitionExpression- endExpr <- char ',' *> p_transitionExpression+ startExpr <- char ',' *> p_transitionExpression stdOffsetSecs+ endExpr <- char ',' *> p_transitionExpression (toOffsetSecs dstOffset) let stdTI = TransitionInfo stdOffset False stdID let dstTI = TransitionInfo dstOffset True dstID return . Right $ TransitionExpressionInfo startExpr endExpr stdTI dstTI+ where+ toOffsetSecs (Offset secs) = secs p_tzIdentifier :: ExpParser String p_tzIdentifier = p_tzSpecialIdentifier <|> p_tzNormalIdentifier@@ -59,11 +62,13 @@ where optionalDigit = char ':' *> many1 digit -p_transitionExpression :: ExpParser TransitionExpression-p_transitionExpression = te <*> time+-- NOTE: Remove offset seconds to get to UTC time+p_transitionExpression :: Int -> ExpParser TransitionExpression+p_transitionExpression offsetSecs = te <*> time' where te = p_julianExpression <|> p_nthDayExpression time = option (toHour 2) (char '/' *> p_time)+ time' = (\x -> x - offsetSecs) <$> time p_julianExpression :: ExpParser (Int -> TransitionExpression) p_julianExpression = JulianExpression <$> cntLp <*> d
src/Data/HodaTime/TimeZone/Unix.hs view
@@ -3,19 +3,21 @@ loadUTC ,loadLocalZone ,loadTimeZone+ ,loadAvailableZones ,defaultLoadZoneFromOlsonFile ) where import Data.HodaTime.TimeZone.Internal import Data.HodaTime.TimeZone.Olson-import System.Directory (doesFileExist)+import System.Directory (doesFileExist, getDirectoryContents) import System.FilePath ((</>)) import qualified Data.ByteString.Lazy.Char8 as BS-import System.Posix.Files (readSymbolicLink)+import System.Posix.Files (readSymbolicLink, getFileStatus, isDirectory)+import System.FilePath.Posix (makeRelative) import Data.List (intercalate) import Control.Exception (Exception, throwIO)-import Control.Monad (unless)+import Control.Monad (unless, forM) import Data.Typeable (Typeable) -- exceptions@@ -45,10 +47,30 @@ loadLocalZone loadZoneFromOlsonFile = do let file = "/etc" </> "localtime" tzPath <- readSymbolicLink $ file- let tzName = timeZoneFromPath $ tzPath+ let tzName = timeZoneNameFromPath $ tzPath (utcM, calDateM) <- loadZoneFromOlsonFile file return (utcM, calDateM, tzName) +loadAvailableZones :: IO [String]+loadAvailableZones = traverseDir tzdbDir+ where+ toZoneName file = makeRelative tzdbDir file+ toResult file = do+ bs <- BS.readFile $ file+ let valid = isOlsonFile bs+ if valid+ then return [toZoneName file]+ else return []+ traverseDir top = do+ ds <- getDirectoryContents top+ paths <- forM (filter (not . flip elem [".", ".."]) ds) $ \d -> do+ let path = top </> d+ s <- getFileStatus path+ if isDirectory s+ then traverseDir path+ else toResult path+ return (concat paths)+ -- helper functions tzdbDir :: FilePath@@ -62,10 +84,8 @@ (utcM, calDateM) <- getTransitions bs return (utcM, calDateM) --- helper functions--timeZoneFromPath :: FilePath -> String-timeZoneFromPath = intercalate "/" . drp . foldr collect [[]]+timeZoneNameFromPath :: FilePath -> String+timeZoneNameFromPath = intercalate "/" . drp . foldr collect [[]] where drp = drop 1 . dropWhile (/= "zoneinfo") collect ch l@(x:xs)
src/Data/HodaTime/ZonedDateTime.hs view
@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------- -- |--- Module : Data.HodaTime.Instant+-- Module : Data.HodaTime.ZonedDateTime -- Copyright : (C) 2017 Jason Johnson -- License : BSD-style (see the file LICENSE) -- Maintainer : Jason Johnson <jason.johnson.081@gmail.com>@@ -22,25 +22,35 @@ -- * Conversion ,toCalendarDateTime ,toCalendarDate+ ,toInstant ,toLocalTime+ ,withCalendar -- * Accessors ,inDst ,zoneAbbreviation+ ,zoneId+ ,year+ ,month+ ,day+ ,hour+ ,minute+ ,second+ ,nanosecond -- * Special constructors ,fromCalendarDateTimeAll ,resolve -- * Exceptions- ,DateTimeDoesNotExistException(..)- ,DateTimeAmbiguousException(..)+ ,DateTimeDoesNotExistException+ ,DateTimeAmbiguousException ) where import Data.HodaTime.ZonedDateTime.Internal-import Data.HodaTime.CalendarDateTime.Internal (CalendarDateTime(..), CalendarDate(..), IsCalendarDateTime(..), IsCalendar(..), LocalTime)-import Data.HodaTime.LocalTime.Internal (second)+import Data.HodaTime.CalendarDateTime.Internal (CalendarDateTime(..), CalendarDate, IsCalendarDateTime(..), IsCalendar(..), LocalTime) import Data.HodaTime.Instant.Internal (Instant)+import qualified Data.HodaTime.LocalTime.Internal as LT(second) import Data.HodaTime.Offset.Internal (Offset(..), adjustInstant)-import Data.HodaTime.TimeZone.Internal (TimeZone, TransitionInfo(..), calDateTransitionsFor, aroundCalDateTransition, activeTransitionFor)+import Data.HodaTime.TimeZone.Internal (TimeZone, TZIdentifier(..), zoneName, TransitionInfo(..), calDateTransitionsFor, aroundCalDateTransition) import Control.Exception (Exception) import Control.Monad.Catch (MonadThrow, throwM) import Data.Typeable (Typeable)@@ -70,7 +80,7 @@ ambiguous zdt _ = zdt skipped (ZonedDateTime _ _ (TransitionInfo (Offset bOff) _ _)) (ZonedDateTime cdt tz ti@(TransitionInfo (Offset aOff) _ _)) = ZonedDateTime cdt' tz ti where- cdt' = modify (\s -> s + aOff - bOff) second cdt+ cdt' = modify (\s -> s + aOff - bOff) LT.second cdt modify f l = head . l ((:[]) . f) -- TODO: We may want to break down and define the 3 lens primitives we need somewhere -- | Returns the mapping of this 'CalendarDateTime' within the given 'TimeZone', with "strict" rules applied such that ambiguous or skipped date times@@ -92,15 +102,6 @@ zdts = fmap mkZdt . calDateTransitionsFor instant $ tz mkZdt = ZonedDateTime cdt tz --- | Returns the 'ZonedDateTime' represented by the passed 'Instant' within the given 'TimeZone'. This is always an unambiguous conversion.-fromInstant :: IsCalendarDateTime cal => Instant -> TimeZone -> ZonedDateTime cal-fromInstant instant tz = ZonedDateTime cdt tz ti- where- ti = activeTransitionFor instant tz- offset = tiUtcOffset ti- instant' = adjustInstant offset instant- cdt = fromAdjustedInstant instant'- -- | Takes two functions to determine how to resolve a 'CalendarDateTime' to a 'ZonedDateTime' in the case of ambiguity or skipped times. The first -- function is for the ambigous case and is past the first matching 'ZonedDateTime', followed by the second match. The second function is for the case -- that the 'CalendarDateTime' doesn't exist in the 'TimeZone' (e.g. in a spring-forward situation, there will be a missing hour), the first@@ -128,10 +129,21 @@ toCalendarDateTime :: ZonedDateTime cal -> CalendarDateTime cal toCalendarDateTime (ZonedDateTime cdt _ _) = cdt +-- | Return the 'Instant' (a universal, UTC-based moment) represented by this 'ZonedDateTime'. This is the inverse+-- of 'fromInstant': it takes the local 'CalendarDateTime' back to its unadjusted instant and then removes the+-- zone's UTC offset.+toInstant :: IsCalendarDateTime cal => ZonedDateTime cal -> Instant+toInstant (ZonedDateTime cdt _ (TransitionInfo (Offset offSecs) _ _)) = adjustInstant (Offset (negate offSecs)) (toUnadjustedInstant cdt)+ -- | Return the 'CalendarDate' represented by this 'ZonedDateTime'. toCalendarDate :: ZonedDateTime cal -> CalendarDate cal toCalendarDate (ZonedDateTime (CalendarDateTime cd _) _ _) = cd +-- | Re-express a 'ZonedDateTime' in a different calendar, preserving the exact 'Instant' and time zone; only the+-- calendar that the local date\/time is labelled in changes. The target calendar is chosen by the result type.+withCalendar :: (IsCalendarDateTime a, IsCalendarDateTime b) => ZonedDateTime a -> ZonedDateTime b+withCalendar (ZonedDateTime cdt tz ti) = ZonedDateTime (fromAdjustedInstant (toUnadjustedInstant cdt)) tz ti+ -- | Return the 'LocalTime' represented by this 'ZonedDateTime'. toLocalTime :: ZonedDateTime cal -> LocalTime toLocalTime (ZonedDateTime (CalendarDateTime _ lt) _ _) = lt@@ -145,3 +157,10 @@ -- | Return a 'String' representing the abbreviation for the TimeZone this 'ZonedDateTime' is currently in. zoneAbbreviation :: ZonedDateTime cal -> String zoneAbbreviation (ZonedDateTime _ _ (TransitionInfo _ _ abbr)) = abbr++-- | Return the identifier of this 'ZonedDateTime's time zone, e.g. @Europe/Zurich@ (or @UTC@). Unlike+-- 'zoneAbbreviation' this is unambiguous, so it is the form to use when a value needs to round-trip through text.+zoneId :: ZonedDateTime cal -> String+zoneId (ZonedDateTime _ tz _) = case zoneName tz of+ UTC -> "UTC"+ Zone n -> n
src/Data/HodaTime/ZonedDateTime/Internal.hs view
@@ -1,17 +1,101 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-} module Data.HodaTime.ZonedDateTime.Internal (- ZonedDateTime(..)+ ZonedDateTime(..)+ ,fromInstant+ ,year+ ,month+ ,day+ ,hour+ ,minute+ ,second+ ,nanosecond ) where -import Data.HodaTime.CalendarDateTime.Internal (CalendarDateTime)-import Data.HodaTime.TimeZone.Internal (TimeZone, TransitionInfo)+import Data.HodaTime.CalendarDateTime.Internal (CalendarDateTime, IsCalendarDateTime, IsCalendar, fromAdjustedInstant, toUnadjustedInstant)+import qualified Data.HodaTime.CalendarDateTime.Internal as CDT+import qualified Data.HodaTime.LocalTime.Internal as LT+import Data.HodaTime.TimeZone.Internal (TimeZone, TZIdentifier(..), TransitionInfo, activeTransitionFor, tiUtcOffset, zoneName)+import Data.HodaTime.Offset.Internal (Offset(..), adjustInstant)+import Data.HodaTime.Instant.Internal (Instant)+import Data.HodaTime.Internal.Lens (view)+import Data.Hashable (Hashable(..)) -- | A CalendarDateTime in a specific time zone. A 'ZonedDateTime' is global and maps directly to a single 'Instant'. data ZonedDateTime cal = ZonedDateTime { zdtCalendarDateTime :: CalendarDateTime cal, zdtTimeZone :: TimeZone, zdtActiveTransition :: TransitionInfo }- deriving (Eq, Show)--- TODO: We should have an Ord instance, we can just ignore the timezone field. It would be especially good so that when CalendarDateTime is equal we can--- TODO: compare the TransitionInfo to see which one comes first++deriving instance Eq (CDT.Date cal) => Eq (ZonedDateTime cal)++-- | Renders a 'ZonedDateTime' as the 'fromInstant' call that reconstructs it from its physical 'Instant' and zone.+instance IsCalendarDateTime cal => Show (ZonedDateTime cal) where+ showsPrec p (ZonedDateTime cdt tz ti) = showParen (p > 10) $+ showString "fromInstant " . showsPrec 11 inst . showChar ' ' . showsPrec 11 tz+ where+ inst = adjustInstant (negateOffset (tiUtcOffset ti)) (toUnadjustedInstant cdt)+ negateOffset (Offset s) = Offset (negate s)++-- | Orders 'ZonedDateTime's by the 'Instant' they represent (their global\/UTC position on the time line), falling+-- back to the zone identifier as a tie-break so that two zones observing the same instant still have a total order.+-- NOTE: this compares by physical time, not by the local wall-clock 'CalendarDateTime'.+instance (IsCalendarDateTime cal, Eq (CDT.Date cal)) => Ord (ZonedDateTime cal) where+ compare a b = compare (instantOf a) (instantOf b) <> compare (zid a) (zid b)+ where+ instantOf (ZonedDateTime cdt _ ti) = adjustInstant (negateOffset (tiUtcOffset ti)) (toUnadjustedInstant cdt)+ negateOffset (Offset s) = Offset (negate s)+ zid (ZonedDateTime _ tz _) = case zoneName tz of+ UTC -> "UTC"+ Zone n -> n++-- | Hashes a 'ZonedDateTime' by its identity: the local 'CalendarDateTime', the zone (by identifier) and the active+-- transition. Consistent with '(==)', which compares those same components.+-- NOTE: no 'NFData' instance is provided because 'ZonedDateTime' embeds a 'TimeZone', whose fingertree-based+-- transition maps cannot be forced (see 'Data.HodaTime.TimeZone.Internal').+instance Hashable (CDT.Date cal) => Hashable (ZonedDateTime cal) where+ hashWithSalt s (ZonedDateTime cdt tz ti) = s `hashWithSalt` cdt `hashWithSalt` tz `hashWithSalt` ti+++-- | Returns the 'ZonedDateTime' represented by the passed 'Instant' within the given 'TimeZone'. This is always an unambiguous conversion.+fromInstant :: IsCalendarDateTime cal => Instant -> TimeZone -> ZonedDateTime cal+fromInstant instant tz = ZonedDateTime cdt tz ti+ where+ ti = activeTransitionFor instant tz+ offset = tiUtcOffset ti+ instant' = adjustInstant offset instant+ cdt = fromAdjustedInstant instant'++-- TODO: We'd like to define lenses here but they must all be getters. Then we could take advantage of the type class, but to do that we probably have to pull the functor constraint to the+-- TODO: class level. This would be a big undertaking so we'll look at it after the merge++-- | Accessor for the Year of a 'ZonedDateTime'.+year :: IsCalendar cal => ZonedDateTime cal -> CDT.Year+year (ZonedDateTime cdt _ _) = view CDT.year cdt++-- | Accessor for the Month of a 'ZonedDateTime'.+month :: IsCalendar cal => ZonedDateTime cal -> CDT.Month cal+month (ZonedDateTime cdt _ _) = CDT.month cdt++-- | Accessor for the Day of a 'ZonedDateTime'.+day :: IsCalendar cal => ZonedDateTime cal -> CDT.DayOfMonth+day (ZonedDateTime cdt _ _) = view CDT.day cdt++-- | Accessor for the Hour of a 'ZonedDateTime'.+hour :: IsCalendar cal => ZonedDateTime cal -> LT.Hour+hour (ZonedDateTime cdt _ _) = view LT.hour cdt++-- | Accessor for the Minute of a 'ZonedDateTime'.+minute :: IsCalendar cal => ZonedDateTime cal -> LT.Minute+minute (ZonedDateTime cdt _ _) = view LT.minute cdt++-- | Accessor for the Second of a 'ZonedDateTime'.+second :: IsCalendar cal => ZonedDateTime cal -> LT.Second+second (ZonedDateTime cdt _ _) = view LT.second cdt++-- | Accessor for the Nanosecond of a 'ZonedDateTime'.+nanosecond :: IsCalendar cal => ZonedDateTime cal -> LT.Nanosecond+nanosecond (ZonedDateTime cdt _ _) = view LT.nanosecond cdt -- helper functions
+ tests/HodaTime/Calendar/CopticTest.hs view
@@ -0,0 +1,105 @@+module HodaTime.Calendar.CopticTest+(+ copticTests+)+where++import Test.Tasty+import Test.Tasty.QuickCheck as QC+import Test.Tasty.HUnit+import Data.Maybe (fromJust)+import Data.Time.Calendar (Day, fromGregorian)+import qualified Data.Time.Calendar.Julian as J+import Data.Time.Clock (UTCTime(..))+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)++import HodaTime.Util+import Data.HodaTime.CalendarDate (day, monthl, month, year, next, previous, dayOfWeek, DayNth(..), CalendarDate)+import Data.HodaTime.Calendar.Coptic (calendarDate, fromNthDay, fromWeekDate, Coptic, Month(..), DayOfWeek(..))+import Data.HodaTime.Instant (fromSecondsSinceUnixEpoch)+import Data.HodaTime.TimeZone (utc)+import Data.HodaTime.ZonedDateTime (fromInstant, ZonedDateTime)+import qualified Data.HodaTime.ZonedDateTime as Z++copticTests :: TestTree+copticTests = testGroup "Coptic Tests" [qcProps, unitTests]++qcProps :: TestTree+qcProps = testGroup "(checked by QuickCheck)" [roundTripProps, lensProps, nthDayProps]++unitTests :: TestTree+unitTests = testGroup "Unit tests" [structureUnits, crossCalendarUnits]++-- | Decode a Coptic date to (day, 1-based month, year) for explicit expected-value assertions.+ymd :: CalendarDate Coptic -> (Int, Int, Int)+ymd x = (get day x, succ . fromEnum $ month x, get year x)++-- | Data.Time has no Coptic calendar, so we verify the construct -> decode bijection directly.+roundTripProps :: TestTree+roundTripProps = testGroup "Constructor"+ [+ QC.testProperty "construct -> decode round-trips" testRoundTrip+ ]+ where+ testRoundTrip (RandomCopticDate y m d) = (ymd <$> calendarDate d m y) == Just (d, succ (fromEnum m), y)++lensProps :: TestTree+lensProps = testGroup "Lens"+ [+ QC.testProperty "dayOfWeek . next n dow $ date == dow" testNextDoW+ ,QC.testProperty "next n (dayOfWeek date) date == modify (+ n * 7) day date" $ testDirection next (+)+ ,QC.testProperty "previous n (dayOfWeek date) date == modify (- n * 7) day date" $ testDirection previous $ flip (-)+ ]+ where+ epochDay = fromJust $ calendarDate 1 Thout 1716+ testNextDoW dow (Positive n) = (dayOfWeek . next n dow $ epochDay) == dow+ testDirection dir adjust (Positive n) = dir n (dayOfWeek epochDay) epochDay == modify (adjust $ n * 7) day epochDay++-- | 'fromNthDay' and 'fromWeekDate' are the generic constructors instantiated for Coptic. We skip the short thirteenth+-- month (which has fewer than 7 days, so a given weekday may not occur) to keep the properties total.+nthDayProps :: TestTree+nthDayProps = testGroup "fromNthDay / fromWeekDate"+ [+ QC.testProperty "fromNthDay First dow is the first such weekday (day 1..7)" testFirst+ ,QC.testProperty "fromNthDay Last dow is the last such weekday (final week)" testLast+ ,QC.testProperty "fromWeekDate lands on the requested day-of-week" testWeekDoW+ ]+ where+ testFirst dow (RandomCopticDate y m _)+ | m == PiKogiEnavot = True+ | otherwise = let r = fromNthDay First dow m y in (dayOfWeek <$> r) == Just dow && maybe False (\d -> get day d >= 1 && get day d <= 7) r+ testLast dow (RandomCopticDate y m _)+ | m == PiKogiEnavot = True+ | otherwise = let r = fromNthDay Last dow m y in (dayOfWeek <$> r) == Just dow && maybe False (\d -> get day d >= 24) r+ testWeekDoW dow (RandomCopticDate y _ _) = maybe True ((== dow) . dayOfWeek) (fromWeekDate 1 dow y)++structureUnits :: TestTree+structureUnits = testGroup "Structure"+ [+ testCase "30 Thout is valid" $ (ymd <$> calendarDate 30 Thout 1716) @?= Just (30, 1, 1716)+ ,testCase "31 Thout is invalid (months are 30 days)" $ calendarDate 31 Thout 1716 @?= Nothing+ ,testCase "5 PiKogiEnavot is valid in a non-leap year (1732)" $ (ymd <$> calendarDate 5 PiKogiEnavot 1732) @?= Just (5, 13, 1732)+ ,testCase "6 PiKogiEnavot is valid in a leap year (1731, 1731 mod 4 == 3)" $ (ymd <$> calendarDate 6 PiKogiEnavot 1731) @?= Just (6, 13, 1731)+ ,testCase "6 PiKogiEnavot is invalid in a non-leap year (1732)" $ calendarDate 6 PiKogiEnavot 1732 @?= Nothing+ ,testCase "1 Thout + 1 month == 1 Paopi" $ (ymd <$> (modify (+1) monthl <$> calendarDate 1 Thout 1716)) @?= Just (1, 2, 1716)+ ,testCase "1 Mesori + 1 month == 1 PiKogiEnavot (12th -> 13th month)" $ (ymd <$> (modify (+1) monthl <$> calendarDate 1 Mesori 1716)) @?= Just (1, 13, 1716)+ ]++-- | The strongest checks: the same absolute day, anchored via Data.Time, must decode to the expected Coptic date.+-- The epoch (Coptic 1.Thout.1 = Julian 29.Aug.284) is pinned via 'Data.Time.Calendar.Julian', and two well-known+-- Nayrouz (Coptic new year) dates are pinned via the Gregorian calendar.+crossCalendarUnits :: TestTree+crossCalendarUnits = testGroup "Cross-calendar (Instant)"+ [+ testCase "epoch: Julian 29.Aug.284 is Coptic 1 Thout 1" $ copticOfDay (J.fromJulian 284 8 29) >>= (@?= (1, 1, 1))+ ,testCase "Nayrouz 1738 = 11.Sep.2021 (Gregorian)" $ copticOfDay (fromGregorian 2021 9 11) >>= (@?= (1738, 1, 1))+ ,testCase "Nayrouz 1716 = 12.Sep.1999 (Gregorian, pre-leap)" $ copticOfDay (fromGregorian 1999 9 12) >>= (@?= (1716, 1, 1))+ ]++-- | View the UTC midnight of a Data.Time 'Day' as a Coptic date, returning (year, 1-based month, day).+copticOfDay :: Day -> IO (Int, Int, Int)+copticOfDay dt = do+ tz <- utc+ let secs = round (utcTimeToPOSIXSeconds (UTCTime dt 0))+ zdt = fromInstant (fromSecondsSinceUnixEpoch secs) tz :: ZonedDateTime Coptic+ return (Z.year zdt, succ (fromEnum (Z.month zdt)), Z.day zdt)
tests/HodaTime/Calendar/GregorianTest.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} -- for the polymorphic 'ymd' helper's Enum (MoY d) constraint module HodaTime.Calendar.GregorianTest ( gregorianTests@@ -11,7 +12,7 @@ import Data.Time.Calendar (fromGregorianValid, toGregorian) import HodaTime.Util-import Data.HodaTime.CalendarDate (day, monthl, month, year, next, previous, dayOfWeek, DayNth(..))+import Data.HodaTime.CalendarDate (day, monthl, month, year, next, previous, dayOfWeek, DayNth(..), HasDate, MoY) import Data.HodaTime.Calendar.Gregorian (calendarDate, fromNthDay, Month(..), DayOfWeek(..)) import qualified Data.HodaTime.Calendar.Gregorian as G import qualified Data.HodaTime.Calendar.Iso as Iso@@ -20,11 +21,39 @@ gregorianTests = testGroup "Gregorian Tests" [qcProps, unitTests] qcProps :: TestTree-qcProps = testGroup "(checked by QuickCheck)" [constructorProps, lensProps]+qcProps = testGroup "(checked by QuickCheck)" [constructorProps, lensProps, nthDayProps] unitTests :: TestTree-unitTests = testGroup "Unit tests" [constructorUnits, lensUnits]+unitTests = testGroup "Unit tests" [constructorUnits, lensUnits, boundaryUnits] +-- | Decode a date to (day, 1-based month, year) for explicit expected-value assertions.+ymd :: (HasDate d, Enum (MoY d)) => d -> (Int, Int, Int)+ymd x = (get day x, succ . fromEnum $ month x, get year x)++-- | Hardcoded boundary regression tests for the Gregorian cycle representation. These are the discrete,+-- known-tricky transitions (century edges, the cycle edge / extra leap day, and the 1582 validity threshold)+-- that the random generators in the 1900-2040 range never reach.+boundaryUnits :: TestTree+boundaryUnits = testGroup "Gregorian boundaries"+ [+ -- century edge: 2100 is NOT a leap year+ testCase "28 Feb 2100 constructs correctly" $ (ymd <$> calendarDate 28 February 2100) @?= Just (28, 2, 2100)+ ,testCase "29 Feb 2100 is invalid (2100 not leap)" $ calendarDate 29 February 2100 @?= Nothing+ ,testCase "31 Dec 2099 + 1 day == 1 Jan 2100" $ (ymd <$> (modify (+ 1) day <$> calendarDate 31 December 2099)) @?= Just (1, 1, 2100)+ ,testCase "1 Jan 2100 - 1 day == 31 Dec 2099" $ (ymd <$> (modify (subtract 1) day <$> calendarDate 1 January 2100)) @?= Just (31, 12, 2099)+ ,testCase "28 Feb 2100 + 1 day == 1 Mar 2100" $ (ymd <$> (modify (+ 1) day <$> calendarDate 28 February 2100)) @?= Just (1, 3, 2100)+ -- cycle edge: 2400 IS a leap year; 29 Feb 2400 is the extra-cycle-day+ ,testCase "29 Feb 2400 constructs correctly (extra-cycle-day)" $ (ymd <$> calendarDate 29 February 2400) @?= Just (29, 2, 2400)+ ,testCase "28 Feb 2400 + 1 day == 29 Feb 2400" $ (ymd <$> (modify (+ 1) day <$> calendarDate 28 February 2400)) @?= Just (29, 2, 2400)+ ,testCase "29 Feb 2400 + 1 day == 1 Mar 2400" $ (ymd <$> (modify (+ 1) day <$> calendarDate 29 February 2400)) @?= Just (1, 3, 2400)+ ,testCase "31 Dec 2399 + 1 day == 1 Jan 2400" $ (ymd <$> (modify (+ 1) day <$> calendarDate 31 December 2399)) @?= Just (1, 1, 2400)+ ,testCase "29 Feb 2400 + 1 year clamps to 28 Feb 2401" $ (ymd <$> (modify (+ 1) year <$> calendarDate 29 February 2400)) @?= Just (28, 2, 2401)+ -- 1582 validity threshold: 15 Oct 1582 is the first valid Gregorian date+ ,testCase "1 Oct 1582 is invalid" $ calendarDate 1 October 1582 @?= Nothing+ ,testCase "15 Oct 1582 constructs correctly" $ (ymd <$> calendarDate 15 October 1582) @?= Just (15, 10, 1582)+ ,testCase "16 Oct 1582 - 1 day == 15 Oct 1582" $ (ymd <$> (modify (subtract 1) day <$> calendarDate 16 October 1582)) @?= Just (15, 10, 1582)+ ]+ constructorProps :: TestTree constructorProps = testGroup "Constructor" [@@ -50,14 +79,34 @@ ,QC.testProperty "dayOfWeek . next n dow $ date == dow" $ testNextDoW ,QC.testProperty "next n (dayOfWeek date) date == modify (+ n * 7) day date" $ testDirection next (+) ,QC.testProperty "previous n (dayOfWeek date) date == modify (- n * 7) day date" $ testDirection previous $ flip (-)+ ,QC.testProperty "next 1 dow date < modify (+ 8) day date" $ testDirectionRange next (<) (+)+ ,QC.testProperty "previous 1 dow date > modify (- 8) day date" $ testDirectionRange previous (>) $ flip (-) ] where mkcd d m = fromJust . calendarDate d m testMonthAdd d (CycleYear y) m add = get day (modify (+ add) monthl $ mkcd d m (y + 1900)) == d -- NOTE: We fix the year so we don't run out of tests testNextDoW dow (Positive n) = (dayOfWeek . next n dow $ epochDay) == dow testDirection dir adjust (Positive n) = dir n (dayOfWeek epochDay) epochDay == modify (adjust $ n * 7) day epochDay+ testDirectionRange dir gtlt adjust dow (RandomStandardDate y m d) = let cd = mkcd d m y in dir 1 dow cd `gtlt` modify (adjust 8) day cd epochDay = mkcd 1 March 2000 +nthDayProps :: TestTree+nthDayProps = testGroup "fromNthDay / fromWeekDate"+ [+ QC.testProperty "fromNthDay First dow is the first such weekday (day 1..7)" testFirst+ ,QC.testProperty "fromNthDay Last dow is the last such weekday (final week)" testLast+ ,QC.testProperty "fromWeekDate lands on the requested day-of-week" testWeekDoW+ ]+ where+ testFirst dow (RandomStandardDate y m _) =+ let r = fromNthDay First dow m y+ in (dayOfWeek <$> r) == Just dow && maybe False (\d -> get day d >= 1 && get day d <= 7) r+ testLast dow (RandomStandardDate y m _) =+ let r = fromNthDay Last dow m y+ in (dayOfWeek <$> r) == Just dow && maybe False (\d -> get day d >= 22) r+ testWeekDoW dow (RandomStandardDate y _ _) (Positive w) =+ maybe True ((== dow) . dayOfWeek) (G.fromWeekDate (1 + w `mod` 50) dow y)+ constructorUnits :: TestTree constructorUnits = testGroup "Constructor" [@@ -70,6 +119,9 @@ ,testCase "Holidays in year 2000" $ test2k (usaHolidays 2000) ,testCase "Holidays in year 2001" $ test2001 (usaHolidays 2001) ,testCase "Holidays in year 1582" $ test1582 (usaHolidays 1582)+ ,testCase "fromNthDay Last, when the month ends on that weekday, is the last day (not a week early)" $+ let lastDay = fromJust $ calendarDate 31 December 2000 -- 31.Dec.2000 is a Sunday+ in fromNthDay Last (dayOfWeek lastDay) December 2000 @?= Just lastDay ] where test2k hs = do
+ tests/HodaTime/Calendar/HebrewTest.hs view
@@ -0,0 +1,131 @@+module HodaTime.Calendar.HebrewTest+(+ hebrewTests+)+where++import Test.Tasty+import Test.Tasty.QuickCheck as QC+import Test.Tasty.HUnit+import Data.Maybe (fromJust)+import Data.Time.Calendar (Day, fromGregorian)+import Data.Time.Clock (UTCTime(..))+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)++import HodaTime.Util+import Data.HodaTime.CalendarDate (day, monthl, month, year, next, previous, dayOfWeek, DayNth(..), CalendarDate)+import Data.HodaTime.Calendar.Hebrew (calendarDate, calendarDate', fromNthDay, fromWeekDate, HebrewCivil, HebrewScriptural, Month(..), DayOfWeek(..))+import Data.HodaTime.Instant (fromSecondsSinceUnixEpoch)+import Data.HodaTime.TimeZone (utc)+import Data.HodaTime.ZonedDateTime (fromInstant, ZonedDateTime)+import qualified Data.HodaTime.ZonedDateTime as Z++hebrewTests :: TestTree+hebrewTests = testGroup "Hebrew Tests" [qcProps, unitTests]++qcProps :: TestTree+qcProps = testGroup "(checked by QuickCheck)" [roundTripProps, lensProps, nthDayProps]++unitTests :: TestTree+unitTests = testGroup "Unit tests" [structureUnits, numberingUnits, crossCalendarUnits]++-- | Decode a civil Hebrew date to (day, 1-based civil month, year) for explicit expected-value assertions.+ymd :: CalendarDate HebrewCivil -> (Int, Int, Int)+ymd x = (get day x, succ . fromEnum $ month x, get year x)++-- | Data.Time has no Hebrew calendar, so we verify the construct -> decode bijection directly. 'RandomHebrewDate'+-- only generates valid dates (the leap month 'AdarI' in leap years, the swing months capped at their shorter length).+roundTripProps :: TestTree+roundTripProps = testGroup "Constructor"+ [+ QC.testProperty "construct -> decode round-trips" testRoundTrip+ ]+ where+ testRoundTrip (RandomHebrewDate y m d) = (ymd <$> calendarDate d m y) == Just (d, succ (fromEnum m), y)++lensProps :: TestTree+lensProps = testGroup "Lens"+ [+ QC.testProperty "dayOfWeek . next n dow $ date == dow" testNextDoW+ ,QC.testProperty "next n (dayOfWeek date) date == modify (+ n * 7) day date" $ testDirection next (+)+ ,QC.testProperty "previous n (dayOfWeek date) date == modify (- n * 7) day date" $ testDirection previous $ flip (-)+ ]+ where+ anchorDay = fromJust $ calendarDate 1 Tishri 5784+ testNextDoW dow (Positive n) = (dayOfWeek . next n dow $ anchorDay) == dow+ testDirection dir adjust (Positive n) = dir n (dayOfWeek anchorDay) anchorDay == modify (adjust $ n * 7) day anchorDay++-- | 'fromNthDay' and 'fromWeekDate' are the generic constructors instantiated for Hebrew. Every Hebrew month has at+-- least 29 days, so a given weekday always occurs and the properties are total.+nthDayProps :: TestTree+nthDayProps = testGroup "fromNthDay / fromWeekDate"+ [+ QC.testProperty "fromNthDay First dow is the first such weekday (day 1..7)" testFirst+ ,QC.testProperty "fromNthDay Last dow is the last such weekday (final week)" testLast+ ,QC.testProperty "fromWeekDate lands on the requested day-of-week" testWeekDoW+ ]+ where+ testFirst dow (RandomHebrewDate y m _) = let r = fromNthDay First dow m y in (dayOfWeek <$> r) == Just dow && maybe False (\d -> get day d >= 1 && get day d <= 7) r+ testLast dow (RandomHebrewDate y m _) = let r = fromNthDay Last dow m y in (dayOfWeek <$> r) == Just dow && maybe False (\d -> get day d >= 22) r+ testWeekDoW dow (RandomHebrewDate y _ _) = maybe True ((== dow) . dayOfWeek) (fromWeekDate 1 dow y)++-- | The interesting Hebrew structure: the leap month 'AdarI' (present only in leap years) and the two swing months+-- 'Cheshvan' \/ 'Kislev' (29 or 30 days depending on the year). Concrete years: 5784 is leap (deficient); 5783 is a+-- complete common year (Cheshvan 30, Kislev 30); 5786 is a regular common year (Cheshvan 29, Kislev 30); 5781 is a+-- deficient common year (Cheshvan 29, Kislev 29).+structureUnits :: TestTree+structureUnits = testGroup "Structure"+ [+ testCase "30 Tishri 5784 is valid (Tishri always has 30 days)" $ (ymd <$> calendarDate 30 Tishri 5784) @?= Just (30, 1, 5784)+ ,testCase "29 Adar 5786 is valid (Adar always has 29 days)" $ (ymd <$> calendarDate 29 Adar 5786) @?= Just (29, 7, 5786)+ ,testCase "30 Cheshvan 5783 is valid (complete year)" $ (ymd <$> calendarDate 30 Cheshvan 5783) @?= Just (30, 2, 5783)+ ,testCase "30 Cheshvan 5786 is invalid (regular year: Cheshvan has 29)" $ calendarDate 30 Cheshvan 5786 @?= Nothing+ ,testCase "30 Kislev 5786 is valid (regular year: Kislev has 30)" $ (ymd <$> calendarDate 30 Kislev 5786) @?= Just (30, 3, 5786)+ ,testCase "30 Kislev 5781 is invalid (deficient year: Kislev has 29)" $ calendarDate 30 Kislev 5781 @?= Nothing+ ,testCase "30 AdarI 5784 is valid (leap year has the extra month)" $ (ymd <$> calendarDate 30 AdarI 5784) @?= Just (30, 6, 5784)+ ,testCase "1 AdarI 5786 is invalid (common year has no AdarI)" $ calendarDate 1 AdarI 5786 @?= Nothing+ ,testCase "1 Shevat 5784 + 1 month == 1 AdarI (leap year keeps AdarI)" $ (ymd <$> (modify (+1) monthl <$> calendarDate 1 Shevat 5784)) @?= Just (1, 6, 5784)+ ,testCase "1 Shevat 5784 + 2 months == 1 Adar (leap year)" $ (ymd <$> (modify (+2) monthl <$> calendarDate 1 Shevat 5784)) @?= Just (1, 7, 5784)+ ,testCase "1 Shevat 5786 + 1 month == 1 Adar (common year skips AdarI)" $ (ymd <$> (modify (+1) monthl <$> calendarDate 1 Shevat 5786)) @?= Just (1, 7, 5786)+ ,testCase "1 Elul 5785 + 1 month == 1 Tishri 5786 (year rolls at Tishri)"$ (ymd <$> (modify (+1) monthl <$> calendarDate 1 Elul 5785)) @?= Just (1, 1, 5786)+ ,testCase "30 AdarI 5784 + 1 year == 29 Adar 5785 (AdarI -> Adar, common)"$ (ymd <$> (modify (+1) year <$> calendarDate 30 AdarI 5784)) @?= Just (29, 7, 5785)+ ,testCase "year 0 is out of range" $ calendarDate 1 Tishri 0 @?= Nothing+ ]++-- | The numbering is carried in the type: the same physical date is numbered differently by civil ('Tishri' = 1) and+-- scriptural ('Nisan' = 1) conventions, but the underlying day, month value and year are identical.+numberingUnits :: TestTree+numberingUnits = testGroup "Month numbering (civil vs scriptural)"+ [+ testCase "civil: Tishri is month 1" $ fromEnum (Tishri :: Month HebrewCivil) @?= 0+ ,testCase "scriptural: Tishri is month 7" $ fromEnum (Tishri :: Month HebrewScriptural) @?= 6+ ,testCase "civil: Nisan is month 8" $ fromEnum (Nisan :: Month HebrewCivil) @?= 7+ ,testCase "scriptural: Nisan is month 1" $ fromEnum (Nisan :: Month HebrewScriptural) @?= 0+ ,testCase "civil: toEnum 0 == Tishri" $ (toEnum 0 :: Month HebrewCivil) @?= Tishri+ ,testCase "scriptural: toEnum 0 == Nisan" $ (toEnum 0 :: Month HebrewScriptural) @?= Nisan+ ,testCase "same date is Nisan (civil), numbered 8" $ (succ . fromEnum . month <$> calendarDate 15 Nisan 5784) @?= Just 8+ ,testCase "same date is Nisan (scriptural), numbered 1" $ (succ . fromEnum . month <$> scripturalNisan) @?= Just 1+ ,testCase "numbering does not move the day/year" $ (dayYear <$> calendarDate 15 Nisan 5784, dayYear <$> scripturalNisan) @?= (Just (15, 5784), Just (15, 5784))+ ]+ where+ scripturalNisan = calendarDate' 15 Nisan 5784 :: Maybe (CalendarDate HebrewScriptural)+ dayYear x = (get day x, get year x)++-- | The strongest checks: the same absolute day, anchored via Data.Time, must decode to the expected Hebrew date. The+-- anchors are well-known Gregorian equivalents (Rosh Hashanah of three years and Passover), independently verified.+crossCalendarUnits :: TestTree+crossCalendarUnits = testGroup "Cross-calendar (Instant)"+ [+ testCase "16.Sep.2023 (Gregorian) is 1 Tishri 5784 (Rosh Hashanah)" $ hebrewOfDay (fromGregorian 2023 9 16) >>= (@?= (5784, 1, 1))+ ,testCase "23.Apr.2024 (Gregorian) is 15 Nisan 5784 (Passover)" $ hebrewOfDay (fromGregorian 2024 4 23) >>= (@?= (5784, 8, 15))+ ,testCase "3.Oct.2024 (Gregorian) is 1 Tishri 5785 (Rosh Hashanah)" $ hebrewOfDay (fromGregorian 2024 10 3) >>= (@?= (5785, 1, 1))+ ,testCase "23.Sep.2025 (Gregorian) is 1 Tishri 5786 (Rosh Hashanah)" $ hebrewOfDay (fromGregorian 2025 9 23) >>= (@?= (5786, 1, 1))+ ]++-- | View the UTC midnight of a Data.Time 'Day' as a civil Hebrew date, returning (year, 1-based civil month, day).+hebrewOfDay :: Day -> IO (Int, Int, Int)+hebrewOfDay dt = do+ tz <- utc+ let secs = round (utcTimeToPOSIXSeconds (UTCTime dt 0))+ zdt = fromInstant (fromSecondsSinceUnixEpoch secs) tz :: ZonedDateTime HebrewCivil+ return (Z.year zdt, succ (fromEnum (Z.month zdt)), Z.day zdt)
+ tests/HodaTime/Calendar/IslamicTest.hs view
@@ -0,0 +1,119 @@+module HodaTime.Calendar.IslamicTest+(+ islamicTests+)+where++import Test.Tasty+import Test.Tasty.QuickCheck as QC+import Test.Tasty.HUnit+import Data.Maybe (fromJust, isJust)+import Data.Time.Calendar (Day, fromGregorian)+import Data.Time.Clock (UTCTime(..))+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)++import HodaTime.Util+import Data.HodaTime.CalendarDate (day, monthl, month, year, next, previous, dayOfWeek, DayNth(..), CalendarDate)+import Data.HodaTime.Calendar.Islamic (calendarDate, calendarDate', fromNthDay, fromWeekDate, IslamicBcl, IslamicBase15, IslamicIndian, IslamicHabashAlHasib, Month(..), DayOfWeek(..))+import Data.HodaTime.Instant (fromSecondsSinceUnixEpoch)+import Data.HodaTime.TimeZone (utc)+import Data.HodaTime.ZonedDateTime (fromInstant, ZonedDateTime)+import qualified Data.HodaTime.ZonedDateTime as Z++islamicTests :: TestTree+islamicTests = testGroup "Islamic Tests" [qcProps, unitTests]++qcProps :: TestTree+qcProps = testGroup "(checked by QuickCheck)" [roundTripProps, lensProps, nthDayProps]++unitTests :: TestTree+unitTests = testGroup "Unit tests" [structureUnits, leapPatternUnits, crossCalendarUnits]++-- | Decode an Islamic date to (day, 1-based month, year) for explicit expected-value assertions.+ymd :: CalendarDate IslamicBcl -> (Int, Int, Int)+ymd x = (get day x, succ . fromEnum $ month x, get year x)++-- | Data.Time has no Islamic calendar, so we verify the construct -> decode bijection directly.+roundTripProps :: TestTree+roundTripProps = testGroup "Constructor"+ [+ QC.testProperty "construct -> decode round-trips" testRoundTrip+ ]+ where+ testRoundTrip (RandomIslamicDate y m d) = (ymd <$> calendarDate d m y) == Just (d, succ (fromEnum m), y)++lensProps :: TestTree+lensProps = testGroup "Lens"+ [+ QC.testProperty "dayOfWeek . next n dow $ date == dow" testNextDoW+ ,QC.testProperty "next n (dayOfWeek date) date == modify (+ n * 7) day date" $ testDirection next (+)+ ,QC.testProperty "previous n (dayOfWeek date) date == modify (- n * 7) day date" $ testDirection previous $ flip (-)+ ]+ where+ epochDay = fromJust $ calendarDate 1 Muharram 1443+ testNextDoW dow (Positive n) = (dayOfWeek . next n dow $ epochDay) == dow+ testDirection dir adjust (Positive n) = dir n (dayOfWeek epochDay) epochDay == modify (adjust $ n * 7) day epochDay++-- | 'fromNthDay' and 'fromWeekDate' are the generic constructors instantiated for Islamic. Every Islamic month has at+-- least 29 days, so a given weekday always occurs and the properties are total.+nthDayProps :: TestTree+nthDayProps = testGroup "fromNthDay / fromWeekDate"+ [+ QC.testProperty "fromNthDay First dow is the first such weekday (day 1..7)" testFirst+ ,QC.testProperty "fromNthDay Last dow is the last such weekday (final week)" testLast+ ,QC.testProperty "fromWeekDate lands on the requested day-of-week" testWeekDoW+ ]+ where+ testFirst dow (RandomIslamicDate y m _) = let r = fromNthDay First dow m y in (dayOfWeek <$> r) == Just dow && maybe False (\d -> get day d >= 1 && get day d <= 7) r+ testLast dow (RandomIslamicDate y m _) = let r = fromNthDay Last dow m y in (dayOfWeek <$> r) == Just dow && maybe False (\d -> get day d >= 22) r+ testWeekDoW dow (RandomIslamicDate y _ _) = maybe True ((== dow) . dayOfWeek) (fromWeekDate 1 dow y)++structureUnits :: TestTree+structureUnits = testGroup "Structure"+ [+ testCase "30 Muharram is valid (odd months have 30 days)" $ (ymd <$> calendarDate 30 Muharram 1443) @?= Just (30, 1, 1443)+ ,testCase "30 Safar is invalid (even months have 29 days)" $ calendarDate 30 Safar 1443 @?= Nothing+ ,testCase "29 Safar is valid" $ (ymd <$> calendarDate 29 Safar 1443) @?= Just (29, 2, 1443)+ ,testCase "30 Ramadan is valid (Ramadan has 30 days)" $ (ymd <$> calendarDate 30 Ramadan 1443) @?= Just (30, 9, 1443)+ ,testCase "30 DhulHijjah is valid in the leap year 1442" $ (ymd <$> calendarDate 30 DhulHijjah 1442) @?= Just (30, 12, 1442)+ ,testCase "30 DhulHijjah is invalid in the non-leap year 1443" $ calendarDate 30 DhulHijjah 1443 @?= Nothing+ ,testCase "29 DhulHijjah is valid in a non-leap year (1443)" $ (ymd <$> calendarDate 29 DhulHijjah 1443) @?= Just (29, 12, 1443)+ ,testCase "1 Muharram + 1 month == 1 Safar" $ (ymd <$> (modify (+1) monthl <$> calendarDate 1 Muharram 1443)) @?= Just (1, 2, 1443)+ ,testCase "1 DhulQadah + 1 month == 1 DhulHijjah (11th -> 12th month)" $ (ymd <$> (modify (+1) monthl <$> calendarDate 1 DhulQadah 1443)) @?= Just (1, 12, 1443)+ ,testCase "year 0 is out of range" $ calendarDate 1 Muharram 0 @?= Nothing+ ]++-- | The leap pattern is carried in the type, so the same year is a leap year under one pattern and not another, and the+-- variants are distinct types. Each of the four patterns is pinned by a cycle-year that is a leap year under it but+-- not under Base16 (the 'IslamicBcl' default): Base15 -> 15, Indian -> 8, HabashAlHasib -> 30.+leapPatternUnits :: TestTree+leapPatternUnits = testGroup "Leap-pattern selection"+ [+ testCase "cycle-year 16 is leap in Base16 (default): 30 DhulHijjah valid" $ isJust (calendarDate 30 DhulHijjah 16) @?= True+ ,testCase "cycle-year 16 is not leap in Base15: 30 DhulHijjah invalid" $ (calendarDate' 30 DhulHijjah 16 :: Maybe (CalendarDate IslamicBase15)) @?= Nothing+ ,testCase "cycle-year 15 is leap in Base15: 30 DhulHijjah valid" $ isJust (calendarDate' 30 DhulHijjah 15 :: Maybe (CalendarDate IslamicBase15)) @?= True+ ,testCase "cycle-year 15 is not leap in Base16 (default): 30 DhulHijjah invalid" $ calendarDate 30 DhulHijjah 15 @?= Nothing+ ,testCase "cycle-year 8 is leap in Indian: 30 DhulHijjah valid" $ isJust (calendarDate' 30 DhulHijjah 8 :: Maybe (CalendarDate IslamicIndian)) @?= True+ ,testCase "cycle-year 8 is not leap in Base16 (default): 30 DhulHijjah invalid" $ calendarDate 30 DhulHijjah 8 @?= Nothing+ ,testCase "cycle-year 30 is leap in HabashAlHasib: 30 DhulHijjah valid" $ isJust (calendarDate' 30 DhulHijjah 30 :: Maybe (CalendarDate IslamicHabashAlHasib)) @?= True+ ,testCase "cycle-year 30 is not leap in Base16 (default): 30 DhulHijjah invalid" $ calendarDate 30 DhulHijjah 30 @?= Nothing+ ]++-- | The strongest checks: the same absolute day, anchored via Data.Time, must decode to the expected Islamic date. The+-- epoch (Islamic 1.Muharram.1 = 18.Jul.622 CE proleptic Gregorian, the astronomical epoch) and a few well-known dates+-- of the tabular calendar are pinned via the Gregorian calendar.+crossCalendarUnits :: TestTree+crossCalendarUnits = testGroup "Cross-calendar (Instant)"+ [+ testCase "epoch: 18.Jul.622 (Gregorian) is Islamic 1 Muharram 1" $ islamicOfDay (fromGregorian 622 7 18) >>= (@?= (1, 1, 1))+ ,testCase "1 Muharram 1443 = 9.Aug.2021 (tabular)" $ islamicOfDay (fromGregorian 2021 8 9) >>= (@?= (1443, 1, 1))+ ,testCase "1 Ramadan 1443 = 2.Apr.2022 (tabular)" $ islamicOfDay (fromGregorian 2022 4 2) >>= (@?= (1443, 9, 1))+ ]++-- | View the UTC midnight of a Data.Time 'Day' as an Islamic date, returning (year, 1-based month, day).+islamicOfDay :: Day -> IO (Int, Int, Int)+islamicOfDay dt = do+ tz <- utc+ let secs = round (utcTimeToPOSIXSeconds (UTCTime dt 0))+ zdt = fromInstant (fromSecondsSinceUnixEpoch secs) tz :: ZonedDateTime IslamicBcl+ return (Z.year zdt, succ (fromEnum (Z.month zdt)), Z.day zdt)
+ tests/HodaTime/Calendar/JulianTest.hs view
@@ -0,0 +1,109 @@+module HodaTime.Calendar.JulianTest+(+ julianTests+)+where++import Test.Tasty+import Test.Tasty.QuickCheck as QC+import Test.Tasty.HUnit+import Data.Maybe (fromJust)+import Data.Time.Calendar.Julian (fromJulianValid, toJulian)++import HodaTime.Util+import Data.HodaTime.CalendarDate (day, monthl, month, year, next, previous, dayOfWeek, DayNth(..), CalendarDate)+import Data.HodaTime.Calendar.Julian (calendarDate, fromNthDay, fromWeekDate, Julian, Month(..), DayOfWeek(..))++julianTests :: TestTree+julianTests = testGroup "Julian Tests" [qcProps, unitTests]++qcProps :: TestTree+qcProps = testGroup "(checked by QuickCheck)" [constructorProps, lensProps, nthDayProps]++unitTests :: TestTree+unitTests = testGroup "Unit tests" [constructorUnits, lensUnits]++-- | Decode a Julian date to (day, 1-based month, year) for explicit expected-value assertions.+ymd :: CalendarDate Julian -> (Int, Int, Int)+ymd x = (get day x, succ . fromEnum $ month x, get year x)++-- | Differential test: 'Data.Time.Calendar.Julian' is the proleptic-Julian oracle. This is the same shape as the+-- Gregorian constructor property, but it exercises Julian's simpler every-4-years leap rule (so e.g. 1900 is a+-- leap year here, unlike in the Gregorian calendar).+constructorProps :: TestTree+constructorProps = testGroup "Constructor"+ [+ QC.testProperty "same dates as Data.Time" $ testConstructor+ ]+ where+ areSame Nothing Nothing = True+ areSame (Just hdate) (Just date) =+ let+ (ty, tm, tday) = toJulian date+ in get day hdate == tday && (convertMonth . month $ hdate) == tm && get year hdate == fromIntegral ty+ areSame _ _ = False+ convertMonth = succ . fromEnum+ testConstructor y m (Positive d) = areSame (calendarDate d m y') (fromJulianValid (fromIntegral y') (convertMonth m) d)+ where+ y' = (y `mod` 2445) - 44 -- NOTE: spans 45 BC (year -44, the calendar's introduction) .. AD 2400++lensProps :: TestTree+lensProps = testGroup "Lens"+ [+ QC.testProperty "dayOfWeek . next n dow $ date == dow" $ testNextDoW+ ,QC.testProperty "next n (dayOfWeek date) date == modify (+ n * 7) day date" $ testDirection next (+)+ ,QC.testProperty "previous n (dayOfWeek date) date == modify (- n * 7) day date" $ testDirection previous $ flip (-)+ ,QC.testProperty "construct -> decode round-trips" $ testRoundTrip+ ]+ where+ epochDay = fromJust $ calendarDate 1 March 2000+ testNextDoW dow (Positive n) = (dayOfWeek . next n dow $ epochDay) == dow+ testDirection dir adjust (Positive n) = dir n (dayOfWeek epochDay) epochDay == modify (adjust $ n * 7) day epochDay+ testRoundTrip (RandomJulianDate y m d) = (ymd <$> calendarDate d m y) == Just (d, succ (fromEnum m), y)++-- | 'fromNthDay' and 'fromWeekDate' are the generic (calendar-agnostic) constructors instantiated for Julian. These+-- self-validating properties confirm the shared core works with Julian's own weekday math (no per-calendar formula).+nthDayProps :: TestTree+nthDayProps = testGroup "fromNthDay / fromWeekDate"+ [+ QC.testProperty "fromNthDay First dow is the first such weekday (day 1..7)" testFirst+ ,QC.testProperty "fromNthDay Last dow is the last such weekday (final week)" testLast+ ,QC.testProperty "fromWeekDate lands on the requested day-of-week" testWeekDoW+ ]+ where+ testFirst dow (RandomJulianDate y m _) =+ let r = fromNthDay First dow m y+ in (dayOfWeek <$> r) == Just dow && maybe False (\d -> get day d >= 1 && get day d <= 7) r+ testLast dow (RandomJulianDate y m _) =+ let r = fromNthDay Last dow m y+ in (dayOfWeek <$> r) == Just dow && maybe False (\d -> get day d >= 22) r+ testWeekDoW dow (RandomJulianDate y _ _) =+ maybe True ((== dow) . dayOfWeek) (fromWeekDate 1 dow y)++constructorUnits :: TestTree+constructorUnits = testGroup "Constructor"+ [+ testCase "30 February 2000 is not a valid date" $ calendarDate 30 February 2000 @?= Nothing+ ,testCase "29 February 1900 IS valid in Julian (1900 is a Julian leap year)" $ (ymd <$> calendarDate 29 February 1900) @?= Just (29, 2, 1900)+ ,testCase "29 February 1900 matches Data.Time" $ (ymd <$> calendarDate 29 February 1900) @?= (juYmd <$> fromJulianValid 1900 2 29)+ ,testCase "14 October 1066 is valid (long before the 1582 Gregorian cutoff)" $ (ymd <$> calendarDate 14 October 1066) @?= Just (14, 10, 1066)+ ,testCase "14 October 1066 matches Data.Time" $ (ymd <$> calendarDate 14 October 1066) @?= (juYmd <$> fromJulianValid 1066 10 14)+ ,testCase "fromNthDay Last, when the month ends on that weekday, is the last day (not a week early)" $+ let lastDay = fromJust $ calendarDate 28 February 301 -- Feb 301 (not a Julian leap year) ends on a Friday+ in fromNthDay Last (dayOfWeek lastDay) February 301 @?= Just lastDay+ ,testCase "1 BC (year 0) is a Julian leap year: 29 February is valid" $ (ymd <$> calendarDate 29 February 0) @?= Just (29, 2, 0)+ ,testCase "1 BC (year 0) 29 February matches Data.Time" $ (ymd <$> calendarDate 29 February 0) @?= (juYmd <$> fromJulianValid 0 2 29)+ ,testCase "2 BC (year -1) is not a leap year: 29 February is invalid" $ calendarDate 29 February (-1) @?= Nothing+ ,testCase "45 BC (year -44) 1 January matches Data.Time" $ (ymd <$> calendarDate 1 January (-44)) @?= (juYmd <$> fromJulianValid (-44) 1 1)+ ,testCase "46 BC (year -45) is before the calendar's introduction and is rejected" $ calendarDate 31 December (-45) @?= Nothing+ ]+ where+ juYmd d = let (ty, tm, td) = toJulian d in (td, tm, fromIntegral ty)++lensUnits :: TestTree+lensUnits = testGroup "Lens"+ [+ testCase "31 January 2000 + 1M == 29 February 2000 (2000 is a Julian leap year)" $ (ymd <$> (modify (+1) monthl <$> calendarDate 31 January 2000)) @?= Just (29, 2, 2000)+ ,testCase "31 December 2000 + 1D == 1 January 2001" $ (ymd <$> (modify (+1) day <$> calendarDate 31 December 2000)) @?= Just (1, 1, 2001)+ ,testCase "29 February 1900 + 1Y clamps to 28 February 1901" $ (ymd <$> (modify (+1) year <$> calendarDate 29 February 1900)) @?= Just (28, 2, 1901)+ ]
+ tests/HodaTime/Calendar/PersianTest.hs view
@@ -0,0 +1,108 @@+module HodaTime.Calendar.PersianTest+(+ persianTests+)+where++import Test.Tasty+import Test.Tasty.QuickCheck as QC+import Test.Tasty.HUnit+import Data.Maybe (fromJust)+import Data.Time.Calendar (Day, fromGregorian)+import Data.Time.Clock (UTCTime(..))+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)++import HodaTime.Util+import Data.HodaTime.CalendarDate (day, monthl, month, year, next, previous, dayOfWeek, DayNth(..), CalendarDate)+import Data.HodaTime.Calendar.Persian (calendarDate, fromNthDay, fromWeekDate, Persian, Month(..), DayOfWeek(..))+import Data.HodaTime.Instant (fromSecondsSinceUnixEpoch)+import Data.HodaTime.TimeZone (utc)+import Data.HodaTime.ZonedDateTime (fromInstant, ZonedDateTime)+import qualified Data.HodaTime.ZonedDateTime as Z++persianTests :: TestTree+persianTests = testGroup "Persian Tests" [qcProps, unitTests]++qcProps :: TestTree+qcProps = testGroup "(checked by QuickCheck)" [roundTripProps, lensProps, nthDayProps]++unitTests :: TestTree+unitTests = testGroup "Unit tests" [structureUnits, crossCalendarUnits]++-- | Decode a Persian date to (day, 1-based month, year) for explicit expected-value assertions.+ymd :: CalendarDate Persian -> (Int, Int, Int)+ymd x = (get day x, succ . fromEnum $ month x, get year x)++-- | Data.Time has no Persian calendar, so we verify the construct -> decode bijection directly.+roundTripProps :: TestTree+roundTripProps = testGroup "Constructor"+ [+ QC.testProperty "construct -> decode round-trips" testRoundTrip+ ]+ where+ testRoundTrip (RandomPersianDate y m d) = (ymd <$> calendarDate d m y) == Just (d, succ (fromEnum m), y)++lensProps :: TestTree+lensProps = testGroup "Lens"+ [+ QC.testProperty "dayOfWeek . next n dow $ date == dow" testNextDoW+ ,QC.testProperty "next n (dayOfWeek date) date == modify (+ n * 7) day date" $ testDirection next (+)+ ,QC.testProperty "previous n (dayOfWeek date) date == modify (- n * 7) day date" $ testDirection previous $ flip (-)+ ]+ where+ epochDay = fromJust $ calendarDate 1 Farvardin 1400+ testNextDoW dow (Positive n) = (dayOfWeek . next n dow $ epochDay) == dow+ testDirection dir adjust (Positive n) = dir n (dayOfWeek epochDay) epochDay == modify (adjust $ n * 7) day epochDay++-- | 'fromNthDay' and 'fromWeekDate' are the generic constructors instantiated for Persian. Every Persian month has at+-- least 29 days, so a given weekday always occurs and the properties are total.+nthDayProps :: TestTree+nthDayProps = testGroup "fromNthDay / fromWeekDate"+ [+ QC.testProperty "fromNthDay First dow is the first such weekday (day 1..7)" testFirst+ ,QC.testProperty "fromNthDay Last dow is the last such weekday (final week)" testLast+ ,QC.testProperty "fromWeekDate lands on the requested day-of-week" testWeekDoW+ ]+ where+ testFirst dow (RandomPersianDate y m _) = let r = fromNthDay First dow m y in (dayOfWeek <$> r) == Just dow && maybe False (\d -> get day d >= 1 && get day d <= 7) r+ testLast dow (RandomPersianDate y m _) = let r = fromNthDay Last dow m y in (dayOfWeek <$> r) == Just dow && maybe False (\d -> get day d >= 22) r+ testWeekDoW dow (RandomPersianDate y _ _) = maybe True ((== dow) . dayOfWeek) (fromWeekDate 1 dow y)++structureUnits :: TestTree+structureUnits = testGroup "Structure"+ [+ testCase "31 Farvardin is valid (months 1-6 have 31 days)" $ (ymd <$> calendarDate 31 Farvardin 1400) @?= Just (31, 1, 1400)+ ,testCase "31 Mehr is invalid (months 7-11 have 30 days)" $ calendarDate 31 Mehr 1400 @?= Nothing+ ,testCase "30 Mehr is valid" $ (ymd <$> calendarDate 30 Mehr 1400) @?= Just (30, 7, 1400)+ ,testCase "30 Esfand is valid in the leap year 1399" $ (ymd <$> calendarDate 30 Esfand 1399) @?= Just (30, 12, 1399)+ ,testCase "30 Esfand is invalid in the non-leap year 1400" $ calendarDate 30 Esfand 1400 @?= Nothing+ ,testCase "30 Esfand is valid in the leap year 1403" $ (ymd <$> calendarDate 30 Esfand 1403) @?= Just (30, 12, 1403)+ ,testCase "30 Esfand is invalid in 1407 (the 1403->1408 five-year gap)" $ calendarDate 30 Esfand 1407 @?= Nothing+ ,testCase "29 Esfand is valid in a non-leap year (1400)" $ (ymd <$> calendarDate 29 Esfand 1400) @?= Just (29, 12, 1400)+ ,testCase "1 Farvardin + 1 month == 1 Ordibehesht" $ (ymd <$> (modify (+1) monthl <$> calendarDate 1 Farvardin 1400)) @?= Just (1, 2, 1400)+ ,testCase "1 Bahman + 1 month == 1 Esfand (11th -> 12th month)" $ (ymd <$> (modify (+1) monthl <$> calendarDate 1 Bahman 1400)) @?= Just (1, 12, 1400)+ ,testCase "year 0 is out of range" $ calendarDate 1 Farvardin 0 @?= Nothing+ ,testCase "year 1600 is out of range" $ calendarDate 1 Farvardin 1600 @?= Nothing+ ]++-- | The strongest checks: the same absolute day, anchored via Data.Time, must decode to the expected Persian date. The+-- epoch (Persian 1.Farvardin.1 = 22.Mar.622 CE proleptic Gregorian) and several well-known Nowruz (Persian new year)+-- dates are pinned via the Gregorian calendar. 1404 is a year where the astronomical calendar differs from the+-- arithmetic one (arithmetic Nowruz 1404 = 20.Mar.2025; astronomical = 21.Mar.2025).+crossCalendarUnits :: TestTree+crossCalendarUnits = testGroup "Cross-calendar (Instant)"+ [+ testCase "epoch: 22.Mar.622 (Gregorian) is Persian 1 Farvardin 1" $ persianOfDay (fromGregorian 622 3 22) >>= (@?= (1, 1, 1))+ ,testCase "Nowruz 1400 = 21.Mar.2021 (Gregorian)" $ persianOfDay (fromGregorian 2021 3 21) >>= (@?= (1400, 1, 1))+ ,testCase "Nowruz 1399 = 20.Mar.2020 (Gregorian, leap year)" $ persianOfDay (fromGregorian 2020 3 20) >>= (@?= (1399, 1, 1))+ ,testCase "Nowruz 1404 = 21.Mar.2025 (astronomical, differs from arithmetic)" $ persianOfDay (fromGregorian 2025 3 21) >>= (@?= (1404, 1, 1))+ ,testCase "1.Dey.1348 = 22.Dec.1969 (Gregorian)" $ persianOfDay (fromGregorian 1969 12 22) >>= (@?= (1348, 10, 1))+ ]++-- | View the UTC midnight of a Data.Time 'Day' as a Persian date, returning (year, 1-based month, day).+persianOfDay :: Day -> IO (Int, Int, Int)+persianOfDay dt = do+ tz <- utc+ let secs = round (utcTimeToPOSIXSeconds (UTCTime dt 0))+ zdt = fromInstant (fromSecondsSinceUnixEpoch secs) tz :: ZonedDateTime Persian+ return (Z.year zdt, succ (fromEnum (Z.month zdt)), Z.day zdt)
tests/HodaTime/CalendarDateTimeTest.hs view
@@ -13,7 +13,7 @@ import Data.HodaTime.LocalTime (localTime, HasLocalTime(..)) import Data.HodaTime.CalendarDate (day, monthl, next, previous, dayOfWeek) import Data.HodaTime.Calendar.Gregorian (calendarDate, Month(..))-import Data.HodaTime.CalendarDateTime (on, at)+import Data.HodaTime.CalendarDateTime (on) calendarDateTimeTests :: TestTree calendarDateTimeTests = testGroup "CalendarDateTimeTests Tests" [qcProps, unitTests]
+ tests/HodaTime/ClassInstanceTests.hs view
@@ -0,0 +1,98 @@+module HodaTime.ClassInstanceTests+(+ classInstanceTests+)+where++import Test.Tasty+import Test.Tasty.HUnit+import Data.Maybe (fromJust)+import Control.DeepSeq (deepseq)+import Data.Hashable (hash)++import Data.HodaTime.Instant (Instant, fromSecondsSinceUnixEpoch)+import qualified Data.HodaTime.Duration as Dur+import Data.HodaTime.LocalTime (localTime, LocalTime)+import qualified Data.HodaTime.Offset as Off+import Data.HodaTime.Interval (interval)+import Data.HodaTime.CalendarDate (CalendarDate)+import Data.HodaTime.CalendarDateTime (at)+import Data.HodaTime.OffsetDateTime (fromInstantWithOffset, OffsetDateTime)+import Data.HodaTime.Calendar.Gregorian (Month(..), DayOfWeek(..))+import qualified Data.HodaTime.Calendar.Gregorian as G++classInstanceTests :: TestTree+classInstanceTests = testGroup "NFData / Hashable / Ord instances" [hashDiscriminates, hashConsistent, nfdataForces, ordChecks]++-- | Confirms every field of a value participates in its hash (i.e. the 'Hashable' instances actually fold each+-- field rather than collapsing to a constant). Distinct values are compared and expected to hash differently.+hashDiscriminates :: TestTree+hashDiscriminates = testGroup "hash distinguishes distinct values"+ [+ testCase "Instant: day field" $ assertBool "" (hash i0 /= hash iDay)+ ,testCase "Instant: second field" $ assertBool "" (hash i0 /= hash iSec)+ ,testCase "Duration: seconds" $ assertBool "" (hash (Dur.fromSeconds (1 :: Int)) /= hash (Dur.fromSeconds (2 :: Int)))+ ,testCase "Duration: nanoseconds" $ assertBool "" (hash (Dur.fromNanoseconds (1 :: Int)) /= hash (Dur.fromNanoseconds (2 :: Int)))+ ,testCase "Offset" $ assertBool "" (hash (Off.fromSeconds (3600 :: Int)) /= hash (Off.fromSeconds (7200 :: Int)))+ ,testCase "LocalTime" $ assertBool "" (hash lt1 /= hash lt2)+ ,testCase "Interval" $ assertBool "" (hash (interval i0 iDay) /= hash (interval i0 iSec))+ ,testCase "CalendarDate" $ assertBool "" (hash cd1 /= hash cd2)+ ,testCase "CalendarDateTime" $ assertBool "" (hash (at cd1 lt1) /= hash (at cd2 lt1))+ ,testCase "Month" $ assertBool "" (hash January /= hash February)+ ,testCase "DayOfWeek" $ assertBool "" (hash Monday /= hash Tuesday)+ ,testCase "OffsetDateTime" $ assertBool "" (hash odt1 /= hash odt2)+ ]++-- | Confirms 'hash' agrees with '(==)': equal values reached by different construction paths must hash equally.+hashConsistent :: TestTree+hashConsistent = testGroup "hash agrees with (==)"+ [+ testCase "Duration: seconds vs nanoseconds" $ do+ let a = Dur.fromSeconds (1 :: Int)+ b = Dur.fromNanoseconds (1000000000 :: Int)+ assertEqual "equal values" a b+ assertEqual "equal hashes" (hash a) (hash b)+ ]++-- | Confirms the 'NFData' instances force a value to normal form without error.+nfdataForces :: TestTree+nfdataForces = testGroup "NFData forces values"+ [+ testCase "Instant" $ assertBool "" (i0 `deepseq` True)+ ,testCase "Duration" $ assertBool "" (Dur.fromSeconds (1 :: Int) `deepseq` True)+ ,testCase "Offset" $ assertBool "" (Off.fromSeconds (3600 :: Int) `deepseq` True)+ ,testCase "LocalTime" $ assertBool "" (lt1 `deepseq` True)+ ,testCase "Interval" $ assertBool "" (interval i0 iDay `deepseq` True)+ ,testCase "CalendarDate" $ assertBool "" (cd1 `deepseq` True)+ ,testCase "CalendarDateTime" $ assertBool "" (at cd1 lt1 `deepseq` True)+ ,testCase "Month" $ assertBool "" (January `deepseq` True)+ ,testCase "DayOfWeek" $ assertBool "" (Monday `deepseq` True)+ ]++-- | Confirms the 'Ord' instances added to 'Duration' order by length, including across zero into negatives.+ordChecks :: TestTree+ordChecks = testGroup "Ord"+ [+ testCase "Duration: shorter < longer" $ assertBool "" (Dur.fromSeconds (1 :: Int) < Dur.fromSeconds (2 :: Int))+ ,testCase "Duration: negative < zero" $ assertBool "" (Dur.fromSeconds (-1 :: Int) < Dur.fromSeconds (0 :: Int))+ ,testCase "OffsetDateTime: earlier < later" $ assertBool "" (odt1 < odt2)+ ]++-- shared values++i0, iDay, iSec :: Instant+i0 = fromSecondsSinceUnixEpoch 0+iDay = fromSecondsSinceUnixEpoch 86400+iSec = fromSecondsSinceUnixEpoch 5++lt1, lt2 :: LocalTime+lt1 = fromJust $ localTime 10 30 0 0+lt2 = fromJust $ localTime 11 30 0 0++cd1, cd2 :: CalendarDate G.Gregorian+cd1 = fromJust $ G.calendarDate 10 March 2020+cd2 = fromJust $ G.calendarDate 11 March 2020++odt1, odt2 :: OffsetDateTime G.Gregorian+odt1 = fromInstantWithOffset i0 (Off.fromSeconds (0 :: Int))+odt2 = fromInstantWithOffset iSec (Off.fromSeconds (0 :: Int))
tests/HodaTime/InstantTest.hs view
@@ -6,28 +6,41 @@ import Test.Tasty import Test.Tasty.HUnit+import Test.Tasty.QuickCheck as QC -import Data.HodaTime.Instant (fromSecondsSinceUnixEpoch)-import Data.HodaTime.TimeZone (utc)-import Data.HodaTime.ZonedDateTime (fromInstant, toLocalTime, ZonedDateTime)+import Data.HodaTime.Instant (Instant, fromSecondsSinceUnixEpoch, add, difference, minus)+import qualified Data.HodaTime.Duration as D+import Data.HodaTime.TimeZone (utc, timeZone)+import Data.HodaTime.ZonedDateTime (fromInstant, toLocalTime, toInstant, ZonedDateTime, year, month, day) import Data.HodaTime.Calendar.Gregorian (Gregorian)+import Data.HodaTime.Calendar.Julian (Julian) import Data.HodaTime.LocalTime (HasLocalTime(..)) import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime)+import Data.Time.Calendar (toGregorian)+import Data.Time.Calendar.Julian (toJulian) import Data.Time.LocalTime (todHour, todMin, todSec, hoursToTimeZone, utcToLocalTime, LocalTime(..)) import HodaTime.Util (get) instantTests :: TestTree-instantTests = testGroup "Instant Tests" [unitTests]+instantTests = testGroup "Instant Tests" [unitTests, qcProps] +qcProps :: TestTree+qcProps = testGroup "(checked by QuickCheck)"+ [+ QC.testProperty "difference (add i d) i == d (add handles negative durations)" prop_addDifferenceRoundTrip+ ,QC.testProperty "add (minus i d) d == i (minus is the inverse of add)" prop_minusAddRoundTrip+ ]+ unitTests :: TestTree unitTests = testGroup "Unit tests" [ testCase "test_fromSecondsSinceUnixEpoch" test_fromSecondsSinceUnixEpoch+ ,testCase "test_instantDate" test_instantDate+ ,testCase "test_instantRoundTrip" test_instantRoundTrip+ ,testCase "test_instantCrossCalendar" test_instantCrossCalendar ] --- TODO: Make sure round-tripping Instant->ZoneDateTime->Instant ends up with the same number. If it doesn't, it's a problem with leap seconds--test_fromSecondsSinceUnixEpoch :: Assertion -- TODO: this is temporary until we get the required infrastructure in place to properly test Instants (we can't now because there is no legal conversion, only the internal fromInstant function)+test_fromSecondsSinceUnixEpoch :: Assertion test_fromSecondsSinceUnixEpoch = do posT <- getPOSIXTime tz <- utc@@ -42,3 +55,84 @@ t = (get hour lt, get minute lt, get second lt) str = "time(" ++ show secs ++ "): " assertEqual str todT t++-- | The date (year, month, day) of an 'Instant' converted through the public 'ZonedDateTime' path (in UTC) must+-- agree with Data.Time. This exercises the cycle-based 'Instant' -> date decode ('daysToGregorian').+test_instantDate :: Assertion+test_instantDate = do+ posT <- getPOSIXTime+ tz <- utc+ let+ secs = round posT+ zdt :: ZonedDateTime Gregorian+ zdt = flip fromInstant tz . fromSecondsSinceUnixEpoch $ secs+ utcT = posixSecondsToUTCTime posT+ (LocalTime dayGreg _) = utcToLocalTime (hoursToTimeZone 0) utcT+ (ty, tm, td) = toGregorian dayGreg+ expected = (fromIntegral ty, tm, td)+ actual = (year zdt, succ . fromEnum $ month zdt, day zdt)+ str = "date(" ++ show secs ++ "): "+ assertEqual str expected actual++-- | 'Instant' -> 'ZonedDateTime' -> 'Instant' (via 'toInstant') must round-trip exactly. Tested in UTC and in a+-- zone with a non-zero UTC offset (so a sign error in the offset arithmetic would be caught). A 'ZonedDateTime'+-- maps to exactly one 'Instant', so this conversion is always unambiguous (the ambiguity is on the reverse,+-- CalendarDateTime -> ZonedDateTime, direction).+test_instantRoundTrip :: Assertion+test_instantRoundTrip = mapM_ check ["UTC", euZone]+ where+ euZone = "Europe/Zurich"+ check zoneName = do+ tz <- timeZone zoneName+ let+ inst = fromSecondsSinceUnixEpoch 1700000000+ zdt :: ZonedDateTime Gregorian+ zdt = fromInstant inst tz+ assertEqual ("Instant -> ZonedDateTime -> Instant round-trips in " ++ zoneName) inst (toInstant zdt)++-- | The SAME 'Instant' decoded into two different calendars must land on the same absolute day: its Gregorian and+-- Julian labels must each match Data.Time, and both 'ZonedDateTime's must convert back (via 'toInstant') to the+-- original 'Instant'. This locks in the Julian epoch alignment \- Julian must be 13 days behind Gregorian in the+-- modern era, not identical to it.+test_instantCrossCalendar :: Assertion+test_instantCrossCalendar = do+ tz <- utc+ let+ inst = fromSecondsSinceUnixEpoch 1592352000 -- 2020-06-17T00:00:00Z+ zdtG :: ZonedDateTime Gregorian+ zdtG = fromInstant inst tz+ zdtJ :: ZonedDateTime Julian+ zdtJ = fromInstant inst tz+ utcT = posixSecondsToUTCTime 1592352000+ (LocalTime dayGreg _) = utcToLocalTime (hoursToTimeZone 0) utcT+ (gy, gm, gd) = toGregorian dayGreg+ (jy, jm, jd) = toJulian dayGreg+ actualG = (year zdtG, succ . fromEnum $ month zdtG, day zdtG)+ actualJ = (year zdtJ, succ . fromEnum $ month zdtJ, day zdtJ)+ assertEqual "Gregorian date" (fromIntegral gy, gm, gd) actualG+ assertEqual "Julian date (13 days behind Gregorian in 2020)" (fromIntegral jy, jm, jd) actualJ+ assertEqual "Gregorian round-trips to the same Instant" inst (toInstant zdtG)+ assertEqual "Julian round-trips to the same Instant" inst (toInstant zdtJ)++-- | Adding a 'Duration' and then taking the 'difference' back out must return the original 'Duration', for any+-- duration including negative ones. This locks in that 'add' handles negative durations (i.e. it is not limited+-- to future instants).+prop_addDifferenceRoundTrip :: Int -> Int -> Int -> Bool+prop_addDifferenceRoundTrip base s ns = difference (add i d) i == d+ where (i, d) = instantAndDuration base s ns++-- | 'minus' is the exact inverse of 'add': shifting an 'Instant' back by a 'Duration' and then forward again by the+-- same 'Duration' returns the original 'Instant', for any duration including negative ones.+prop_minusAddRoundTrip :: Int -> Int -> Int -> Bool+prop_minusAddRoundTrip base s ns = add (minus i d) d == i+ where (i, d) = instantAndDuration base s ns++-- | Build an 'Instant' / 'Duration' pair from raw generated 'Int's, bounding the magnitudes so the (Int32) day+-- field cannot overflow while still exercising the full sign range (negative seconds and nanoseconds included).+instantAndDuration :: Int -> Int -> Int -> (Instant, D.Duration)+instantAndDuration base s ns = (i, d)+ where+ i = fromSecondsSinceUnixEpoch (base `rem` secBound)+ d = D.fromSeconds (s `rem` secBound) `D.add` D.fromNanoseconds (ns `rem` nsBound)+ secBound = 100000000000+ nsBound = 1000000000000
tests/HodaTime/LocalTimeTest.hs view
@@ -10,7 +10,7 @@ import Data.Maybe (fromJust) import HodaTime.Util-import Data.HodaTime.LocalTime (localTime, HasLocalTime(..))+import Data.HodaTime.LocalTime (localTime, LocalTime, HasLocalTime(..)) localTimeTests :: TestTree localTimeTests = testGroup "LocalTime Tests" [qcProps, unitTests]@@ -58,4 +58,5 @@ ,testCase "22:57:57 + 3725s == 00:00:02" $ modify (+3725) second <$> time @?= localTime 0 0 2 0 ] where+ time :: Maybe LocalTime time = localTime 22 57 57 0
+ tests/HodaTime/LocaleTest.hs view
@@ -0,0 +1,137 @@+module HodaTime.LocaleTest+(+ localeTests+)+where++import Test.Tasty+import Test.Tasty.HUnit+import Data.Maybe (fromMaybe, isNothing)++import Data.HodaTime.Locale+import Data.HodaTime.Pattern+import Data.HodaTime.Pattern.CalendarDate (pdd, pMM, pyyyy, pMMMM', pMMM', pdddd', pMonthName, pdaySpace)+import Data.HodaTime.Pattern.LocalTime (phh, phhSpace, pmm, ppp')+import Data.HodaTime.Pattern.Locale (localeDatePattern, localeTimePattern, localeDateTimePattern, localeOffsetDateTimePattern, parseZonedDateTime)+import Data.HodaTime.Pattern.Offset (pOffsetCompact)+import Data.HodaTime.LocalTime (localTime, LocalTime)+import Data.HodaTime.CalendarDate (CalendarDate)+import Data.HodaTime.CalendarDateTime (CalendarDateTime, at)+import Data.HodaTime.ZonedDateTime (ZonedDateTime, toCalendarDateTime, fromCalendarDateTimeStrictly)+import Data.HodaTime.OffsetDateTime (OffsetDateTime, fromCalendarDateTimeWithOffset)+import Data.HodaTime.Offset (fromHours, fromMinutes)+import Data.HodaTime.TimeZone (utc)+import qualified Data.HodaTime.Calendar.Gregorian as G+import System.Info (os)++tuesday :: CalendarDate G.Gregorian+tuesday = fromMaybe (error "impossible") $ G.calendarDate 3 G.March 2020++mar15 :: CalendarDate G.Gregorian+mar15 = fromMaybe (error "impossible") $ G.calendarDate 15 G.March 2020++mkLtm :: Int -> Int -> LocalTime+mkLtm h m = fromMaybe (error "impossible") (localTime h m 0 0)++mkLts :: Int -> Int -> Int -> LocalTime+mkLts h m s = fromMaybe (error "impossible") (localTime h m s 0)++-- | 15 March 2020 (a Sunday), 13:24:35 — all date and time fields distinct, for the combined-layout tests.+dt :: CalendarDateTime G.Gregorian+dt = at mar15 (mkLts 13 24 35)++localeTests :: TestTree+localeTests = testGroup "Locale Tests" [patternTests, readerTests, strftimeTests, zonedTests, offsetTests]++patternTests :: TestTree+patternTests = testGroup "locale-aware patterns"+ [+ testCase "format pMMMM' is the German month name" $ format (pMMMM' deDE) tuesday @?= "März"+ ,testCase "format pMMM' is the short German month name" $ format (pMMM' deDE) tuesday @?= "Mär"+ ,testCase "format pMMMM' is the Japanese month name" $ format (pMMMM' jaJP) tuesday @?= "3月"+ ,testCase "format pdddd' is the German weekday name" $ format (pdddd' deDE) tuesday @?= "Dienstag"+ ,testCase "parse German full date round-trips" $ parse (pdd <% char ' ' <> pMMMM' deDE <% char ' ' <> pyyyy) "03 März 2020" @?= Just tuesday+ ,testCase "parse consumes the German weekday" $ parse (pdddd' deDE <% string ", " <> pdd <% char ' ' <> pMMMM' deDE <% char ' ' <> pyyyy) "Dienstag, 03 März 2020" @?= Just tuesday+ ,testCase "generic pMonthName uses any name vector" $ format (pMonthName ["M1","M2","M3","M4","M5","M6","M7","M8","M9","M10","M11","M12"]) tuesday @?= "M3"+ ,testCase "format ppp' is the PM designator" $ format (ppp' enUS) (mkLtm 15 0) @?= "PM"+ ,testCase "parse 12-hour + ppp' round-trips" $ parse (phh <% char ':' <> pmm <% char ' ' <> ppp' enUS) "03:04 PM" @?= Just (mkLtm 15 4)+ ,testCase "pdaySpace pads a single-digit day" $ format pdaySpace tuesday @?= " 3"+ ,testCase "pdaySpace leaves a two-digit day" $ format pdaySpace mar15 @?= "15"+ ,testCase "pdaySpace parses the padded form" $ parse (pdaySpace <% char '.' <> pMM <% char '.' <> pyyyy) " 3.03.2020" @?= Just tuesday+ ,testCase "pdaySpace parses the bare form" $ parse (pdaySpace <% char '.' <> pMM <% char '.' <> pyyyy) "3.03.2020" @?= Just tuesday+ ,testCase "phhSpace pads the 12-hour clock" $ format (phhSpace <% char ':' <> pmm <% char ' ' <> ppp' enUS) (mkLtm 13 24) @?= " 1:24 PM"+ ,testCase "phhSpace round-trips" $ parse (phhSpace <% char ':' <> pmm <% char ' ' <> ppp' enUS) " 1:24 PM" @?= Just (mkLtm 13 24)+ ]++readerTests :: TestTree+readerTests = testGroup "reading the machine locale"+ [+ testCase "the C locale has the English month names" $ do+ loc <- localeByName "C"+ take 3 (monthNames loc) @?= ["January", "February", "March"]+ length (monthNames loc) @?= 12+ ,testCase "the C locale has seven weekday names, Sunday-first" $ do+ loc <- localeByName "C"+ head (dayNames loc) @?= "Sunday"+ length (dayNames loc) @?= 7+ ,testCase "currentLocale returns a structurally complete locale" $ do+ loc <- currentLocale+ length (monthNames loc) @?= 12+ length (monthNamesShort loc) @?= 12+ length (dayNames loc) @?= 7+ length (dayNamesShort loc) @?= 7+ ,testCase "Windows: a read locale's layout compiles (de-DE)" $+ -- Only meaningful on Windows, where raw*Format is translated from a Windows picture string; a no-op elsewhere.+ if os == "mingw32"+ then do+ loc <- localeByName "de-DE"+ p <- localeDatePattern loc+ format p mar15 @?= "15.03.2020"+ else return ()+ ]++strftimeTests :: TestTree+strftimeTests = testGroup "strftime layout compiler"+ [+ testCase "US date is month-first (%m/%d/%Y)" $ fmap (\p -> format p mar15) (localeDatePattern enUS) @?= Just "03/15/2020"+ ,testCase "US date round-trips" $ (localeDatePattern enUS >>= \p -> parse p "03/15/2020") @?= Just mar15+ ,testCase "German date is day-first (%d.%m.%Y)" $ fmap (\p -> format p mar15) (localeDatePattern deDE) @?= Just "15.03.2020"+ ,testCase "German date round-trips" $ (localeDatePattern deDE >>= \p -> parse p "15.03.2020") @?= Just mar15+ ,testCase "Japanese date has multibyte separators" $ fmap (\p -> format p mar15) (localeDatePattern jaJP) @?= Just "2020年03月15日"+ ,testCase "Japanese date round-trips" $ (localeDatePattern jaJP >>= \p -> parse p "2020年03月15日") @?= Just mar15+ ,testCase "US time is 12-hour (%r)" $ fmap (\p -> format p (mkLts 13 24 35)) (localeTimePattern enUS) @?= Just "01:24:35 PM"+ ,testCase "US time round-trips" $ (localeTimePattern enUS >>= \p -> parse p "01:24:35 PM") @?= Just (mkLts 13 24 35)+ ,testCase "German time is 24-hour (%T)" $ fmap (\p -> format p (mkLts 13 24 35)) (localeTimePattern deDE) @?= Just "13:24:35"+ ,testCase "German time round-trips" $ (localeTimePattern deDE >>= \p -> parse p "13:24:35") @?= Just (mkLts 13 24 35)+ ,testCase "Japanese time has multibyte separators" $ fmap (\p -> format p (mkLts 13 24 35)) (localeTimePattern jaJP) @?= Just "13時24分35秒"+ ,testCase "Japanese time round-trips" $ (localeTimePattern jaJP >>= \p -> parse p "13時24分35秒") @?= Just (mkLts 13 24 35)+ ,testCase "German date+time drops the zone" $ fmap (\p -> format p dt) (localeDateTimePattern deDE) @?= Just "So 15 Mär 2020 13:24:35"+ ,testCase "German date+time round-trips" $ (localeDateTimePattern deDE >>= \p -> parse p "So 15 Mär 2020 13:24:35") @?= Just dt+ ,testCase "US date+time is 12-hour, zone dropped" $ fmap (\p -> format p dt) (localeDateTimePattern enUS) @?= Just "Sun 15 Mar 2020 01:24:35 PM"+ ,testCase "US date+time round-trips" $ (localeDateTimePattern enUS >>= \p -> parse p "Sun 15 Mar 2020 01:24:35 PM") @?= Just dt+ ,testCase "Japanese date+time (no zone in layout)" $ fmap (\p -> format p dt) (localeDateTimePattern jaJP) @?= Just "2020年03月15日 13時24分35秒"+ ,testCase "Japanese date+time round-trips" $ (localeDateTimePattern jaJP >>= \p -> parse p "2020年03月15日 13時24分35秒") @?= Just dt+ ]++zonedTests :: TestTree+zonedTests = testGroup "locale ZonedDateTime parsing"+ [+ testCase "reads the local time from a zoned layout" $ do+ tz <- utc+ zdt <- parseZonedDateTime (const (pure tz)) fromCalendarDateTimeStrictly deDE "So 15 Mär 2020 13:24:35 UTC" :: IO (ZonedDateTime G.Gregorian)+ toCalendarDateTime zdt @?= dt+ ,testCase "rejects a zoneless (Japanese) layout" $ isNothing (parseZonedDateTime (const Nothing) fromCalendarDateTimeStrictly jaJP "irrelevant" :: Maybe (ZonedDateTime G.Gregorian)) @?= True+ ]++odt :: OffsetDateTime G.Gregorian+odt = fromCalendarDateTimeWithOffset dt (fromHours 2)++offsetTests :: TestTree+offsetTests = testGroup "locale OffsetDateTime parsing"+ [+ testCase "pOffsetCompact formats +HHmm" $ format pOffsetCompact (fromHours 2) @?= "+0200"+ ,testCase "pOffsetCompact formats a negative offset" $ format pOffsetCompact (fromMinutes (-330)) @?= "-0530"+ ,testCase "pOffsetCompact parses +HHmm" $ parse pOffsetCompact "+0200" @?= Just (fromHours (2 :: Int))+ ,testCase "pOffsetCompact parses a negative offset" $ parse pOffsetCompact "-0530" @?= Just (fromMinutes (-330 :: Int))+ ,testCase "rejects a layout with no %z" $ isNothing (fmap (\p -> format p odt) (localeOffsetDateTimePattern deDE)) @?= True+ ]
tests/HodaTime/OffsetTest.hs view
@@ -10,8 +10,6 @@ import Test.Tasty.HUnit import HodaTime.Util import Data.HodaTime.Offset-import Control.Applicative (Const(..))-import Data.Functor.Identity (Identity(..)) offsetTests :: TestTree offsetTests = testGroup "Offset Tests" [scProps, qcProps, unitTests]@@ -22,12 +20,19 @@ scProps = testGroup "(checked by SmallCheck)" [mathPropSC] qcProps :: TestTree-qcProps = testGroup "(checked by QuickCheck)" [secondProps, mathProps, lensProps]+qcProps = testGroup "(checked by QuickCheck)" [secondProps, mathProps, componentProps] unitTests :: TestTree unitTests = testGroup "Unit tests" [+ testCase "-01:30 -> hours -1" $ hours (fromSeconds (-5400 :: Int)) @?= (-1)+ ,testCase "-01:30 -> minutes -30" $ minutes (fromSeconds (-5400 :: Int)) @?= (-30)+ ,testCase "-00:30 -> (hours,minutes,seconds) == (0,-30,0)" $ triple (fromSeconds (-1800 :: Int)) @?= (0, -30, 0)+ ,testCase "-01:01:01 -> (-1,-1,-1)" $ triple (fromSeconds (-3661 :: Int)) @?= (-1, -1, -1)+ ,testCase "+02:15 -> (2,15,0)" $ triple (fromSeconds (2*3600 + 15*60 :: Int)) @?= (2, 15, 0) ]+ where+ triple o = (hours o, minutes o, seconds o) -- properties @@ -58,28 +63,17 @@ ,QC.testProperty "fromMinutes x `minusClamped` fromMinutes y == fromMinutes (x-y)" $ test fromMinutes minusClamped (-) ] -lensProps :: TestTree-lensProps = testGroup "Lens"+componentProps :: TestTree+componentProps = testGroup "Components" [- QC.testProperty "get seconds offset" $ testGet seconds _1- ,QC.testProperty "get minutes offset" $ testGet minutes _2- ,QC.testProperty "get hours offset" $ testGet hours _3- ,QC.testProperty "modify seconds offset" $ testF (modify . (+)) seconds _1 (+) 5- ,QC.testProperty "modify minutes offset" $ testF (modify . (+)) minutes _2 (+) 5- ,QC.testProperty "modify hours offset" $ testF (modify . (+)) hours _3 (+) 5- ,QC.testProperty "set seconds offset" $ testF set seconds _1 const 5- ,QC.testProperty "set minutes offset" $ testF set minutes _2 const 5- ,QC.testProperty "set hours offset" $ testF set hours _3 const 5+ QC.testProperty "components reconstruct the offset" $ \(RandomOffset h m s) ->+ let t = h*3600 + m*60 + s; o = fromSeconds t in hours o * 3600 + minutes o * 60 + seconds o == t+ ,QC.testProperty "each component carries the offset's sign (or is zero)" $ \(RandomOffset h m s) ->+ let t = h*3600 + m*60 + s; o = fromSeconds t; ok x = x == 0 || signum x == signum t+ in ok (hours o) && ok (minutes o) && ok (seconds o)+ ,QC.testProperty "sub-hour components stay under 60" $ \(RandomOffset h m s) ->+ let o = fromSeconds (h*3600 + m*60 + s) in abs (minutes o) < 60 && abs (seconds o) < 60 ]- where- offset :: Int -> Int -> Int -> Offset -- Only needed so the compiler can decide which concreate type to use- offset s m h = fromSeconds s `addClamped` fromMinutes m `addClamped` fromHours h- offsetEq (s, m, h) off = get seconds off == s && get minutes off == m && get hours off == h- _1 f (a,b,c) = (\a' -> (a',b,c)) <$> f a- _2 f (a,b,c) = (\b' -> (a,b',c)) <$> f b- _3 f (a,b,c) = (\c' -> (a,b,c')) <$> f c- testGet l l' (RandomOffset h m s) = get l (offset s m h) == get l' (s, m, h)- testF f l l' g n (RandomOffset h m s) = h < 18 - n && s < 60 - n && m < 60 - n QC.==> offsetEq (modify (g n) l' (s,m,h)) $ f n l (offset s m h) -- helper functions
+ tests/HodaTime/PatternTest.hs view
@@ -0,0 +1,249 @@+module HodaTime.PatternTest+(+ patternTests+)+where++import Test.Tasty+import qualified Test.Tasty.SmallCheck as SC+import Test.Tasty.QuickCheck as QC+import Test.QuickCheck.Monadic (monadicIO, run)+import qualified Test.QuickCheck.Monadic as QCM+import Data.Maybe (fromMaybe)+import Control.Monad.Catch (MonadThrow)+import Data.Semigroup ((<>))+import Test.Tasty.HUnit+import HodaTime.Util+import Data.HodaTime.LocalTime (localTime)+import Data.HodaTime.CalendarDateTime (at, CalendarDateTime)+import qualified Data.HodaTime.Calendar.Gregorian as G+import Data.HodaTime.Pattern+import Data.HodaTime.Pattern.CalendarDate+import Data.HodaTime.Pattern.CalendarDateTime+import Data.HodaTime.Pattern.LocalTime+import Data.HodaTime.Pattern.Instant+import Data.HodaTime.Pattern.Offset+import Data.HodaTime.Pattern.OffsetDateTime+import Data.HodaTime.Pattern.Duration+import Data.HodaTime.Pattern.ZonedDateTime (pZonedDateTime, parseZonedDateTime)+import Data.HodaTime.Instant (fromSecondsSinceUnixEpoch)+import Data.HodaTime.TimeZone (utc)+import Data.HodaTime.ZonedDateTime (ZonedDateTime, fromInstant, fromCalendarDateTimeStrictly)+import Data.HodaTime.Offset (Offset, fromHours, fromMinutes, fromSeconds, empty)+import Data.HodaTime.OffsetDateTime (fromCalendarDateTimeWithOffset)+import qualified Data.HodaTime.Duration as Dur (fromStandardDays, fromSeconds, fromNanoseconds, add)+import Control.Applicative (Const(..))+import Data.Functor.Identity (Identity(..))++-- instance MonadThrow (QCM.PropertyM IO)++patternTests :: TestTree+patternTests = testGroup "Pattern Tests" [scProps, qcProps, unitTests]++-- top level tests++scProps :: TestTree+scProps = testGroup "(checked by SmallCheck)" []++qcProps :: TestTree+qcProps = testGroup "(checked by QuickCheck)" [ calDateTimeProps, calDateProps, localTimeProps, instantProps, offsetProps, offsetDateTimeProps, durationProps ]++unitTests :: TestTree+unitTests = testGroup "Unit tests"+ [+ testCase "format pddd is the abbreviated weekday name" $ format pddd tuesday @?= "Tue"+ ,testCase "format pdddd is the full weekday name" $ format pdddd tuesday @?= "Tuesday"+ ,testCase "format pD includes the weekday" $ format pD tuesday @?= "Tuesday, 03 March 2020"+ ,testCase "format pMMM is the abbreviated month name" $ format pMMM tuesday @?= "Mar"+ ,testCase "parse pMMM round-trips a date" $ parse (pdd <% char ' ' <> pMMM <% char ' ' <> pyyyy) "03 Mar 2020" @?= Just tuesday+ ,testCase "format pmonthDay is MMMM dd" $ format pmonthDay tuesday @?= "March 03"+ ,testCase "format pyearMonth is yyyy MMMM" $ format pyearMonth tuesday @?= "2020 March"+ ,testCase "format phh folds 15:00 to 03" $ format phh (mkLt 15) @?= "03"+ ,testCase "format phh folds 00:00 to 12" $ format phh (mkLt 0) @?= "12"+ ,testCase "format phh folds 12:00 to 12" $ format phh (mkLt 12) @?= "12"+ ,testCase "format pp is P in the afternoon" $ format pp (mkLt 15) @?= "P"+ ,testCase "format pp is A in the morning" $ format pp (mkLt 3) @?= "A"+ ,testCase "format ppp is PM at noon" $ format ppp (mkLt 12) @?= "PM"+ ,testCase "format ppp is AM at midnight" $ format ppp (mkLt 0) @?= "AM"+ ,testCase "format 12-hour+AM/PM at 15:04" $ format hhmmp (mkLtm 15 4) @?= "03:04 PM"+ ,testCase "parse 12-hour+AM/PM 03:04 PM is 15:04" $ parse hhmmp "03:04 PM" @?= Just (mkLtm 15 4)+ ,testCase "parse 12-hour+AM/PM 12:00 AM is midnight" $ parse hhmmp "12:00 AM" @?= Just (mkLtm 0 0)+ ,testCase "parse 12-hour+AM/PM 12:00 PM is noon" $ parse hhmmp "12:00 PM" @?= Just (mkLtm 12 0)+ ,testCase "format pfrac 3 truncates to milliseconds" $ format (pfrac 3) (mkLtn 123456789) @?= "123"+ ,testCase "format pfrac 6 truncates to microseconds" $ format (pfrac 6) (mkLtn 123456789) @?= "123456"+ ,testCase "format pfrac 9 shows full nanoseconds" $ format (pfrac 9) (mkLtn 123456789) @?= "123456789"+ ,testCase "format pfrac 3 zero-pads" $ format (pfrac 3) (mkLtn 7000000) @?= "007"+ ,testCase "parse pfrac 3 scales up to nanoseconds" $ parse (pfrac 3) "123" @?= Just (mkLtn 123000000)+ ,testCase "parse pfrac 9 reads full nanoseconds" $ parse (pfrac 9) "123456789" @?= Just (mkLtn 123456789) -- width parameter: width 1 is the no-padding case (unpadded format, variable-width parse); width >= 2 is fixed padded.+ ,testCase "format pday 1 has no leading zero" $ format (pday 1) tuesday @?= "3"+ ,testCase "format pday 2 zero-pads (== pdd)" $ format (pday 2) tuesday @?= format pdd tuesday+ ,testCase "format phour 1 has no leading zero" $ format (phour 1) (mkLt 3) @?= "3"+ ,testCase "format no-padding date" $ format (pyear 1 <% char '-' <> pmonthNum 1 <% char '-' <> pday 1) tuesday @?= "2020-3-3"+ ,testCase "parse no-padding date round-trips" $ parse (pyear 1 <% char '-' <> pmonthNum 1 <% char '-' <> pday 1) "2020-3-3" @?= Just tuesday+ ,testCase "no-padding parse also accepts padded input" $ parse (pyear 1 <% char '-' <> pmonthNum 1 <% char '-' <> pday 1) "2020-03-03" @?= Just tuesday+ -- pyy is the interpreting two-digit year (Noda's yy): format emits year mod 100; parse infers the century from the+ -- parse template (default year 2000). Contrast pyear, which is strict/absolute and never truncates.+ ,testCase "format pyy emits the last two digits" $ format pyy tuesday @?= "20"+ ,testCase "format pyear 2 does not truncate (strict)" $ format (pyear 2) tuesday @?= "2020"+ ,testCase "parse pyy 20 infers 2020" $ parse (pyy <% char '-' <> pMM <% char '-' <> pdd) "20-03-03" @?= Just tuesday+ ,testCase "parse pyy 99 infers 1999" $ parse (pyy <% char '-' <> pMM <% char '-' <> pdd) "99-03-03" @?= Just (mar3 1999)+ ,testCase "parse pyy 00 infers 2000" $ parse (pyy <% char '-' <> pMM <% char '-' <> pdd) "00-03-03" @?= Just (mar3 2000) ,testCase "format pR is the ISO date" $ format pR tuesday @?= "2020-03-03"+ -- setter-application order independence: <> applies the right operand's setter first, so verify that+ -- reordering composed fields (independent lenses, and the hour-sharing phh/ppp) yields the same result.+ ,testCase "date field order is independent" $ parse (pyyyy <% char '-' <> pMM <% char '-' <> pdd) "2020-03-03" @?= Just tuesday+ ,testCase "date field order is independent (reversed)" $ parse (pdd <% char '-' <> pMM <% char '-' <> pyyyy) "03-03-2020" @?= Just tuesday+ ,testCase "phh before ppp parses PM" $ parse (phh <% char ' ' <> ppp) "03 PM" @?= Just (mkLtm 15 0)+ ,testCase "ppp before phh parses PM (reversed order)" $ parse (ppp <% char ' ' <> phh) "PM 03" @?= Just (mkLtm 15 0)+ ,testCase "phh before ppp parses AM at midnight" $ parse (phh <% char ' ' <> ppp) "12 AM" @?= Just (mkLtm 0 0)+ ,testCase "ppp before phh parses AM at midnight (rev)" $ parse (ppp <% char ' ' <> phh) "AM 12" @?= Just (mkLtm 0 0)+ ,testCase "format pInstant at the Unix epoch" $ format pInstant (fromSecondsSinceUnixEpoch 0) @?= "1970-01-01T00:00:00Z"+ ,testCase "parse pInstant at the Unix epoch" $ parse pInstant "1970-01-01T00:00:00Z" @?= Just (fromSecondsSinceUnixEpoch 0)+ ,testCase "format pInstantNano at the Unix epoch" $ format pInstantNano (fromSecondsSinceUnixEpoch 0) @?= "1970-01-01T00:00:00.000000000Z"+ ,testCase "format pOffset +02:00" $ format pOffset (fromHours 2) @?= "+02:00"+ ,testCase "format pOffset -05:30" $ format pOffset (fromMinutes (-330)) @?= "-05:30"+ ,testCase "format pOffset UTC is +00:00" $ format pOffset empty @?= "+00:00"+ ,testCase "format pOffsetFull -05:30:45" $ format pOffsetFull (fromSeconds (-19845 :: Int)) @?= "-05:30:45"+ ,testCase "parse pOffset +02:00" $ parse pOffset "+02:00" @?= Just (fromHours 2)+ ,testCase "parse pOffset -05:30" $ parse pOffset "-05:30" @?= Just (fromMinutes (-330))+ ,testCase "format pOffsetZ UTC is Z" $ format pOffsetZ empty @?= "Z"+ ,testCase "format pOffsetZ +02:00" $ format pOffsetZ (fromHours 2) @?= "+02:00"+ ,testCase "parse pOffsetZ Z is UTC" $ parse pOffsetZ "Z" @?= Just empty+ ,testCase "parse pOffsetZ +02:00" $ parse pOffsetZ "+02:00" @?= Just (fromHours 2)+ ,testCase "format pOffsetDateTime +02:00" $ format pOffsetDateTime odtPos @?= "2024-04-23T09:00:00+02:00"+ ,testCase "parse pOffsetDateTime +02:00" $ parse pOffsetDateTime "2024-04-23T09:00:00+02:00" @?= Just odtPos+ ,testCase "format pOffsetDateTime -05:30" $ format pOffsetDateTime odtNeg @?= "2024-04-23T09:00:00-05:30"+ ,testCase "format pDuration 1 day 30s" $ format pDuration dur1d30 @?= "1:00:00:30"+ ,testCase "format pDuration -30s" $ format pDuration (Dur.fromSeconds (-30)) @?= "-0:00:00:30"+ ,testCase "parse pDuration 1:00:00:30" $ parse pDuration "1:00:00:30" @?= Just dur1d30+ ,testCase "format pDurationNano fraction" $ format pDurationNano (Dur.fromNanoseconds 123456789) @?= "0:00:00:00.123456789"+ ,testCase "format pZonedDateTime at the UTC epoch" $ do+ tz <- utc+ let zdt = fromInstant (fromSecondsSinceUnixEpoch 0) tz :: ZonedDateTime G.Gregorian+ format pZonedDateTime zdt @?= "1970-01-01T00:00:00 UTC"+ ,testCase "parseZonedDateTime resolves and round-trips" $ do+ tz <- utc+ let zdt0 = fromInstant (fromSecondsSinceUnixEpoch 0) tz :: ZonedDateTime G.Gregorian+ txt = format pZonedDateTime zdt0+ zdt1 <- parseZonedDateTime (const (pure tz)) fromCalendarDateTimeStrictly txt :: IO (ZonedDateTime G.Gregorian)+ format pZonedDateTime zdt1 @?= txt+ zdt2 <- parseZonedDateTime (const (pure tz)) fromCalendarDateTimeStrictly "2024-04-23T09:00:00 UTC" :: IO (ZonedDateTime G.Gregorian)+ format pZonedDateTime zdt2 @?= "2024-04-23T09:00:00 UTC"+ ]+ where+ tuesday = fromMaybe (error "impossible") $ G.calendarDate 3 G.March 2020+ mar3 y = fromMaybe (error "impossible") $ G.calendarDate 3 G.March y+ hhmmp = phh <% char ':' <> pmm <% char ' ' <> ppp+ mkLt h = mkLtm h 0+ mkLtm h m = fromMaybe (error "impossible") (localTime h m 0 0)+ mkLtn ns = fromMaybe (error "impossible") (localTime 0 0 0 ns)+ apr23_0900 = fromMaybe (error "impossible") $ at <$> G.calendarDate 23 G.April 2024 <*> localTime 9 0 0 0+ odtPos = fromCalendarDateTimeWithOffset apr23_0900 (fromHours 2)+ odtNeg = fromCalendarDateTimeWithOffset apr23_0900 (fromMinutes (-330))+ dur1d30 = Dur.fromStandardDays 1 `Dur.add` Dur.fromSeconds 30++-- properties++calDateTimeProps :: TestTree+calDateTimeProps = testGroup "CalendarDateTime conversion"+ [+ QC.testProperty "format ps CalendarDateTime -> parse ps CalendarDateTime == id" $ testCdtFormatToParseIdentity ps True+ ,QC.testProperty "format pf CalendarDateTime -> parse pf CalendarDateTime == id" $ testCdtFormatToParseIdentity pf False+ ,QC.testProperty "format pF CalendarDateTime -> parse pF CalendarDateTime == id" $ testCdtFormatToParseIdentity pF True+ ,QC.testProperty "format pg CalendarDateTime -> parse pg CalendarDateTime == id" $ testCdtFormatToParseIdentity pg False+ ,QC.testProperty "format pG CalendarDateTime -> parse pG CalendarDateTime == id" $ testCdtFormatToParseIdentity pG True+ ,QC.testProperty "format po CalendarDateTime -> parse po CalendarDateTime == id" $ testCdtFormatToParseIdentity po True+ ,QC.testProperty "format custom CalendarDateTime -> parse custom CalendarDateTime == id" $ testCdtFormatToParseIdentity (pyyyy <% char '/' <> pMMMM <% char '/' <> pdd <% char ' ' <> pHH <% char ':' <> pmm <% char ':' <> pss) True+ ]+ where+ seconds True s = s+ seconds False _ = 0+ testCdtFormatToParseIdentity pat useSeconds (RandomStandardDate y mon d) (RandomTime h m s) = monadicIO $ do+ let cdt = fromMaybe (error "impossible") $ at <$> G.calendarDate d mon y <*> localTime h m (seconds useSeconds s) 0+ cdt' <- run $ parse pat $ format pat cdt+ QCM.assert $ cdt == cdt'++calDateProps :: TestTree+calDateProps = testGroup "CalendarDate conversion"+ [+ QC.testProperty "format pd CalendarDate -> parse pd CalendarDate == id" $ testCdFormatToParseIdentity pd+ ,QC.testProperty "format pD CalendarDate -> parse pD CalendarDate == id" $ testCdFormatToParseIdentity pD+ ,QC.testProperty "format pR CalendarDate -> parse pR CalendarDate == id" $ testCdFormatToParseIdentity pR+ ,QC.testProperty "format custom CalendarDate -> parse custom CalendarDate == id" $ testCdFormatToParseIdentity (pyyyy <% char '/' <> pMMMM <% char '/' <> pdd)+ ]+ where+ testCdFormatToParseIdentity pat (RandomStandardDate y mon d) = monadicIO $ do+ let cd = fromMaybe (error "impossible") $ G.calendarDate d mon y+ cd' <- run $ parse pat $ format pat cd+ QCM.assert $ cd == cd'+localTimeProps :: TestTree+localTimeProps = testGroup "LocalTime conversion"+ [+ QC.testProperty "format pt LocalTime -> parse pt LocalTime == id" $ testLtFormatToParseIdentity pt False+ ,QC.testProperty "format pT LocalTime -> parse pT LocalTime == id" $ testLtFormatToParseIdentity pT True+ ,QC.testProperty "format custom LocalTime -> parse custom LocalTime == id" $ testLtFormatToParseIdentity (pHH <% char ':' <> pmm <% char ':' <> pss) True+ ,QC.testProperty "format 12-hour+AM/PM LocalTime -> parse == id" $ testLtFormatToParseIdentity (phh <% char ':' <> pmm <% char ' ' <> ppp) False+ ,QC.testProperty "format pr LocalTime -> parse pr LocalTime == id" $ testLtFormatToParseIdentity pr True+ ,QC.testProperty "format pfrac 9 LocalTime -> parse == id (nanoseconds)" testFracRoundTrip+ ]+ where+ seconds True s = s+ seconds False _ = 0+ testLtFormatToParseIdentity pat useSeconds (RandomTime h m s) = monadicIO $ do+ let lt = fromMaybe (error "impossible") $ localTime h m (seconds useSeconds s) 0+ lt' <- run $ parse pat $ format pat lt+ QCM.assert $ lt == lt'+ testFracRoundTrip (NonNegative ns0) = monadicIO $ do+ let ns = ns0 `mod` 1000000000+ let lt = fromMaybe (error "impossible") $ localTime 0 0 0 ns+ lt' <- run $ parse (pfrac 9) $ format (pfrac 9) lt+ QCM.assert $ lt == lt'++instantProps :: TestTree+instantProps = testGroup "Instant conversion"+ [+ QC.testProperty "format pInstant Instant -> parse pInstant Instant == id" $ testInstantRoundTrip pInstant+ ,QC.testProperty "format pInstantNano Instant -> parse pInstantNano Instant == id" $ testInstantRoundTrip pInstantNano+ ]+ where+ testInstantRoundTrip pat (NonNegative s0) = monadicIO $ do+ let s = s0 `mod` 253402300800 -- keep within 4-digit Gregorian years (1970-9999)+ let inst = fromSecondsSinceUnixEpoch s+ inst' <- run $ parse pat $ format pat inst+ QCM.assert $ inst == inst'++offsetProps :: TestTree+offsetProps = testGroup "Offset conversion"+ [+ QC.testProperty "format pOffset Offset -> parse pOffset == id (whole minutes)" $ testOffsetRoundTrip pOffset (fromMinutes :: Int -> Offset)+ ,QC.testProperty "format pOffsetFull Offset -> parse pOffsetFull == id" $ testOffsetRoundTrip pOffsetFull (fromSeconds :: Int -> Offset)+ ]+ where+ testOffsetRoundTrip pat mk n = monadicIO $ do+ let o = mk n+ o' <- run $ parse pat $ format pat o+ QCM.assert $ o == o'++offsetDateTimeProps :: TestTree+offsetDateTimeProps = testGroup "OffsetDateTime conversion"+ [+ QC.testProperty "format pOffsetDateTime -> parse pOffsetDateTime == id" testOdtRoundTrip+ ]+ where+ testOdtRoundTrip (RandomStandardDate y mon d) (RandomTime h m s) (RandomOffset oh om _) = monadicIO $ do+ let cdt = fromMaybe (error "impossible") $ at <$> G.calendarDate d mon y <*> localTime h m s 0+ off = fromMinutes (oh * 60 + om)+ odt = fromCalendarDateTimeWithOffset cdt off+ odt' <- run $ parse pOffsetDateTime $ format pOffsetDateTime odt+ QCM.assert $ odt == odt'++durationProps :: TestTree+durationProps = testGroup "Duration conversion"+ [+ QC.testProperty "format pDuration -> parse pDuration == id" $ testDurRoundTrip pDuration Dur.fromSeconds 100000000000+ ,QC.testProperty "format pDurationNano -> parse pDurationNano == id" $ testDurRoundTrip pDurationNano Dur.fromNanoseconds 1000000000000000+ ]+ where+ testDurRoundTrip pat mk bound n = monadicIO $ do+ let dur = mk (n `rem` bound) -- rem keeps the sign of n, so negative durations are exercised too+ dur' <- run $ parse pat $ format pat dur+ QCM.assert $ dur == dur'
tests/HodaTime/Util.hs view
@@ -5,18 +5,28 @@ ,RandomTime(..) ,CycleYear(..) ,RandomStandardDate(..)+ ,RandomJulianDate(..)+ ,RandomCopticDate(..)+ ,RandomPersianDate(..)+ ,RandomIslamicDate(..)+ ,RandomHebrewDate(..) ,get ,modify ,set ) where -import Test.Tasty.QuickCheck (Arbitrary(..), choose)+import Test.Tasty.QuickCheck (Arbitrary(..), choose, elements) import Control.Applicative (Const(..)) import Data.Functor.Identity (Identity(..)) import Data.HodaTime.Calendar.Gregorian (Month(..), DayOfWeek(..), Gregorian)+import qualified Data.HodaTime.Calendar.Julian as J+import qualified Data.HodaTime.Calendar.Coptic as C+import qualified Data.HodaTime.Calendar.Persian as P+import qualified Data.HodaTime.Calendar.Islamic as I+import qualified Data.HodaTime.Calendar.Hebrew as H -- arbitrary data and instances @@ -65,7 +75,7 @@ y <- choose (0,399) return $ CycleYear y -data RandomStandardDate = RandomStandardDate Int Int Int+data RandomStandardDate = RandomStandardDate Int (Month Gregorian) Int deriving (Show) instance Arbitrary RandomStandardDate where@@ -73,7 +83,131 @@ y <- choose (1972,2040) m <- choose (0,11) d <- choose (1,28)- return $ RandomStandardDate y m d+ return $ RandomStandardDate y (toEnum m) d++instance Arbitrary (J.Month J.Julian) where+ arbitrary = do+ x <- choose (0,11)+ return $ toEnum x++instance Arbitrary (J.DayOfWeek J.Julian) where+ arbitrary = do+ x <- choose (0,6)+ return $ toEnum x++-- | A random valid Julian date. The Julian calendar runs from its introduction on 1.Jan.45 BC (astronomical year+-- -44) with no upper bound, so the range spans 45 BC through the modern era and exercises BC (negative) years. The+-- day is capped at 28 so every generated (year, month, day) is a real date.+data RandomJulianDate = RandomJulianDate Int (J.Month J.Julian) Int+ deriving (Show)++instance Arbitrary RandomJulianDate where+ arbitrary = do+ y <- choose (-44,2400)+ m <- choose (0,11)+ d <- choose (1,28)+ return $ RandomJulianDate y (toEnum m) d++instance Arbitrary (C.Month C.Coptic) where+ arbitrary = do+ x <- choose (0,12)+ return $ toEnum x++instance Arbitrary (C.DayOfWeek C.Coptic) where+ arbitrary = do+ x <- choose (0,6)+ return $ toEnum x++-- | A random valid Coptic date. Months 1\-12 have 30 days; the thirteenth month (the epagomenal days) has only 5 (6+-- in a leap year), so we cap its day at 5 to keep every generated (year, month, day) valid regardless of leap year.+data RandomCopticDate = RandomCopticDate Int (C.Month C.Coptic) Int+ deriving (Show)++instance Arbitrary RandomCopticDate where+ arbitrary = do+ y <- choose (1,2000)+ m <- choose (0,12)+ d <- if m == 12 then choose (1,5) else choose (1,30)+ return $ RandomCopticDate y (toEnum m) d++instance Arbitrary (P.Month P.Persian) where+ arbitrary = do+ x <- choose (0,11)+ return $ toEnum x++instance Arbitrary (P.DayOfWeek P.Persian) where+ arbitrary = do+ x <- choose (0,6)+ return $ toEnum x++-- | A random valid Persian date. Months 1\-6 have 31 days, months 7\-11 have 30, and 'Esfand' has 29 (30 in a leap+-- year), so we cap 'Esfand' at 29 to keep every generated (year, month, day) valid regardless of leap year. The year+-- is kept within the astronomical calendar's supported range.+data RandomPersianDate = RandomPersianDate Int (P.Month P.Persian) Int+ deriving (Show)++instance Arbitrary RandomPersianDate where+ arbitrary = do+ y <- choose (1,1500)+ m <- choose (0,11)+ d <- if m < 6 then choose (1,31) else if m < 11 then choose (1,30) else choose (1,29)+ return $ RandomPersianDate y (toEnum m) d++instance Arbitrary (I.Month I.IslamicBcl) where+ arbitrary = do+ x <- choose (0,11)+ return $ toEnum x++instance Arbitrary (I.DayOfWeek I.IslamicBcl) where+ arbitrary = do+ x <- choose (0,6)+ return $ toEnum x++-- | A random valid Islamic date. Odd-numbered months have 30 days and even-numbered months 29 ('DhulHijjah' gains a+-- 30th only in a leap year), so we cap the even months (including 'DhulHijjah') at 29 to keep every generated+-- (year, month, day) valid regardless of leap year.+data RandomIslamicDate = RandomIslamicDate Int (I.Month I.IslamicBcl) Int+ deriving (Show)++instance Arbitrary RandomIslamicDate where+ arbitrary = do+ y <- choose (1,2000)+ m <- choose (0,11)+ d <- if even m then choose (1,30) else choose (1,29)+ return $ RandomIslamicDate y (toEnum m) d++instance Arbitrary (H.Month H.HebrewCivil) where+ arbitrary = do+ x <- choose (0,12)+ return $ toEnum x++instance Arbitrary (H.DayOfWeek H.HebrewCivil) where+ arbitrary = do+ x <- choose (0,6)+ return $ toEnum x++-- | The Hebrew months in calendar order, each paired with a day it is always safe to generate. 'Cheshvan' and+-- 'Kislev' are the two swing months (29 or 30 days depending on the year), so they are capped at their shorter length+-- of 29; every other length is fixed. 'AdarI' (the leap month) is only ever included for leap years (see below).+hebrewMonthCaps :: [(H.Month H.HebrewCivil, Int)]+hebrewMonthCaps =+ [ (H.Tishri, 30), (H.Cheshvan, 29), (H.Kislev, 29), (H.Tevet, 29), (H.Shevat, 30)+ , (H.AdarI, 30), (H.Adar, 29), (H.Nisan, 30), (H.Iyar, 29), (H.Sivan, 30)+ , (H.Tammuz, 29), (H.Av, 30), (H.Elul, 29) ]++-- | A random valid Hebrew (civil) date. A common year has no leap month, so 'AdarI' is offered only in leap years+-- (Metonic years 3, 6, 8, 11, 14, 17, 19); the swing months 'Cheshvan' and 'Kislev' are capped at their shorter+-- length so every generated (year, month, day) is a real date regardless of the year's exact length.+data RandomHebrewDate = RandomHebrewDate Int (H.Month H.HebrewCivil) Int+ deriving (Show)++instance Arbitrary RandomHebrewDate where+ arbitrary = do+ y <- choose (1,6000)+ let months = if (7 * y + 1) `mod` 19 < 7 then hebrewMonthCaps else filter ((/= H.AdarI) . fst) hebrewMonthCaps+ (m, cap) <- elements months+ d <- choose (1,cap)+ return $ RandomHebrewDate y m d -- Lenses
+ tests/HodaTime/WithCalendarTest.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE FlexibleContexts #-} -- for the polymorphic 'ymd' helper's Enum (MoY d) constraint+{-# LANGUAGE ScopedTypeVariables #-}+module HodaTime.WithCalendarTest+(+ withCalendarTests+)+where++import Test.Tasty+import Test.Tasty.HUnit+import Data.Maybe (fromJust)++import HodaTime.Util (get)+import Data.HodaTime.CalendarDate (withCalendar, day, month, year, CalendarDate, HasDate, MoY)+import qualified Data.HodaTime.CalendarDateTime as CDT+import qualified Data.HodaTime.ZonedDateTime as Z+import qualified Data.HodaTime.Calendar.Gregorian as G+import qualified Data.HodaTime.Calendar.Julian as J+import qualified Data.HodaTime.Calendar.Coptic as C+import qualified Data.HodaTime.Calendar.Persian as P+import qualified Data.HodaTime.Calendar.Islamic as I+import Data.HodaTime.Instant (fromSecondsSinceUnixEpoch)+import Data.HodaTime.TimeZone (utc)++withCalendarTests :: TestTree+withCalendarTests = testGroup "withCalendar Tests" [dateTests, dateTimeTests, zonedTests]++-- | Decode any 'HasDate' value to (day, 1-based month, year).+ymd :: (HasDate d, Enum (MoY d)) => d -> (Int, Int, Int)+ymd x = (get day x, succ . fromEnum $ month x, get year x)++mkG :: Int -> G.Month G.Gregorian -> Int -> CalendarDate G.Gregorian+mkG d m y = fromJust $ G.calendarDate d m y++mkJ :: Int -> J.Month J.Julian -> Int -> CalendarDate J.Julian+mkJ d m y = fromJust $ J.calendarDate d m y++dateTests :: TestTree+dateTests = testGroup "CalendarDate"+ [+ testCase "Gregorian 17.Jun.2020 -> Julian 4.Jun.2020 (13 days behind)" $+ ymd (withCalendar (mkG 17 G.June 2020) :: CalendarDate J.Julian) @?= (4, 6, 2020)+ ,testCase "Gregorian 11.Sep.2021 -> Coptic 1 Thout 1738 (Nayrouz)" $+ ymd (withCalendar (mkG 11 G.September 2021) :: CalendarDate C.Coptic) @?= (1, 1, 1738)+ ,testCase "Julian 29.Aug.284 -> Coptic 1 Thout 1 (Coptic epoch)" $+ ymd (withCalendar (mkJ 29 J.August 284) :: CalendarDate C.Coptic) @?= (1, 1, 1)+ ,testCase "Gregorian 21.Mar.2021 -> Persian 1 Farvardin 1400 (Nowruz)" $+ ymd (withCalendar (mkG 21 G.March 2021) :: CalendarDate P.Persian) @?= (1, 1, 1400)+ ,testCase "Julian 15.Jul.622 -> Islamic 1 Muharram 1 (Hijri epoch)" $+ ymd (withCalendar (mkJ 15 J.July 622) :: CalendarDate I.IslamicBcl) @?= (1, 1, 1)+ ,testCase "Gregorian -> Islamic -> Gregorian round-trips" $+ let g = mkG 17 G.June 2020+ in (withCalendar (withCalendar g :: CalendarDate I.IslamicBcl) :: CalendarDate G.Gregorian) @?= g+ ,testCase "Gregorian -> Julian -> Gregorian round-trips" $+ let g = mkG 17 G.June 2020+ in (withCalendar (withCalendar g :: CalendarDate J.Julian) :: CalendarDate G.Gregorian) @?= g+ ]++dateTimeTests :: TestTree+dateTimeTests = testGroup "CalendarDateTime"+ [+ testCase "Gregorian 17.Jun.2020 (start of day) -> Julian 4.Jun.2020" $+ ymd (CDT.withCalendar (CDT.atStartOfDay (mkG 17 G.June 2020)) :: CDT.CalendarDateTime J.Julian) @?= (4, 6, 2020)+ ,testCase "Gregorian -> Julian -> Gregorian round-trips (keeps the LocalTime)" $+ let cdt = CDT.atStartOfDay (mkG 17 G.June 2020)+ in (CDT.withCalendar (CDT.withCalendar cdt :: CDT.CalendarDateTime J.Julian) :: CDT.CalendarDateTime G.Gregorian) @?= cdt+ ]++zonedTests :: TestTree+zonedTests = testGroup "ZonedDateTime"+ [+ testCase "same Instant (UTC), Gregorian view -> Julian view is 13 days behind" $ do+ tz <- utc+ let inst = fromSecondsSinceUnixEpoch 1592352000 -- 2020-06-17T00:00:00Z+ zdtG = Z.fromInstant inst tz :: Z.ZonedDateTime G.Gregorian+ zdtJ = Z.withCalendar zdtG :: Z.ZonedDateTime J.Julian+ (Z.year zdtJ, succ (fromEnum (Z.month zdtJ)), Z.day zdtJ) @?= (2020, 6, 4)+ ,testCase "round-trips back to the same Instant" $ do+ tz <- utc+ let inst = fromSecondsSinceUnixEpoch 1592352000+ zdtG = Z.fromInstant inst tz :: Z.ZonedDateTime G.Gregorian+ zdtJ = Z.withCalendar zdtG :: Z.ZonedDateTime J.Julian+ Z.toInstant zdtJ @?= inst+ ]
tests/HodaTime/ZonedDateTimeTest.hs view
@@ -14,8 +14,10 @@ import Data.Maybe (catMaybes) import HodaTime.Util-import Data.HodaTime.ZonedDateTime (fromCalendarDateTimeStrictly, fromCalendarDateTimeLeniently, fromCalendarDateTimeAll, toCalendarDateTime, zoneAbbreviation, ZonedDateTime) -- remove ZonedDateTime-import Data.HodaTime.TimeZone (timeZone)+import Data.HodaTime.ZonedDateTime (fromInstant, fromCalendarDateTimeStrictly, fromCalendarDateTimeLeniently, fromCalendarDateTimeAll, toCalendarDateTime, toInstant, zoneAbbreviation, zoneId, ZonedDateTime) -- remove ZonedDateTime+import Data.HodaTime.Instant (fromSecondsSinceUnixEpoch)+import Data.HodaTime.TimeZone (utc, timeZone)+import Data.Hashable (hash) import Data.HodaTime.Calendar.Gregorian (Month(..)) import qualified Data.HodaTime.Calendar.Gregorian as G import Data.HodaTime.LocalTime (localTime)@@ -32,7 +34,7 @@ unitTests :: TestTree unitTests = testGroup "Unit tests" [- lenientZoneTransitionUnits, allZoneTransitionUnits+ lenientZoneTransitionUnits, allZoneTransitionUnits, ordUnits, hashUnits ] -- properties@@ -45,7 +47,7 @@ where testCalToZonedIdentity zone (RandomStandardDate y mon d) (RandomTime h m s) = monadicIO $ do tz <- run (timeZone zone)- let cdt = at <$> G.calendarDate d (toEnum mon) y <*> localTime h m s 0+ let cdt = at <$> G.calendarDate d mon y <*> localTime h m s 0 let zdt = join $ flip fromCalendarDateTimeStrictly tz <$> cdt let cdt' = toCalendarDateTime <$> zdt QCM.assert $ cdt == cdt'@@ -59,8 +61,8 @@ ,testCase "October 30 2039 2:10:15.30 -> October 30 2039 2:10:15.30 CEST" $ ensureHour startZone resultZone 30 October 2039 2 ] where- startZone = if SysInfo.os == "mingw32" then "W. Europe Standard Time" else "Europe/Zurich"- resultZone = if SysInfo.os == "mingw32" then "W. Europe Summer Time" else "CEST"+ startZone = "Europe/Zurich"+ resultZone = if SysInfo.os == "mingw32" then "W. Europe Daylight Time" else "CEST" toLocalTime h = localTime h 10 15 30 mkDate zone d m y = do tz <- timeZone zone@@ -90,14 +92,16 @@ ,testCase "November 4 2007 1:10:15.30 -> [November 4 2007: 1:10:15.30 CDT, 1:10:15.30 CST]" $ ensureHours' 1 startUsZone [summerUsZone, normUsZone] 4 November 2007 [1,1] ,testCase "March 9 2008 2:10:15.30 -> []" $ ensureHours startUsZone [] 9 March 2008 [] ,testCase "November 2 2008 1:10:15.30 -> [November 2 2008: 1:10:15.30 CDT, 1:10:15.30 CST]" $ ensureHours' 1 startUsZone [summerUsZone, normUsZone] 2 November 2008 [1,1]+ ,testCase "March 13 2039 2:10:15.30 -> []" $ ensureHours startUsZone [] 13 March 2039 []+ ,testCase "November 6 2039 1:10:15.30 -> [November 6 2039: 1:10:15.30 CDT, 1:10:15.30 CST]" $ ensureHours' 1 startUsZone [summerUsZone, normUsZone] 6 November 2039 [1,1] ] where- startEuZone = if SysInfo.os == "mingw32" then "W. Europe Standard Time" else "Europe/Zurich"- startUsZone = if SysInfo.os == "mingw32" then "Central Standard Time" else "US/Central"+ startEuZone = "Europe/Zurich"+ startUsZone = "America/Chicago" normEuZone = if SysInfo.os == "mingw32" then "W. Europe Standard Time" else "CET" normUsZone = if SysInfo.os == "mingw32" then "Central Standard Time" else "CST"- summerEuZone = if SysInfo.os == "mingw32" then "W. Europe Summer Time" else "CEST"- summerUsZone = if SysInfo.os == "mingw32" then "Central Summer Time" else "CDT"+ summerEuZone = if SysInfo.os == "mingw32" then "W. Europe Daylight Time" else "CEST"+ summerUsZone = if SysInfo.os == "mingw32" then "Central Daylight Time" else "CDT" toLocalTime h = localTime h 10 15 30 mkDates h zone d m y = do tz <- timeZone zone@@ -111,3 +115,41 @@ let cdtExpecteds = catMaybes $ (\x -> at <$> G.calendarDate d m y <*> toLocalTime x) <$> hs assertEqual "Zone abbreviation" expectedAbbrs abbrs assertEqual "" cdtExpecteds cdts++ordUnits :: TestTree+ordUnits = testGroup "Ord ZonedDateTime"+ [+ testCase "orders by physical instant" $ do+ tz <- utc+ let z1 = fromInstant (fromSecondsSinceUnixEpoch 1000000000) tz :: ZonedDateTime G.Gregorian+ z2 = fromInstant (fromSecondsSinceUnixEpoch 1000000001) tz :: ZonedDateTime G.Gregorian+ assertEqual "earlier instant compares LT" LT (compare z1 z2)+ assertBool "earlier instant is less than later" (z1 < z2)+ ,testCase "same instant tie-breaks on zone id" $ do+ utcTz <- utc+ zurich <- timeZone euZone+ let inst = fromSecondsSinceUnixEpoch 1000000000+ zUtc = fromInstant inst utcTz :: ZonedDateTime G.Gregorian+ zZur = fromInstant inst zurich :: ZonedDateTime G.Gregorian+ assertEqual "same physical instant" (toInstant zZur) (toInstant zUtc)+ assertEqual "tie-break falls through to zone id" (compare (zoneId zZur) (zoneId zUtc)) (compare zZur zUtc)+ assertBool "distinct zones do not compare EQ" (compare zZur zUtc /= EQ)+ ]+ where+ euZone = "Europe/Zurich"++hashUnits :: TestTree+hashUnits = testGroup "Hashable ZonedDateTime"+ [+ testCase "equal values hash equally" $ do+ tz <- utc+ let z1 = fromInstant (fromSecondsSinceUnixEpoch 1000000000) tz :: ZonedDateTime G.Gregorian+ z2 = fromInstant (fromSecondsSinceUnixEpoch 1000000000) tz :: ZonedDateTime G.Gregorian+ assertEqual "equal values" z1 z2+ assertEqual "equal hashes" (hash z1) (hash z2)+ ,testCase "different instants hash differently" $ do+ tz <- utc+ let z1 = fromInstant (fromSecondsSinceUnixEpoch 1000000000) tz :: ZonedDateTime G.Gregorian+ z2 = fromInstant (fromSecondsSinceUnixEpoch 1000000001) tz :: ZonedDateTime G.Gregorian+ assertBool "distinct hashes" (hash z1 /= hash z2)+ ]
tests/test.hs view
@@ -5,14 +5,23 @@ import HodaTime.OffsetTest import HodaTime.LocalTimeTest import HodaTime.Calendar.GregorianTest+import HodaTime.Calendar.JulianTest+import HodaTime.Calendar.CopticTest+import HodaTime.Calendar.PersianTest+import HodaTime.Calendar.IslamicTest+import HodaTime.Calendar.HebrewTest import HodaTime.CalendarDateTimeTest import HodaTime.ZonedDateTimeTest+import HodaTime.PatternTest+import HodaTime.WithCalendarTest+import HodaTime.LocaleTest+import HodaTime.ClassInstanceTests main :: IO () main = defaultMain tests tests :: TestTree-tests = testGroup "Tests" [instantTests, durationTests, offsetTests, localTimeTests, gregorianTests, calendarDateTimeTests, zonedDateTimeTests]+tests = testGroup "Tests" [instantTests, durationTests, offsetTests, localTimeTests, gregorianTests, julianTests, copticTests, persianTests, islamicTests, hebrewTests, calendarDateTimeTests, zonedDateTimeTests, patternTests, withCalendarTests, localeTests, classInstanceTests] {- unitTests :: TestTree