hodatime 1.0.0.0 → 1.1.0.0

raw patch · 41 files changed

+722/−482 lines, 41 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.md +7/−0
• bench/HodaTime/CalendarBench.hs +4/−13
• hodatime.cabal +5/−1
• scripts/sync-version.sh +64/−0
• src/Data/HodaTime.hs +10/−9
• src/Data/HodaTime/Calendar/Coptic.hs +7/−6
• src/Data/HodaTime/Calendar/Gregorian/Internal.hs +10/−6
• src/Data/HodaTime/Calendar/Hebrew.hs +31/−36
• src/Data/HodaTime/Calendar/Internal.hs +22/−22
• src/Data/HodaTime/Calendar/Islamic.hs +7/−6
• src/Data/HodaTime/Calendar/Julian.hs +8/−7
• src/Data/HodaTime/Calendar/Persian.hs +7/−6
• src/Data/HodaTime/CalendarDate.hs +11/−2
• src/Data/HodaTime/CalendarDateTime.hs +11/−2
• src/Data/HodaTime/CalendarDateTime/Internal.hs +21/−24
• src/Data/HodaTime/Internal.hs +0/−32
• src/Data/HodaTime/LocalTime.hs +5/−1
• src/Data/HodaTime/LocalTime/Internal.hs +37/−33
• src/Data/HodaTime/Pattern/CalendarDate.hs +23/−24
• src/Data/HodaTime/Pattern/CalendarDateTime.hs +8/−7
• src/Data/HodaTime/Pattern/Internal.hs +13/−12
• src/Data/HodaTime/Pattern/LocalTime.hs +14/−15
• src/Data/HodaTime/Pattern/Locale.hs +8/−8
• src/Data/HodaTime/Pattern/OffsetDateTime.hs +2/−2
• src/Data/HodaTime/Pattern/ZonedDateTime.hs +3/−3
• src/Data/HodaTime/Period.hs +156/−0
• src/Data/HodaTime/ZonedDateTime.hs +2/−3
• src/Data/HodaTime/ZonedDateTime/Internal.hs +6/−10
• tests/HodaTime/Calendar/CopticTest.hs +13/−12
• tests/HodaTime/Calendar/GregorianTest.hs +37/−36
• tests/HodaTime/Calendar/HebrewTest.hs +17/−16
• tests/HodaTime/Calendar/IslamicTest.hs +13/−12
• tests/HodaTime/Calendar/JulianTest.hs +18/−17
• tests/HodaTime/Calendar/PersianTest.hs +13/−12
• tests/HodaTime/CalendarDateTimeTest.hs +23/−35
• tests/HodaTime/InstantTest.hs +2/−3
• tests/HodaTime/LocalTimeTest.hs +17/−29
• tests/HodaTime/PeriodTest.hs +64/−0
• tests/HodaTime/Util.hs +0/−17
• tests/HodaTime/WithCalendarTest.hs +1/−2
• tests/test.hs +2/−1

@@ -55,6 +55,13 @@  Release notes are published on the [GitHub releases page](https://github.com/jason-johnson/hodatime/releases). +## Versioning++Git release tags are the version source of truth. On a commit tagged `vX.Y.Z.W`,+`scripts/sync-version.sh` sets the Cabal package version to `X.Y.Z.W`; later+commits use `X.Y.Z.(W+1)`. CI runs the script before building or publishing.+Run it locally after creating a tag to synchronize `hodatime.cabal`.+ ## License  BSD-3-Clause. See [LICENSE](LICENSE).

@@ -6,24 +6,15 @@ 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)+import Data.HodaTime.Period (applyPeriod, days)  -- | 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)+forceDate x = day x + 100 * fromEnum (month x) + 10000 * year x + 1000000 * fromEnum (dayOfWeek x)  calendarBenches :: Benchmark calendarBenches = bgroup "Calendar (Gregorian)"@@ -32,8 +23,8 @@     ,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 "addDays in-century"    $ nf (forceDate . applyPeriod (days 40)) cd+    ,bench "addDays cross-century" $ nf (forceDate . applyPeriod (days 40000)) cd     ,bench "next dow"              $ nf (forceDate . next 3 Monday) cd   ]   where

@@ -1,6 +1,7 @@ cabal-version:  2.4 name:           hodatime-version:        1.0.0.0+-- Synced from Git tags by scripts/sync-version.sh before CI builds.+version:        1.1.0.0 stability:      experimental license:        BSD-3-Clause license-file:   LICENSE@@ -39,6 +40,7 @@                    README.md                    CHANGELOG.md extra-source-files:+                   scripts/sync-version.sh                    platform/osx/Data/HodaTime/TimeZone/Platform.hs                    platform/osx/Data/HodaTime/Instant/Platform.hs                    platform/linux/Data/HodaTime/TimeZone/Platform.hs@@ -105,6 +107,7 @@                    Data.HodaTime.Offset,                    Data.HodaTime.LocalTime,                    Data.HodaTime.OffsetDateTime,+                   Data.HodaTime.Period,                    Data.HodaTime.TimeZone,                    Data.HodaTime.ZonedDateTime,                    Data.HodaTime.Locale,@@ -174,6 +177,7 @@                    HodaTime.CalendarDateTimeTest,                    HodaTime.ZonedDateTimeTest,                    HodaTime.PatternTest,+                   HodaTime.PeriodTest,                    HodaTime.WithCalendarTest,                    HodaTime.LocaleTest,                    HodaTime.ClassInstanceTests

@@ -0,0 +1,64 @@+#!/bin/sh+set -eu++repo_root=$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd)+cabal_file="$repo_root/hodatime.cabal"+mode=${1:-}++if [ "$mode" = "--set" ]; then+  version=${2:?Usage: scripts/sync-version.sh --set VERSION}+  case "$version" in+    *[!0-9.]* | .* | *. | *..*)+      echo "Invalid Cabal version: $version" >&2+      exit 1+      ;;+  esac+else++  version_tag=$(git -C "$repo_root" tag --points-at HEAD --sort=-version:refname |+    grep -E '^v[0-9]+\.[0-9]+\.[0-9]+(\.[0-9]+)?$' |+    head -n 1 || true)++  if [ -n "$version_tag" ]; then+    version=${version_tag#v}+  else+    version_tag=$(git -C "$repo_root" describe --tags --abbrev=0 --match 'v[0-9]*' 2>/dev/null || true)+    if [ -z "$version_tag" ]; then+      echo "No reachable vX.Y.Z or vX.Y.Z.W tag found" >&2+      exit 1+    fi++    tagged_version=${version_tag#v}+    old_ifs=$IFS+    IFS=.+    set -- $tagged_version+    IFS=$old_ifs++    case $# in+      3) version="$1.$2.$3.1" ;;+      4) version="$1.$2.$3.$(($4 + 1))" ;;+      *)+        echo "Unsupported version tag: $version_tag" >&2+        exit 1+        ;;+    esac+  fi+fi++current_version=$(awk -F: '/^version:/ { sub(/^[[:space:]]+/, "", $2); print $2; exit }' "$cabal_file")++if [ "$mode" = "--check" ]; then+  if [ "$current_version" != "$version" ]; then+    echo "hodatime.cabal has version $current_version; Git requires $version" >&2+    exit 1+  fi+else+  temporary_file="$cabal_file.tmp"+  awk -v version="$version" '+    /^version:/ && !updated { print "version:        " version; updated = 1; next }+    { print }+  ' "$cabal_file" > "$temporary_file"+  mv "$temporary_file" "$cabal_file"+fi++echo "$version"

@@ -52,10 +52,9 @@  === Accessors -For access the convention is simple: read-only accessors are just functions and all read/write accessors are valid lenses.  We incur-no dependancy on any lens library but the accessors are defined-<https://github.com/ekmett/lens/wiki/How-can-I-write-lenses-without-depending-on-lens%3F here>.  The user of the library can use their-favorite lens library or define 3 simple functions (see tests/HodaTime/Util.hs) if they do not wish to use any existing library.+For access the convention is simple: read-only accessors are functions, and independent read/write product fields may be valid lenses.+Calendar and clock arithmetic is represented by "Data.HodaTime.Period", because normalization, rollover and end-of-month clamping do+not obey the lens laws.  = How to use this library @@ -77,6 +76,8 @@  [@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. +[@Period@ — "Data.HodaTime.Period"] A calendar-relative amount such as "five months and two hours". Period unit constructors compose with @(<>)@, and their target type records whether date fields, time fields, or both are required.+ [@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.@@ -173,13 +174,13 @@  __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:+__Calendar arithmetic.__  Calendar-relative arithmetic is represented by a "Data.HodaTime.Period". Unit constructors compose monoidally, and the target type prevents applying a period to a value without the required fields: -* @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.+> applyPeriod (months 2) calendarDate+> applyPeriod (hours 2) localTime+> applyPeriod (months 5 <> hours 2) calendarDateTime -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.+Date fields are applied from largest to smallest, then time fields. End-of-month values clamp when a year or month is applied, weeks and days move along the calendar timeline, a time-only period wraps at midnight, and a mixed period carries that rollover into its date.  === Crossing over: offsets and zones 

@@ -31,7 +31,7 @@ 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.HodaTime.Calendar.Internal (mkCommonDaySetter, mkCommonMonthSetter, mkYearSetter, mkFromNthDay, mkFromWeekDate, moveByDow, dayOfWeekFromDays, daysPerStandardYear, daysPerFourYears) import Data.Int (Int32) import Data.Word (Word8) import Control.Monad (guard)@@ -85,15 +85,16 @@   toYmd = copticToYmd   calendarName _ = "Coptic" -  day' = mkCommonDayLens invalidDayThresh yearMonthDayToDays copticFromDays copticToYmd+  day' (CopticDate _ d _ _) = fromIntegral d+  setDay' = mkCommonDaySetter invalidDayThresh yearMonthDayToDays copticFromDays copticToYmd   {-# INLINE day' #-}    month' (CopticDate _ _ m _) = toEnum . fromIntegral $ m--  monthl' = mkCommonMonthLens monthsPerYear firstCopDayTuple maxDaysInMonth yearMonthDayToDays copticToYmd copticFromDays-  {-# INLINE monthl' #-}+  setMonthIndex' = mkCommonMonthSetter monthsPerYear firstCopDayTuple maxDaysInMonth yearMonthDayToDays copticToYmd copticFromDays+  {-# INLINE month' #-} -  year' = mkYearLens firstCopDayTuple maxDaysInMonth yearMonthDayToDays copticToYmd copticFromDays+  year' (CopticDate _ _ _ y) = fromIntegral y+  setYear' = mkYearSetter firstCopDayTuple maxDaysInMonth yearMonthDayToDays copticToYmd copticFromDays   {-# INLINE year' #-}    dayOfWeek' (CopticDate days _ _ _) = toEnum . dayOfWeekFromDays epochDayOfWeek . fromIntegral $ days

@@ -24,7 +24,7 @@  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.Internal (mkCommonMonthLens, mkYearLens, mkFromWeekDate, dayOfWeekFromDays, commonMonthDayOffsets, borders, daysPerStandardYear, daysPerCentury)+import Data.HodaTime.Calendar.Internal (mkCommonMonthSetter, mkYearSetter, mkFromWeekDate, dayOfWeekFromDays, commonMonthDayOffsets, borders, daysPerStandardYear, daysPerCentury) import Data.HodaTime.Instant.Internal (Instant(..)) import Control.Arrow ((>>>), (&&&), (***), first) import Data.Int (Int32, Int8)@@ -70,18 +70,22 @@   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)+  day' gd = fromIntegral d+    where (_, _, d) = gregorianToYearMonthDay gd++  setDay' newDay gd = shiftDaysWith clampToValid (newDay - fromIntegral d) gd     where       (_, _, d) = gregorianToYearMonthDay gd-      mkgd d' = shiftDaysWith clampToValid (d' - fromIntegral d) gd    month' gd = toEnum . fromIntegral $ m     where (_, m, _) = gregorianToYearMonthDay gd+  setMonthIndex' = mkCommonMonthSetter 12 firstGregDayTuple maxDaysInMonth yearMonthDayToDays gregorianToYearMonthDay daysToGregorian+  {-# INLINE month' #-} -  monthl' = mkCommonMonthLens 12 firstGregDayTuple maxDaysInMonth yearMonthDayToDays gregorianToYearMonthDay daysToGregorian-  {-# INLINE monthl' #-}+  year' gd = fromIntegral y+    where (y, _, _) = gregorianToYearMonthDay gd -  year' = mkYearLens firstGregDayTuple maxDaysInMonth yearMonthDayToDays gregorianToYearMonthDay daysToGregorian+  setYear' = mkYearSetter firstGregDayTuple maxDaysInMonth yearMonthDayToDays gregorianToYearMonthDay daysToGregorian   {-# INLINE year' #-}    dayOfWeek' (GregorianDate _ century dic) = toEnum . dayOfWeekFromDays epochDayOfWeek $ 5 * fromIntegral century + fromIntegral dic

@@ -94,7 +94,7 @@ 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+-- | The Hebrew calendar. All field access 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.@@ -116,15 +116,16 @@   toYmd = hebrewToYmd   calendarName _ = "Hebrew" -  day' = hebrewDayLens+  day' (HebrewDate _ d _ _) = fromIntegral d+  setDay' = setHebrewDay   {-# INLINE day' #-}    month' (HebrewDate _ _ ci _) = monthAt (fromIntegral ci)--  monthl' = hebrewMonthLens (numberingStart @n)-  {-# INLINE monthl' #-}+  setMonthIndex' = setHebrewMonth (numberingStart @n)+  {-# INLINE month' #-} -  year' = hebrewYearLens+  year' (HebrewDate _ _ _ y) = fromIntegral y+  setYear' = setHebrewYear   {-# INLINE year' #-}    dayOfWeek' (HebrewDate days _ _ _) = toEnum . dayOfWeekFromDays epochDayOfWeek . fromIntegral $ days@@ -366,49 +367,43 @@ 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+-- setters (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)+-- | Set the day of month, rolling overflow into the next month.+setHebrewDay :: DayOfMonth -> Date (Hebrew n) -> Date (Hebrew n)+setHebrewDay newDay date = hebrewFromDays (fromIntegral days)   where-    (y, ci, d) = hebrewToYmd date+    (y, ci, _) = 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+    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+-- | Set the numbered month. Values outside the current year move in calendar order, --   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+setHebrewMonth :: Int -> Int -> Date (Hebrew n) -> Date (Hebrew n)+setHebrewMonth start target date = hebrewFromDays (fromIntegral days)   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+    (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)+-- | Set the year, clamping the day and moving 'AdarI' to 'Adar' when necessary.+setHebrewYear :: Year -> Date (Hebrew n) -> Date (Hebrew n)+setHebrewYear newYear date = hebrewFromDays (fromIntegral days)   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'+    (_, ci, d) = hebrewToYmd date+    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.

@@ -2,9 +2,9 @@ {-# LANGUAGE FlexibleContexts #-} module Data.HodaTime.Calendar.Internal (-   mkCommonDayLens-  ,mkCommonMonthLens-  ,mkYearLens+  mkCommonDaySetter+  ,mkCommonMonthSetter+  ,mkYearSetter   ,mkFromNthDay   ,mkFromWeekDate   ,moveByDow@@ -37,38 +37,38 @@ -- 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+-- epoch-relative day count) and @toYmd@ (decode a date to year\/month\/day) so the same setter logic works whether -- the calendar stores a flat day count, a packed cycle, or anything else. -mkCommonDayLens :: (Functor f, Enum mon) =>+mkCommonDaySetter :: Enum mon =>      Int   -> (Year -> mon -> DayOfMonth -> Int)   -> (Int32 -> d)   -> (d -> (Int32, Word8, Word8))-  -> (DayOfMonth -> f DayOfMonth)+  -> DayOfMonth   -> d-  -> f d-mkCommonDayLens preStartDay yearMonthDayToDays fromDays toYmd f date = mkcd . (rest +) <$> f (fromIntegral d)+  -> d+mkCommonDaySetter preStartDay yearMonthDayToDays fromDays toYmd newDay date = mkcd (rest + newDay)     where-      (y, m, d) = toYmd date+      (y, m, _) = 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 #-}+{-# INLINE mkCommonDaySetter #-} -mkCommonMonthLens :: (Functor f, Enum mon) =>+mkCommonMonthSetter :: Enum mon =>      Int   -> (Int, Int, Word8)   -> (mon -> Year -> Int)   -> (Year -> mon -> DayOfMonth -> Int)   -> (d -> (Int32, Word8, Word8))   -> (Int32 -> d)-  -> (Int -> f Int)+  -> Int   -> d-  -> f d-mkCommonMonthLens monthsPerYear firstDayTuple maxDaysInMonth yearMonthDayToDays toYmd fromDays f date = mkcd <$> f (fromIntegral m)+  -> d+mkCommonMonthSetter monthsPerYear firstDayTuple maxDaysInMonth yearMonthDayToDays toYmd fromDays newMonth date = mkcd newMonth     where-      (y, m, d) = toYmd date+      (y, _, d) = toYmd date       mkcd months = fromDays (fromIntegral days)         where           (y', months') = flip divMod monthsPerYear >>> first (+ fromIntegral y) $ months@@ -76,20 +76,20 @@           mdim = fromIntegral $ maxDaysInMonth (toEnum m') y'           d'' = if d' > mdim then mdim else d'           days = yearMonthDayToDays y'' (toEnum m') (fromIntegral d'')-{-# INLINE mkCommonMonthLens #-}+{-# INLINE mkCommonMonthSetter #-} -mkYearLens :: (Functor f, Enum mon) =>+mkYearSetter :: Enum mon =>      (Int, Word8, Word8)   -> (mon -> Year -> Int)   -> (Year -> mon -> DayOfMonth -> Int)   -> (d -> (Int32, Word8, Word8))   -> (Int32 -> d)-  -> (Int -> f Int)+  -> Int   -> d-  -> f d-mkYearLens firstDayTuple maxDaysInMonth yearMonthDayToDays toYmd fromDays f date = mkcd <$> f (fromIntegral y)+  -> d+mkYearSetter firstDayTuple maxDaysInMonth yearMonthDayToDays toYmd fromDays newYear date = mkcd newYear     where-      (y, m, d) = toYmd date+      (_, m, d) = toYmd date       mkcd y' = fromDays days         where           (y'', m', d') = if (y', m, d) < firstDayTuple then firstDayTuple else (y', m, d)@@ -97,7 +97,7 @@           mdim = fromIntegral $ maxDaysInMonth m'' y''           d'' = if d' > mdim then mdim else d'           days = fromIntegral $ yearMonthDayToDays y'' m'' (fromIntegral d'')-{-# INLINE mkYearLens #-}+{-# INLINE mkYearSetter #-}  -- | 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

@@ -82,7 +82,7 @@ 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.Internal (mkCommonDaySetter, mkCommonMonthSetter, mkYearSetter, mkFromNthDay, mkFromWeekDate, moveByDow, dayOfWeekFromDays) import Data.Bits ((.&.), shiftL, testBit, popCount) import Data.Int (Int32) import Data.Word (Word8)@@ -174,15 +174,16 @@   toYmd = islamicToYmd   calendarName _ = "Islamic" -  day' = let b = leapPatternBits @l in mkCommonDayLens invalidDayThresh (yearMonthDayToDays b) (islamicFromDays b) islamicToYmd+  day' (IslamicDate _ d _ _) = fromIntegral d+  setDay' = let b = leapPatternBits @l in mkCommonDaySetter 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' #-}+  setMonthIndex' = let b = leapPatternBits @l in mkCommonMonthSetter monthsPerYear firstIslDayTuple (maxDaysInMonth b) (yearMonthDayToDays b) islamicToYmd (islamicFromDays b)+  {-# INLINE month' #-} -  year' = let b = leapPatternBits @l in mkYearLens firstIslDayTuple (maxDaysInMonth b) (yearMonthDayToDays b) islamicToYmd (islamicFromDays b)+  year' (IslamicDate _ _ _ y) = fromIntegral y+  setYear' = let b = leapPatternBits @l in mkYearSetter firstIslDayTuple (maxDaysInMonth b) (yearMonthDayToDays b) islamicToYmd (islamicFromDays b)   {-# INLINE year' #-}    dayOfWeek' (IslamicDate days _ _ _) = toEnum . dayOfWeekFromDays epochDayOfWeek . fromIntegral $ days

@@ -44,7 +44,7 @@ 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.HodaTime.Calendar.Internal (mkCommonDaySetter, mkCommonMonthSetter, mkYearSetter, mkFromNthDay, mkFromWeekDate, moveByDow, dayOfWeekFromDays, commonMonthDayOffsets, borders, daysPerStandardYear, daysPerFourYears) import Data.Int (Int32) import Data.Word (Word8) import Control.Arrow ((>>>), (***), (&&&))@@ -56,7 +56,7 @@  -- | 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+--   upper bound beyond the 'Int32' day representation. This tuple is also the floor the shared setter\/constructor --   helpers clamp to. firstJulDayTuple :: (Integral a, Integral b, Integral c) => (a, b, c) firstJulDayTuple = (-44, 0, 1)        -- NOTE: 1.Jan.45 BC@@ -100,15 +100,16 @@   toYmd = julianToYmd   calendarName _ = "Julian" -  day' = mkCommonDayLens invalidDayThresh yearMonthDayToDays julianFromDays julianToYmd+  day' (JulianDate _ d _ _) = fromIntegral d+  setDay' = mkCommonDaySetter invalidDayThresh yearMonthDayToDays julianFromDays julianToYmd   {-# INLINE day' #-}    month' (JulianDate _ _ m _) = toEnum . fromIntegral $ m--  monthl' = mkCommonMonthLens 12 firstJulDayTuple maxDaysInMonth yearMonthDayToDays julianToYmd julianFromDays-  {-# INLINE monthl' #-}+  setMonthIndex' = mkCommonMonthSetter 12 firstJulDayTuple maxDaysInMonth yearMonthDayToDays julianToYmd julianFromDays+  {-# INLINE month' #-} -  year' = mkYearLens firstJulDayTuple maxDaysInMonth yearMonthDayToDays julianToYmd julianFromDays+  year' (JulianDate _ _ _ y) = fromIntegral y+  setYear' = mkYearSetter firstJulDayTuple maxDaysInMonth yearMonthDayToDays julianToYmd julianFromDays   {-# INLINE year' #-}    dayOfWeek' (JulianDate days _ _ _) = toEnum . dayOfWeekFromDays epochDayOfWeek . fromIntegral $ days

@@ -55,7 +55,7 @@ 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.Internal (mkCommonDaySetter, mkCommonMonthSetter, mkYearSetter, mkFromNthDay, mkFromWeekDate, moveByDow, dayOfWeekFromDays) import Data.HodaTime.Calendar.Persian.Astronomical (newYearDay, minPersianYear, maxPersianYear) import Data.Int (Int32) import Data.Word (Word8)@@ -103,15 +103,16 @@   toYmd = persianToYmd   calendarName _ = "Persian" -  day' = mkCommonDayLens invalidDayThresh yearMonthDayToDays persianFromDays persianToYmd+  day' (PersianDate _ d _ _) = fromIntegral d+  setDay' = mkCommonDaySetter invalidDayThresh yearMonthDayToDays persianFromDays persianToYmd   {-# INLINE day' #-}    month' (PersianDate _ _ m _) = toEnum . fromIntegral $ m--  monthl' = mkCommonMonthLens monthsPerYear firstPerDayTuple maxDaysInMonth yearMonthDayToDays persianToYmd persianFromDays-  {-# INLINE monthl' #-}+  setMonthIndex' = mkCommonMonthSetter monthsPerYear firstPerDayTuple maxDaysInMonth yearMonthDayToDays persianToYmd persianFromDays+  {-# INLINE month' #-} -  year' = mkYearLens firstPerDayTuple maxDaysInMonth yearMonthDayToDays persianToYmd persianFromDays+  year' (PersianDate _ _ _ y) = fromIntegral y+  setYear' = mkYearSetter firstPerDayTuple maxDaysInMonth yearMonthDayToDays persianToYmd persianFromDays   {-# INLINE year' #-}    dayOfWeek' (PersianDate days _ _ _) = toEnum . dayOfWeekFromDays epochDayOfWeek . fromIntegral $ days

@@ -61,12 +61,21 @@   ,WeekNumber   ,DayOfMonth   ,CalendarDate-  ,HasDate(..)+  ,HasDate+  ,DoW+  ,MoY+  ,day+  ,month+  ,year+  ,dayOfWeek+  ,next+  ,previous+  ,yearMonthDay   ,withCalendar ) where -import Data.HodaTime.CalendarDateTime.Internal (CalendarDate, DayNth(..), DayOfMonth, Year, WeekNumber, HasDate(..), CalendarDateTime(..), IsCalendarDateTime(..), at)+import Data.HodaTime.CalendarDateTime.Internal (CalendarDate, DayNth(..), DayOfMonth, Year, WeekNumber, HasDate, DoW, MoY, day, month, year, dayOfWeek, next, previous, yearMonthDay, CalendarDateTime(..), IsCalendarDateTime(..), at) import Data.HodaTime.LocalTime.Internal (midnight)  -- $setup

@@ -18,8 +18,17 @@ (   -- * Types    CalendarDateTime-  ,IsCalendar(..)-  ,HasDate(..)+  ,IsCalendar+  ,HasDate+  ,DoW+  ,MoY+  ,day+  ,month+  ,year+  ,dayOfWeek+  ,next+  ,previous+  ,yearMonthDay   -- * Constructors   ,on   ,at

@@ -21,7 +21,6 @@ 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(..))@@ -29,7 +28,6 @@  -- $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(..)) @@ -72,10 +70,12 @@   -- | 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)+  day' :: Date cal -> DayOfMonth+  setDay' :: DayOfMonth -> Date cal -> 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)+  setMonthIndex' :: Int -> Date cal -> Date cal+  year' :: Date cal -> Year+  setYear' :: Year -> Date cal -> Date cal   dayOfWeek' :: Date cal -> DayOfWeek cal   next' :: Int -> DayOfWeek cal -> Date cal -> Date cal   previous' :: Int -> DayOfWeek cal -> Date cal -> Date cal@@ -83,22 +83,15 @@ class HasDate d where   type DoW d   type MoY d-  -- | Lens for the day component of a 'HasDate'.  Please note that days are not clamped: if you add e.g. 400 days then the month and year will roll-  day :: Functor f => (DayOfMonth -> f DayOfMonth) -> d -> f d+  -- | Day-of-month component.+  day :: d -> DayOfMonth+  setDay :: DayOfMonth -> d -> d   -- | Accessor for the Month component of a 'HasDate'.   month :: d -> MoY d-  -- | Lens for interacting with the month component of a 'HasDate'.  Please note that we convert the month to an Int so meaningful math can be done on it.  Also-  --   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 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+  setMonthIndex :: Int -> d -> d+  -- | Year component.+  year :: d -> Year+  setYear :: Year -> d -> d   -- | Accessor for the Day of the week enum of a 'HasDate', for example:   --   -- >>> dayOfWeek . fromJust $ Gregorian.calendarDate 31 January 2000@@ -126,15 +119,17 @@   --   '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))+  yearMonthDay d = (year d, month d, day d)  instance (IsCalendar cal) => HasDate (Date cal) where   type DoW (Date cal) = DayOfWeek cal   type MoY (Date cal) = Month cal   day = day'+  setDay = setDay'   month = month'-  monthl = monthl'+  setMonthIndex = setMonthIndex'   year = year'+  setYear = setYear'   dayOfWeek = dayOfWeek'   next = next'   previous = previous'@@ -209,10 +204,12 @@ instance (IsCalendar cal) => HasDate (CalendarDateTime cal) where   type DoW (CalendarDateTime cal) = DayOfWeek cal   type MoY (CalendarDateTime cal) = Month cal-  day f (CalendarDateTime cd lt) = flip CalendarDateTime lt <$> day f cd+  day (CalendarDateTime cd _) = day cd+  setDay value (CalendarDateTime cd lt) = CalendarDateTime (setDay value cd) lt   month (CalendarDateTime cd _) = month cd-  monthl f (CalendarDateTime cd lt) = flip CalendarDateTime lt <$> monthl f cd-  year f (CalendarDateTime cd lt) = flip CalendarDateTime lt <$> year f cd+  setMonthIndex value (CalendarDateTime cd lt) = CalendarDateTime (setMonthIndex value cd) lt+  year (CalendarDateTime cd _) = year cd+  setYear value (CalendarDateTime cd lt) = CalendarDateTime (setYear value cd) lt   dayOfWeek (CalendarDateTime cd _) = dayOfWeek cd   next i dow (CalendarDateTime cd lt) = CalendarDateTime (next i dow cd) lt   previous i dow (CalendarDateTime cd lt) = CalendarDateTime (previous i dow cd) lt

@@ -3,9 +3,6 @@    secondsFromSeconds   ,secondsFromMinutes   ,secondsFromHours-  ,hoursFromSecs-  ,minutesFromSecs-  ,secondsFromSecs   ,clamp ) where@@ -26,37 +23,8 @@ secondsFromHours = fromIntegral . (*secondsPerHour) {-# INLINE secondsFromHours #-} --- lenses--hoursFromSecs :: (Functor f, Num b, Integral b) => (b -> a) -> (Int -> f Int) -> b -> f a-hoursFromSecs to f secs = unitFromSeconds to h r (*secondsPerHour) f-  where-    h = secs `div` secondsPerHour-    r = secs - (h*secondsPerHour)-{-# INLINE hoursFromSecs #-}--minutesFromSecs :: (Functor f, Num b, Integral b) => (b -> a) -> (Int -> f Int) -> b -> f a-minutesFromSecs to f secs = unitFromSeconds to m r (*60) f-  where-    m = secs `mod` secondsPerHour `div` 60-    r = secs - (m*60)-{-# INLINE minutesFromSecs #-}--secondsFromSecs :: (Functor f, Num b, Integral b) => (b -> a) -> (Int -> f Int) -> b -> f a-secondsFromSecs to f secs = unitFromSeconds to s r id f-  where-    s = secs `mod` 60-    r = secs - s-{-# INLINE secondsFromSecs #-}- -- utility  clamp :: Ord a => a -> a -> a -> a clamp small big = min big . max small {-# INLINE clamp #-}---- helper functions--unitFromSeconds :: (Functor f, Num b, Integral b) => (b -> a) -> b -> b -> (b -> b) -> (Int -> f Int) -> f a-unitFromSeconds to unit rest fromSecs f = to . (rest+) . fromSecs . fromIntegral <$> f (fromIntegral unit)-{-# INLINE unitFromSeconds #-}

@@ -18,11 +18,15 @@ (   -- * Types    LocalTime-  ,HasLocalTime(..)+  ,HasLocalTime   ,Hour   ,Minute   ,Second   ,Nanosecond+  ,hour+  ,minute+  ,second+  ,nanosecond   -- * Constructors   ,localTime   -- * Exceptions

@@ -15,10 +15,9 @@ ) where -import Data.HodaTime.CalendarDateTime.Internal (LocalTime(..), CalendarDateTime(..), CalendarDate, day, IsCalendar(..))-import Data.HodaTime.Internal (hoursFromSecs, minutesFromSecs, secondsFromSecs, secondsFromHours, secondsFromMinutes)+import Data.HodaTime.CalendarDateTime.Internal (LocalTime(..), CalendarDateTime(..), CalendarDate, day, setDay, IsCalendar(..))+import Data.HodaTime.Internal (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)@@ -59,54 +58,50 @@ type Nanosecond = Int  class HasLocalTime lt where-  -- | Lens for the hour component of the 'LocalTime'-  hour :: Functor f => (Hour -> f Hour) -> lt -> f lt-  -- | Lens for the minute component of the 'LocalTime'-  minute :: Functor f => (Minute -> f Minute) -> lt -> f lt-  -- | Lens for the second component of the 'LocalTime'-  second :: Functor f => (Second -> f Second) -> lt -> f lt-  -- | Lens for the nanoseconds component of the 'LocalTime'.  NOTE: no effort is made to detect nano overflow.  They will simply roll over on overflow without affecting the rest of the time.-  nanosecond :: Functor f => (Nanosecond -> f Nanosecond) -> lt -> f lt+  hour :: lt -> Hour+  setHour :: Hour -> lt -> lt+  minute :: lt -> Minute+  setMinute :: Minute -> lt -> lt+  second :: lt -> Second+  setSecond :: Second -> lt -> lt+  nanosecond :: lt -> Nanosecond+  setNanosecond :: Nanosecond -> lt -> lt  instance HasLocalTime LocalTime where-  hour f (LocalTime secs nsecs) = hoursFromSecs to f secs-    where-      to = fromSecondsClamped nsecs+  hour (LocalTime secs _) = fromIntegral (secs `div` 3600)   {-# INLINE hour #-}+  setHour value (LocalTime secs nsecs) = fromSecondsClamped nsecs (replaceHour value secs) -  minute f (LocalTime secs nsecs) = minutesFromSecs to f secs-    where-      to = fromSecondsClamped nsecs+  minute (LocalTime secs _) = fromIntegral (secs `mod` 3600 `div` 60)   {-# INLINE minute #-}+  setMinute value (LocalTime secs nsecs) = fromSecondsClamped nsecs (replaceMinute value secs) -  second f (LocalTime secs nsecs) = secondsFromSecs to f secs-    where-      to = fromSecondsClamped nsecs+  second (LocalTime secs _) = fromIntegral (secs `mod` 60)   {-# INLINE second #-}+  setSecond value (LocalTime secs nsecs) = fromSecondsClamped nsecs (replaceSecond value secs) -  nanosecond f (LocalTime secs nsecs) = LocalTime secs . fromIntegral <$> (f . fromIntegral) nsecs+  nanosecond (LocalTime _ nsecs) = fromIntegral nsecs   {-# INLINE nanosecond #-}+  setNanosecond value (LocalTime secs _) = LocalTime secs (fromIntegral value)  instance IsCalendar cal => HasLocalTime (CalendarDateTime cal) where-  hour f (CalendarDateTime cd (LocalTime secs nsecs)) = hoursFromSecs to f secs-    where-      to = fromSecondsRolled cd nsecs+  hour (CalendarDateTime _ lt) = hour lt   {-# INLINE hour #-}+  setHour value (CalendarDateTime cd (LocalTime secs nsecs)) = fromSecondsRolled cd nsecs (replaceHour value secs) -  minute f (CalendarDateTime cd (LocalTime secs nsecs)) = minutesFromSecs to f secs-    where-      to = fromSecondsRolled cd nsecs+  minute (CalendarDateTime _ lt) = minute lt   {-# INLINE minute #-}+  setMinute value (CalendarDateTime cd (LocalTime secs nsecs)) = fromSecondsRolled cd nsecs (replaceMinute value secs) -  second f (CalendarDateTime cd (LocalTime secs nsecs)) = secondsFromSecs to f secs-    where-      to = fromSecondsRolled cd nsecs+  second (CalendarDateTime _ lt) = second lt   {-# INLINE second #-}+  setSecond value (CalendarDateTime cd (LocalTime secs nsecs)) = fromSecondsRolled cd nsecs (replaceSecond value secs) -  nanosecond f (CalendarDateTime cd lt) = CalendarDateTime cd <$> nanosecond f lt+  nanosecond (CalendarDateTime _ lt) = nanosecond lt   {-# INLINE nanosecond #-}+  setNanosecond value (CalendarDateTime cd lt) = CalendarDateTime cd (setNanosecond value lt) --- NOTE: AM/PM is handled in the pattern layer (see Data.HodaTime.Pattern.LocalTime), not as a lens here: the+-- NOTE: AM/PM is handled in the pattern layer (see Data.HodaTime.Pattern.LocalTime): 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. @@ -125,7 +120,16 @@ fromSecondsRolled date nsecs secs = CalendarDateTime date' $ LocalTime secs' nsecs     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+      date' = if d == 0 then date else setDay (day date + fromIntegral d) date++replaceHour :: Hour -> Word32 -> Word32+replaceHour value secs = secs - (secs `div` 3600 * 3600) + fromIntegral value * 3600++replaceMinute :: Minute -> Word32 -> Word32+replaceMinute value secs = secs - (secs `mod` 3600 `div` 60 * 60) + fromIntegral value * 60++replaceSecond :: Second -> Word32 -> Word32+replaceSecond value secs = secs - secs `mod` 60 + fromIntegral value  -- constructors 

@@ -49,13 +49,12 @@ 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 Data.HodaTime.CalendarDateTime.Internal (HasDate, Month, MoY, IsCalendar, setMonthIndex, dayOfWeek, DoW)+import qualified Data.HodaTime.CalendarDateTime.Internal as CDT (day, setDay, month, year, setYear) 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@@ -70,7 +69,7 @@ --   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"+pyear w = pat_field CDT.year CDT.setYear (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@@ -86,26 +85,26 @@ 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)+    expand v d = CDT.setYear (fullYear (CDT.year d) v) d+    fmt = f_shown_pad 2 (\d -> 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"+pmonthNum :: (HasDate d, Enum (MoY d)) => Int -> Pattern (d -> d) (d -> String) String+pmonthNum w = pat_field (fromEnum . CDT.month) setMonthIndex (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 :: (HasDate d, Enum (MoY 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+pMMMM :: forall cal d c. (d ~ c cal, MoY d ~ Month 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_field (fromEnum . CDT.month) setMonthIndex p' fmt' $ "month: " ++ show fm ++ "-" ++ show lm   where     fm = minBound :: Month cal     lm = maxBound :: Month cal@@ -117,8 +116,8 @@ --   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+pMMM :: forall cal d c. (d ~ c cal, MoY d ~ Month cal, IsCalendar cal, HasDate d, Bounded (Month cal), Show (Month cal), Enum (Month cal)) => Pattern (d -> d) (d -> String) String+pMMM = pat_field (fromEnum . CDT.month) setMonthIndex p' fmt' $ "month: " ++ abbr fm ++ "-" ++ abbr lm   where     fm = minBound :: Month cal     lm = maxBound :: Month cal@@ -127,7 +126,7 @@     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"+pday w = pat_field CDT.day CDT.setDay (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@@ -136,7 +135,7 @@ -- | 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)"+pdaySpace = pat_field CDT.day CDT.setDay (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).@@ -158,31 +157,31 @@     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 :: (HasDate d, Enum (MoY 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 :: (HasDate (c cal), MoY (c cal) ~ Month 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 :: (HasDate d, Enum (MoY 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 :: (HasDate (c cal), MoY (c cal) ~ Month 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 :: (HasDate (c cal), MoY (c cal) ~ Month 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"+pMonthName :: (HasDate d, Enum (MoY d)) => [String] -> Pattern (d -> d) (d -> String) String+pMonthName names = pat_field (fromEnum . CDT.month) setMonthIndex 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)@@ -197,11 +196,11 @@     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' :: (HasDate d, Enum (MoY 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' :: (HasDate d, Enum (MoY 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'.

@@ -11,6 +11,7 @@ -- @pf@\/@pF@, @pg@\/@pG@), each of which glues a date pattern to a time pattern. ---------------------------------------------------------------------------- {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-} module Data.HodaTime.Pattern.CalendarDateTime (   -- * Standard Patterns@@ -27,7 +28,7 @@ where  import Data.HodaTime.Pattern.Internal-import Data.HodaTime.CalendarDateTime.Internal (HasDate, Month, IsCalendar, DoW)+import Data.HodaTime.CalendarDateTime.Internal (HasDate, Month, MoY, IsCalendar, DoW) import Data.HodaTime.LocalTime.Internal (HasLocalTime) import Data.HodaTime.Pattern.LocalTime import Data.HodaTime.Pattern.CalendarDate@@ -39,23 +40,23 @@ -- 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 :: (HasLocalTime dt, HasDate dt, Enum (MoY 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 :: (HasLocalTime dt, HasDate dt, Enum (MoY 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 :: (HasLocalTime (c cal), HasDate (c cal), MoY (c cal) ~ Month 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 :: (HasLocalTime (c cal), HasDate (c cal), MoY (c cal) ~ Month 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 :: (HasLocalTime dt, HasDate dt, Enum (MoY 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 :: (HasLocalTime dt, HasDate dt, Enum (MoY dt)) => Pattern (dt -> dt) (dt -> String) String pG = pd <% char ' ' <> pT

@@ -17,8 +17,8 @@   ,pairP   ,string   ,char-  ,pat_lens-  ,pat_lens'+  ,pat_field+  ,pat_lens_field   ,digitsToInt   ,p_sixty   ,f_shown@@ -41,7 +41,7 @@ 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.Internal.Lens (set, Lens) import Data.HodaTime.Pattern.ApplyParse (DefaultForParse(..), ApplyParse(..)) import Control.Exception (Exception) import Data.Typeable (Typeable)@@ -112,26 +112,27 @@ format :: Pattern a r String -> r format (Pattern _ fmt) = formatToString fmt -pat_lens :: Lens s s a a+pat_field :: (s -> a)+              -> (a -> s -> s)               -> 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+pat_field getter setter p f err = Pattern par fmt   where-    fmt = f $ view l-    par = set l <$> p <?> err+    fmt = f getter+    par = setter <$> p <?> err -pat_lens' :: Lens s s a a-              -> Lens s' s' a' a'+pat_lens_field :: Lens s s a a+              -> (s' -> 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+pat_lens_field lens getter p f err = Pattern par fmt   where-    fmt = f $ view lf-    par = set lp <$> p <?> err+    fmt = f getter+    par = set lens <$> p <?> err  digitsToInt :: (Num n, Read n) => Char -> Char -> n digitsToInt a b = read [a, b]

@@ -43,8 +43,7 @@ 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 qualified Data.HodaTime.LocalTime.Internal as LT(hour, setHour, minute, setMinute, second, setSecond, nanosecond, setNanosecond) import Control.Applicative ((<|>)) import Formatting (Format, later, left, (%.)) import qualified Data.Text as T@@ -79,47 +78,47 @@ --   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))+twelveHour numP mkFmt = Pattern par (mkFmt (to12 . 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+    adjust n lt = LT.setHour (12 * (LT.hour lt `div` 12) + (n `mod` 12)) lt     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"+phour w = pat_field LT.hour LT.setHour (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"+hour' = pat_lens_field 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"+pminute w = pat_field LT.minute LT.setMinute (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"+minute' = pat_lens_field 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"+psecond w = pat_field LT.second LT.setSecond (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"+second' = pat_lens_field 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@@ -135,8 +134,8 @@   | 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)+    par = ((LT.setNanosecond . (* scale) . read) <$> count n digit) <?> ("fractional second: " ++ show n ++ " digits")+    fmt = left n '0' %. f_shown (\lt -> 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@@ -173,12 +172,12 @@  -- | 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+amPmSetter isPM lt = LT.setHour (h12 + if isPM then 12 else 0) lt+  where h12 = 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)+amPmFormat render = later (TLB.fromText . T.pack . render . (>= (12 :: Int)) . 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

@@ -71,7 +71,7 @@ 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.CalendarDateTime.Internal (HasDate, DoW, MoY, Month, CalendarDateTime, IsCalendar) import Data.HodaTime.LocalTime.Internal (HasLocalTime) import Data.HodaTime.ZonedDateTime (ZonedDateTime) import Data.HodaTime.OffsetDateTime (OffsetDateTime)@@ -170,7 +170,7 @@ 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 :: (HasDate d, Enum (MoY 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@@ -196,7 +196,7 @@  -- | 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 :: (MonadThrow m, HasDate d, Enum (MoY 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@@ -205,7 +205,7 @@ 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 :: (MonadThrow m, HasDate d, Enum (MoY 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).@@ -214,7 +214,7 @@  -- | 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 :: (IsCalendar cal, Enum (Month 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@@ -222,7 +222,7 @@ -- | 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 :: (MonadThrow m, IsCalendar cal, Enum (Month 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,@@ -238,7 +238,7 @@ --   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)))+  :: (MonadThrow m, IsCalendar cal, Enum (Month cal), Enum (DoW (CalendarDateTime cal)))   => (String -> m TimeZone)   -> (CalendarDateTime cal -> TimeZone -> m (ZonedDateTime cal))   -> Locale@@ -268,7 +268,7 @@ --   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)))+  :: (MonadThrow m, IsCalendar cal, Enum (Month cal), Enum (DoW (CalendarDateTime cal)))   => Locale   -> m (Pattern (OffsetDateTime cal -> OffsetDateTime cal) (OffsetDateTime cal -> String) String) localeOffsetDateTimePattern loc

@@ -29,7 +29,7 @@ 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.CalendarDateTime.Internal (IsCalendar, Month) import Data.HodaTime.Offset (Offset)  -- | Join a Gregorian-or-other 'CalendarDateTime' pattern to an 'Offset' pattern, producing an 'OffsetDateTime'@@ -42,5 +42,5 @@ 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 :: (IsCalendar cal, Enum (Month cal)) => Pattern (OffsetDateTime cal -> OffsetDateTime cal) (OffsetDateTime cal -> String) String pOffsetDateTime = offsetDateTimePattern ps pOffset

@@ -38,7 +38,7 @@ 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.CalendarDateTime.Internal (IsCalendar, Month) import Data.HodaTime.TimeZone (TimeZone) import Control.Monad.Catch (MonadThrow) import Formatting (later)@@ -62,7 +62,7 @@  -- | 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 :: (IsCalendar cal, Enum (Month 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@@ -70,7 +70,7 @@ --   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)+  :: (MonadThrow m, IsCalendar cal, Enum (Month cal))   => (String -> m TimeZone)   -> (CalendarDateTime cal -> TimeZone -> m (ZonedDateTime cal))   -> String

@@ -0,0 +1,156 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module      : Data.HodaTime.Period+-- Description : Calendar-relative amounts of time.+--+-- A 'Period' is indexed by the type it can be applied to. Unit constructors+-- constrain that target, so combining date and time units with '<>' infers a+-- target that supports both sets of fields.+--+-- For example, a mixed period can be applied to a 'CalendarDateTime', while+-- either half can also be used independently with a date or time:+--+-- @+-- applyPeriod (months 5 <> hours 2) calendarDateTime+-- applyPeriod (months 5) calendarDate+-- applyPeriod (hours 2) localTime+-- @+--+-- A reusable top-level binding needs either a target annotation or+-- @NoMonomorphismRestriction@. With the latter, GHC generalizes+-- @months 5 <> hours 2@ to a period requiring both 'HasDate' and+-- 'HasLocalTime'.+module Data.HodaTime.Period+(+   Period+  ,years+  ,months+  ,weeks+  ,days+  ,hours+  ,minutes+  ,seconds+  ,nanoseconds+  ,negatePeriod+  ,scalePeriod+  ,ApplyPeriod(..)+)+where++import Data.HodaTime.CalendarDateTime.Internal+  (CalendarDateTime(..), Date, HasDate(..), IsCalendar(..), LocalTime(..))+import Data.HodaTime.LocalTime.Internal (HasLocalTime)++-- | A calendar-relative amount applicable to @target@.+--+-- The constructor is hidden so the constraints introduced by the unit+-- constructors cannot be bypassed.+data Period target = Period+  { periodYears :: !Int+  , periodMonths :: !Int+  , periodWeeks :: !Int+  , periodDays :: !Int+  , periodHours :: !Int+  , periodMinutes :: !Int+  , periodSeconds :: !Int+  , periodNanoseconds :: !Int+  }+  deriving (Eq, Show)++type role Period nominal++instance Semigroup (Period target) where+  Period y1 mo1 w1 d1 h1 mi1 s1 ns1 <> Period y2 mo2 w2 d2 h2 mi2 s2 ns2 =+    Period (y1 + y2) (mo1 + mo2) (w1 + w2) (d1 + d2)+      (h1 + h2) (mi1 + mi2) (s1 + s2) (ns1 + ns2)++instance Monoid (Period target) where+  mempty = Period 0 0 0 0 0 0 0 0++-- | Construct a period measured in calendar years.+years, months, weeks, days :: HasDate target => Int -> Period target+years value = mempty { periodYears = value }+-- | Construct a period measured in calendar months.+months value = mempty { periodMonths = value }+-- | Construct a period measured in seven-day calendar weeks.+weeks value = mempty { periodWeeks = value }+-- | Construct a period measured in calendar days.+days value = mempty { periodDays = value }++-- | Construct a period measured in hours.+hours, minutes, seconds, nanoseconds :: HasLocalTime target => Int -> Period target+hours value = mempty { periodHours = value }+-- | Construct a period measured in minutes.+minutes value = mempty { periodMinutes = value }+-- | Construct a period measured in seconds.+seconds value = mempty { periodSeconds = value }+-- | Construct a period measured in nanoseconds.+nanoseconds value = mempty { periodNanoseconds = value }++-- | Negate every component of a period.+negatePeriod :: Period target -> Period target+negatePeriod = scalePeriod (-1)++-- | Multiply every component of a period by an integer.+scalePeriod :: Int -> Period target -> Period target+scalePeriod factor (Period y mo w d h mi s ns) =+  Period (factor * y) (factor * mo) (factor * w) (factor * d)+    (factor * h) (factor * mi) (factor * s) (factor * ns)++-- | Types to which periods can be applied.+class ApplyPeriod target where+  applyPeriod :: Period target -> target -> target++instance ApplyPeriod LocalTime where+  applyPeriod period = snd . applyTimePeriod period++instance (IsCalendar cal, Enum (Month cal)) => ApplyPeriod (Date cal) where+  applyPeriod = applyDatePeriod++instance (IsCalendar cal, Enum (Month cal)) => ApplyPeriod (CalendarDateTime cal) where+  applyPeriod period (CalendarDateTime date time) =+    CalendarDateTime (shiftDateByDays carry (applyDatePeriod period date)) time'+    where+      (carry, time') = applyTimePeriod period time++-- Noda Time applies period fields from largest to smallest. Keeping year and+-- month as separate operations preserves that behavior when either clamps an+-- end-of-month date.+applyDatePeriod :: (HasDate target, Enum (MoY target)) => Period periodTarget -> target -> target+applyDatePeriod period =+    shiftDateByDays (periodDays period)+  . shiftDateByDays (7 * periodWeeks period)+  . adjustDate (fromEnum . month) setMonthIndex (periodMonths period)+  . adjustDate year setYear (periodYears period)++shiftDateByDays :: HasDate target => Int -> target -> target+shiftDateByDays = adjustDate day setDay++adjustDate+  :: (target -> Int)+  -> (Int -> target -> target)+  -> Int+  -> target+  -> target+adjustDate getter setter amount target = setter (getter target + amount) target++applyTimePeriod :: Period target -> LocalTime -> (Int, LocalTime)+applyTimePeriod period (LocalTime currentSeconds currentNanoseconds) =+  (fromInteger carry, LocalTime (fromInteger secondsOfDay) (fromInteger nanos))+  where+    nanosPerSecond = 1000000000 :: Integer+    nanosPerDay = 86400 * nanosPerSecond+    current =+      (toInteger currentSeconds * nanosPerSecond) + toInteger currentNanoseconds+    delta =+      (((toInteger (periodHours period) * 60+        + toInteger (periodMinutes period)) * 60+        + toInteger (periodSeconds period)) * nanosPerSecond)+        + toInteger (periodNanoseconds period)+    (carry, withinDay) = (current + delta) `divMod` nanosPerDay+    (secondsOfDay, nanos) = withinDay `divMod` nanosPerSecond

@@ -48,7 +48,7 @@ import Data.HodaTime.ZonedDateTime.Internal 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 qualified Data.HodaTime.LocalTime.Internal as LT(second, setSecond) import Data.HodaTime.Offset.Internal (Offset(..), adjustInstant) import Data.HodaTime.TimeZone.Internal (TimeZone, TZIdentifier(..), zoneName, TransitionInfo(..), calDateTransitionsFor, aroundCalDateTransition) import Control.Exception (Exception)@@ -80,8 +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) 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+        cdt' = LT.setSecond (LT.second cdt + aOff - bOff) cdt  -- | Returns the mapping of this 'CalendarDateTime' within the given 'TimeZone', with "strict" rules applied such that ambiguous or skipped date times --   return the requested failure response (e.g. Nothing, Left, exception, etc.)

@@ -21,7 +21,6 @@ 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'.@@ -66,12 +65,9 @@     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+year (ZonedDateTime cdt _ _) = CDT.year cdt  -- | Accessor for the Month of a 'ZonedDateTime'. month :: IsCalendar cal => ZonedDateTime cal -> CDT.Month cal@@ -79,23 +75,23 @@  -- | Accessor for the Day of a 'ZonedDateTime'. day :: IsCalendar cal => ZonedDateTime cal -> CDT.DayOfMonth-day (ZonedDateTime cdt _ _) = view CDT.day cdt+day (ZonedDateTime cdt _ _) = CDT.day cdt  -- | Accessor for the Hour of a 'ZonedDateTime'. hour :: IsCalendar cal => ZonedDateTime cal -> LT.Hour-hour (ZonedDateTime cdt _ _) = view LT.hour cdt+hour (ZonedDateTime cdt _ _) = LT.hour cdt  -- | Accessor for the Minute of a 'ZonedDateTime'. minute :: IsCalendar cal => ZonedDateTime cal -> LT.Minute-minute (ZonedDateTime cdt _ _) = view LT.minute cdt+minute (ZonedDateTime cdt _ _) = LT.minute cdt  -- | Accessor for the Second of a 'ZonedDateTime'. second :: IsCalendar cal => ZonedDateTime cal -> LT.Second-second (ZonedDateTime cdt _ _) = view LT.second cdt+second (ZonedDateTime cdt _ _) = LT.second cdt  -- | Accessor for the Nanosecond of a 'ZonedDateTime'. nanosecond :: IsCalendar cal => ZonedDateTime cal -> LT.Nanosecond-nanosecond (ZonedDateTime cdt _ _) = view LT.nanosecond cdt+nanosecond (ZonedDateTime cdt _ _) = LT.nanosecond cdt  -- helper functions 

@@ -14,8 +14,9 @@ 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.CalendarDate (day, month, year, next, previous, dayOfWeek, DayNth(..), CalendarDate) import Data.HodaTime.Calendar.Coptic (calendarDate, fromNthDay, fromWeekDate, Coptic, Month(..), DayOfWeek(..))+import Data.HodaTime.Period (applyPeriod, days, months) import Data.HodaTime.Instant (fromSecondsSinceUnixEpoch) import Data.HodaTime.TimeZone (utc) import Data.HodaTime.ZonedDateTime (fromInstant, ZonedDateTime)@@ -25,14 +26,14 @@ copticTests = testGroup "Coptic Tests" [qcProps, unitTests]  qcProps :: TestTree-qcProps = testGroup "(checked by QuickCheck)" [roundTripProps, lensProps, nthDayProps]+qcProps = testGroup "(checked by QuickCheck)" [roundTripProps, periodProps, 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)+ymd x = (day x, succ . fromEnum $ month x, year x)  -- | Data.Time has no Coptic calendar, so we verify the construct -> decode bijection directly. roundTripProps :: TestTree@@ -43,17 +44,17 @@   where     testRoundTrip (RandomCopticDate y m d) = (ymd <$> calendarDate d m y) == Just (d, succ (fromEnum m), y) -lensProps :: TestTree-lensProps = testGroup "Lens"+periodProps :: TestTree+periodProps = testGroup "Period"   [      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 n (dayOfWeek date) date == a positive day period" $ testDirection next id+    ,QC.testProperty "previous n (dayOfWeek date) date == a negative day period" $ testDirection previous negate   ]   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+    testDirection dir adjust (Positive n) = dir n (dayOfWeek epochDay) epochDay == applyPeriod (days (adjust (n * 7))) 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.@@ -67,10 +68,10 @@   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+      | otherwise = let r = fromNthDay First dow m y in (dayOfWeek <$> r) == Just dow && maybe False (\d -> day d >= 1 && 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+      | otherwise = let r = fromNthDay Last dow m y in (dayOfWeek <$> r) == Just dow && maybe False (\d -> day d >= 24) r     testWeekDoW dow (RandomCopticDate y _ _) = maybe True ((== dow) . dayOfWeek) (fromWeekDate 1 dow y)  structureUnits :: TestTree@@ -81,8 +82,8 @@     ,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)+    ,testCase "1 Thout + 1 month == 1 Paopi" $ (ymd . applyPeriod (months 1) <$> calendarDate 1 Thout 1716) @?= Just (1, 2, 1716)+    ,testCase "1 Mesori + 1 month == 1 PiKogiEnavot (12th -> 13th month)" $ (ymd . applyPeriod (months 1) <$> 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.

@@ -12,23 +12,24 @@ import Data.Time.Calendar (fromGregorianValid, toGregorian)  import HodaTime.Util-import Data.HodaTime.CalendarDate (day, monthl, month, year, next, previous, dayOfWeek, DayNth(..), HasDate, MoY)+import Data.HodaTime.CalendarDate (day, 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+import Data.HodaTime.Period (applyPeriod, days, months, years)  gregorianTests :: TestTree gregorianTests = testGroup "Gregorian Tests" [qcProps, unitTests]  qcProps :: TestTree-qcProps = testGroup "(checked by QuickCheck)" [constructorProps, lensProps, nthDayProps]+qcProps = testGroup "(checked by QuickCheck)" [constructorProps, periodProps, nthDayProps]  unitTests :: TestTree-unitTests = testGroup "Unit tests" [constructorUnits, lensUnits, boundaryUnits]+unitTests = testGroup "Unit tests" [constructorUnits, periodUnits, 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)+ymd x = (day x, succ . fromEnum $ month x, 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)@@ -39,19 +40,19 @@   -- 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)+    ,testCase "31 Dec 2099 + 1 day == 1 Jan 2100" $ (ymd . applyPeriod (days 1) <$> calendarDate 31 December 2099) @?= Just (1, 1, 2100)+    ,testCase "1 Jan 2100 - 1 day == 31 Dec 2099" $ (ymd . applyPeriod (days (-1)) <$> calendarDate 1 January 2100) @?= Just (31, 12, 2099)+    ,testCase "28 Feb 2100 + 1 day == 1 Mar 2100" $ (ymd . applyPeriod (days 1) <$> 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)+    ,testCase "28 Feb 2400 + 1 day == 29 Feb 2400" $ (ymd . applyPeriod (days 1) <$> calendarDate 28 February 2400) @?= Just (29, 2, 2400)+    ,testCase "29 Feb 2400 + 1 day == 1 Mar 2400" $ (ymd . applyPeriod (days 1) <$> calendarDate 29 February 2400) @?= Just (1, 3, 2400)+    ,testCase "31 Dec 2399 + 1 day == 1 Jan 2400" $ (ymd . applyPeriod (days 1) <$> calendarDate 31 December 2399) @?= Just (1, 1, 2400)+    ,testCase "29 Feb 2400 + 1 year clamps to 28 Feb 2401" $ (ymd . applyPeriod (years 1) <$> 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)+    ,testCase "16 Oct 1582 - 1 day == 15 Oct 1582" $ (ymd . applyPeriod (days (-1)) <$> calendarDate 16 October 1582) @?= Just (15, 10, 1582)   ]  constructorProps :: TestTree@@ -64,30 +65,30 @@       areSame (Just hdate) (Just date) =         let           (ty, tm, tday) = toGregorian date-        in get day hdate == tday && (convertMonth . month $ hdate) == tm && get year hdate == (fromIntegral ty)+        in day hdate == tday && (convertMonth . month $ hdate) == tm && year hdate == (fromIntegral ty)       areSame _ _ = False       convertMonth = succ . fromEnum       testConstructor (Positive y) m (Positive d) = areSame (calendarDate d m y') (fromGregorianValid (fromIntegral y') (convertMonth m) d)         where           y' = 1900 + y -lensProps :: TestTree-lensProps = testGroup "Lens"+periodProps :: TestTree+periodProps = testGroup "Period"   [      QC.testProperty "first day not changed by month math" $ testMonthAdd 1     ,QC.testProperty "mid day not changed by month math" $ testMonthAdd 15     ,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 (-)+    ,QC.testProperty "next n (dayOfWeek date) date == a positive day period" $ testDirection next id+    ,QC.testProperty "previous n (dayOfWeek date) date == a negative day period" $ testDirection previous negate+    ,QC.testProperty "next 1 dow date < date + 8 days" $ testDirectionRange next (<) id+    ,QC.testProperty "previous 1 dow date > date - 8 days" $ testDirectionRange previous (>) negate   ]   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+    testMonthAdd d (CycleYear y) m add = day (applyPeriod (months add) $ mkcd d m (y + 1900)) == d     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+    testDirection dir adjust (Positive n) = dir n (dayOfWeek epochDay) epochDay == applyPeriod (days (adjust (n * 7))) epochDay+    testDirectionRange dir gtlt adjust dow (RandomStandardDate y m d) = let cd = mkcd d m y in dir 1 dow cd `gtlt` applyPeriod (days (adjust 8)) cd     epochDay = mkcd 1 March 2000  nthDayProps :: TestTree@@ -100,10 +101,10 @@   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+      in (dayOfWeek <$> r) == Just dow && maybe False (\d -> day d >= 1 && 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+      in (dayOfWeek <$> r) == Just dow && maybe False (\d -> day d >= 22) r     testWeekDoW dow (RandomStandardDate y _ _) (Positive w) =       maybe True ((== dow) . dayOfWeek) (G.fromWeekDate (1 + w `mod` 50) dow y) @@ -151,19 +152,19 @@           ,calendarDate 29 February             -- Not a holiday but will sometimes be absent         ] -lensUnits :: TestTree-lensUnits = testGroup "Lens"+periodUnits :: TestTree+periodUnits = testGroup "Period"   [-     testCase "31-January-2000 + 2M == 31-March-2000" $ modify (+2) monthl <$> janEnd @?= calendarDate 31 March 2000-    ,testCase "31-January-2000 + 1M == 29-February-2000" $ modify (+1) monthl <$> janEnd @?= calendarDate 29 February 2000-    ,testCase "15-November-1582 - 1M == 15-October-1582" $ modify (subtract 1) monthl <$> calendarDate 15 November 1582 @?= firstValidDate-    ,testCase "14-November-1582 - 1M == 15-October-1582 (clamped)" $ modify (subtract 1) monthl <$> calendarDate 14 November 1582 @?= firstValidDate-    ,testCase "29-February-2000 + 1Y == 28-February-2001" $ modify (+1) year <$> leapFeb @?= calendarDate 28 February 2001-    ,testCase "15-October-1583 - 1Y == 15-October-1582" $ modify (subtract 1) year <$> calendarDate 15 October 1583 @?= firstValidDate-    ,testCase "14-October-1583 - 1Y == 15-October-1582 (clamped)" $ modify (subtract 1) year <$> calendarDate 14 October 1583 @?= firstValidDate-    ,testCase "31-December-2000 + 1D == 1-January-2001" $ modify (+1) day <$> endYear @?= calendarDate 1 January 2001-    ,testCase "16-October-1583 - 1D == 15-October-1582" $ modify (subtract 1) day <$> calendarDate 16 October 1582 @?= firstValidDate-    ,testCase "15-October-1583 - 1D == 15-October-1582 (clamped)" $ modify (subtract 1) day <$> calendarDate 15 October 1582 @?= firstValidDate+     testCase "31-January-2000 + 2M == 31-March-2000" $ applyPeriod (months 2) <$> janEnd @?= calendarDate 31 March 2000+    ,testCase "31-January-2000 + 1M == 29-February-2000" $ applyPeriod (months 1) <$> janEnd @?= calendarDate 29 February 2000+    ,testCase "15-November-1582 - 1M == 15-October-1582" $ applyPeriod (months (-1)) <$> calendarDate 15 November 1582 @?= firstValidDate+    ,testCase "14-November-1582 - 1M == 15-October-1582 (clamped)" $ applyPeriod (months (-1)) <$> calendarDate 14 November 1582 @?= firstValidDate+    ,testCase "29-February-2000 + 1Y == 28-February-2001" $ applyPeriod (years 1) <$> leapFeb @?= calendarDate 28 February 2001+    ,testCase "15-October-1583 - 1Y == 15-October-1582" $ applyPeriod (years (-1)) <$> calendarDate 15 October 1583 @?= firstValidDate+    ,testCase "14-October-1583 - 1Y == 15-October-1582 (clamped)" $ applyPeriod (years (-1)) <$> calendarDate 14 October 1583 @?= firstValidDate+    ,testCase "31-December-2000 + 1D == 1-January-2001" $ applyPeriod (days 1) <$> endYear @?= calendarDate 1 January 2001+    ,testCase "16-October-1583 - 1D == 15-October-1582" $ applyPeriod (days (-1)) <$> calendarDate 16 October 1582 @?= firstValidDate+    ,testCase "15-October-1583 - 1D == 15-October-1582 (clamped)" $ applyPeriod (days (-1)) <$> calendarDate 15 October 1582 @?= firstValidDate   ]     where       janEnd = calendarDate 31 January 2000

@@ -13,25 +13,26 @@ 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.CalendarDate (day, 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+import Data.HodaTime.Period (applyPeriod, days, months, years)  hebrewTests :: TestTree hebrewTests = testGroup "Hebrew Tests" [qcProps, unitTests]  qcProps :: TestTree-qcProps = testGroup "(checked by QuickCheck)" [roundTripProps, lensProps, nthDayProps]+qcProps = testGroup "(checked by QuickCheck)" [roundTripProps, periodProps, 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)+ymd x = (day x, succ . fromEnum $ month x, 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).@@ -43,17 +44,17 @@   where     testRoundTrip (RandomHebrewDate y m d) = (ymd <$> calendarDate d m y) == Just (d, succ (fromEnum m), y) -lensProps :: TestTree-lensProps = testGroup "Lens"+periodProps :: TestTree+periodProps = testGroup "Period"   [      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 n (dayOfWeek date) date == a positive day period" $ testDirection next id+    ,QC.testProperty "previous n (dayOfWeek date) date == a negative day period" $ testDirection previous negate   ]   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+    testDirection dir adjust (Positive n) = dir n (dayOfWeek anchorDay) anchorDay == applyPeriod (days (adjust (n * 7))) 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.@@ -65,8 +66,8 @@     ,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+    testFirst dow (RandomHebrewDate y m _) = let r = fromNthDay First dow m y in (dayOfWeek <$> r) == Just dow && maybe False (\d -> day d >= 1 && day d <= 7) r+    testLast dow (RandomHebrewDate y m _) = let r = fromNthDay Last dow m y in (dayOfWeek <$> r) == Just dow && maybe False (\d -> 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@@ -84,11 +85,11 @@     ,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 "1 Shevat 5784 + 1 month == 1 AdarI (leap year keeps AdarI)"   $ (ymd . applyPeriod (months 1) <$> calendarDate 1 Shevat 5784) @?= Just (1, 6, 5784)+    ,testCase "1 Shevat 5784 + 2 months == 1 Adar (leap year)"               $ (ymd . applyPeriod (months 2) <$> calendarDate 1 Shevat 5784) @?= Just (1, 7, 5784)+    ,testCase "1 Shevat 5786 + 1 month == 1 Adar (common year skips AdarI)"  $ (ymd . applyPeriod (months 1) <$> calendarDate 1 Shevat 5786) @?= Just (1, 7, 5786)+    ,testCase "1 Elul 5785 + 1 month == 1 Tishri 5786 (year rolls at Tishri)"$ (ymd . applyPeriod (months 1) <$> calendarDate 1 Elul 5785) @?= Just (1, 1, 5786)+    ,testCase "30 AdarI 5784 + 1 year == 29 Adar 5785 (AdarI -> Adar, common)"$ (ymd . applyPeriod (years 1) <$> calendarDate 30 AdarI 5784) @?= Just (29, 7, 5785)     ,testCase "year 0 is out of range"                                       $ calendarDate 1 Tishri 0 @?= Nothing   ] @@ -109,7 +110,7 @@   ]   where     scripturalNisan = calendarDate' 15 Nisan 5784 :: Maybe (CalendarDate HebrewScriptural)-    dayYear x = (get day x, get year x)+    dayYear x = (day x, 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.

@@ -13,8 +13,9 @@ 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.CalendarDate (day, 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.Period (applyPeriod, days, months) import Data.HodaTime.Instant (fromSecondsSinceUnixEpoch) import Data.HodaTime.TimeZone (utc) import Data.HodaTime.ZonedDateTime (fromInstant, ZonedDateTime)@@ -24,14 +25,14 @@ islamicTests = testGroup "Islamic Tests" [qcProps, unitTests]  qcProps :: TestTree-qcProps = testGroup "(checked by QuickCheck)" [roundTripProps, lensProps, nthDayProps]+qcProps = testGroup "(checked by QuickCheck)" [roundTripProps, periodProps, 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)+ymd x = (day x, succ . fromEnum $ month x, year x)  -- | Data.Time has no Islamic calendar, so we verify the construct -> decode bijection directly. roundTripProps :: TestTree@@ -42,17 +43,17 @@   where     testRoundTrip (RandomIslamicDate y m d) = (ymd <$> calendarDate d m y) == Just (d, succ (fromEnum m), y) -lensProps :: TestTree-lensProps = testGroup "Lens"+periodProps :: TestTree+periodProps = testGroup "Period"   [      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 n (dayOfWeek date) date == a positive day period" $ testDirection next id+    ,QC.testProperty "previous n (dayOfWeek date) date == a negative day period" $ testDirection previous negate   ]   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+    testDirection dir adjust (Positive n) = dir n (dayOfWeek epochDay) epochDay == applyPeriod (days (adjust (n * 7))) 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.@@ -64,8 +65,8 @@     ,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+    testFirst dow (RandomIslamicDate y m _) = let r = fromNthDay First dow m y in (dayOfWeek <$> r) == Just dow && maybe False (\d -> day d >= 1 && day d <= 7) r+    testLast dow (RandomIslamicDate y m _) = let r = fromNthDay Last dow m y in (dayOfWeek <$> r) == Just dow && maybe False (\d -> day d >= 22) r     testWeekDoW dow (RandomIslamicDate y _ _) = maybe True ((== dow) . dayOfWeek) (fromWeekDate 1 dow y)  structureUnits :: TestTree@@ -78,8 +79,8 @@     ,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 "1 Muharram + 1 month == 1 Safar" $ (ymd . applyPeriod (months 1) <$> calendarDate 1 Muharram 1443) @?= Just (1, 2, 1443)+    ,testCase "1 DhulQadah + 1 month == 1 DhulHijjah (11th -> 12th month)" $ (ymd . applyPeriod (months 1) <$> calendarDate 1 DhulQadah 1443) @?= Just (1, 12, 1443)     ,testCase "year 0 is out of range" $ calendarDate 1 Muharram 0 @?= Nothing   ] 

@@ -11,21 +11,22 @@ 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.CalendarDate (day, month, year, next, previous, dayOfWeek, DayNth(..), CalendarDate) import Data.HodaTime.Calendar.Julian (calendarDate, fromNthDay, fromWeekDate, Julian, Month(..), DayOfWeek(..))+import Data.HodaTime.Period (applyPeriod, days, months, years)  julianTests :: TestTree julianTests = testGroup "Julian Tests" [qcProps, unitTests]  qcProps :: TestTree-qcProps = testGroup "(checked by QuickCheck)" [constructorProps, lensProps, nthDayProps]+qcProps = testGroup "(checked by QuickCheck)" [constructorProps, periodProps, nthDayProps]  unitTests :: TestTree-unitTests = testGroup "Unit tests" [constructorUnits, lensUnits]+unitTests = testGroup "Unit tests" [constructorUnits, periodUnits]  -- | 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)+ymd x = (day x, succ . fromEnum $ month x, 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@@ -40,25 +41,25 @@       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+        in day hdate == tday && (convertMonth . month $ hdate) == tm && 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"+periodProps :: TestTree+periodProps = testGroup "Period"   [      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 n (dayOfWeek date) date == applyPeriod (weeks n) date" $ testDirection next id+    ,QC.testProperty "previous n (dayOfWeek date) date == applyPeriod (weeks (-n)) date" $ testDirection previous negate     ,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+    testDirection dir adjust (Positive n) = dir n (dayOfWeek epochDay) epochDay == applyPeriod (days (adjust (n * 7))) 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@@ -73,10 +74,10 @@   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+      in (dayOfWeek <$> r) == Just dow && maybe False (\d -> day d >= 1 && 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+      in (dayOfWeek <$> r) == Just dow && maybe False (\d -> day d >= 22) r     testWeekDoW dow (RandomJulianDate y _ _) =       maybe True ((== dow) . dayOfWeek) (fromWeekDate 1 dow y) @@ -100,10 +101,10 @@     where       juYmd d = let (ty, tm, td) = toJulian d in (td, tm, fromIntegral ty) -lensUnits :: TestTree-lensUnits = testGroup "Lens"+periodUnits :: TestTree+periodUnits = testGroup "Period"   [-     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)+     testCase "31 January 2000 + 1M == 29 February 2000 (2000 is a Julian leap year)" $ (ymd . applyPeriod (months 1) <$> calendarDate 31 January 2000) @?= Just (29, 2, 2000)+    ,testCase "31 December 2000 + 1D == 1 January 2001" $ (ymd . applyPeriod (days 1) <$> calendarDate 31 December 2000) @?= Just (1, 1, 2001)+    ,testCase "29 February 1900 + 1Y clamps to 28 February 1901" $ (ymd . applyPeriod (years 1) <$> calendarDate 29 February 1900) @?= Just (28, 2, 1901)   ]

@@ -13,8 +13,9 @@ 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.CalendarDate (day, month, year, next, previous, dayOfWeek, DayNth(..), CalendarDate) import Data.HodaTime.Calendar.Persian (calendarDate, fromNthDay, fromWeekDate, Persian, Month(..), DayOfWeek(..))+import Data.HodaTime.Period (applyPeriod, days, months) import Data.HodaTime.Instant (fromSecondsSinceUnixEpoch) import Data.HodaTime.TimeZone (utc) import Data.HodaTime.ZonedDateTime (fromInstant, ZonedDateTime)@@ -24,14 +25,14 @@ persianTests = testGroup "Persian Tests" [qcProps, unitTests]  qcProps :: TestTree-qcProps = testGroup "(checked by QuickCheck)" [roundTripProps, lensProps, nthDayProps]+qcProps = testGroup "(checked by QuickCheck)" [roundTripProps, periodProps, 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)+ymd x = (day x, succ . fromEnum $ month x, year x)  -- | Data.Time has no Persian calendar, so we verify the construct -> decode bijection directly. roundTripProps :: TestTree@@ -42,17 +43,17 @@   where     testRoundTrip (RandomPersianDate y m d) = (ymd <$> calendarDate d m y) == Just (d, succ (fromEnum m), y) -lensProps :: TestTree-lensProps = testGroup "Lens"+periodProps :: TestTree+periodProps = testGroup "Period"   [      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 n (dayOfWeek date) date == a positive day period" $ testDirection next id+    ,QC.testProperty "previous n (dayOfWeek date) date == a negative day period" $ testDirection previous negate   ]   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+    testDirection dir adjust (Positive n) = dir n (dayOfWeek epochDay) epochDay == applyPeriod (days (adjust (n * 7))) 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.@@ -64,8 +65,8 @@     ,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+    testFirst dow (RandomPersianDate y m _) = let r = fromNthDay First dow m y in (dayOfWeek <$> r) == Just dow && maybe False (\d -> day d >= 1 && day d <= 7) r+    testLast dow (RandomPersianDate y m _) = let r = fromNthDay Last dow m y in (dayOfWeek <$> r) == Just dow && maybe False (\d -> day d >= 22) r     testWeekDoW dow (RandomPersianDate y _ _) = maybe True ((== dow) . dayOfWeek) (fromWeekDate 1 dow y)  structureUnits :: TestTree@@ -79,8 +80,8 @@     ,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 "1 Farvardin + 1 month == 1 Ordibehesht" $ (ymd . applyPeriod (months 1) <$> calendarDate 1 Farvardin 1400) @?= Just (1, 2, 1400)+    ,testCase "1 Bahman + 1 month == 1 Esfand (11th -> 12th month)" $ (ymd . applyPeriod (months 1) <$> 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   ]

@@ -9,69 +9,57 @@ import Test.Tasty.HUnit import Data.Maybe (fromJust) -import HodaTime.Util-import Data.HodaTime.LocalTime (localTime, HasLocalTime(..))-import Data.HodaTime.CalendarDate (day, monthl, next, previous, dayOfWeek)+import HodaTime.Util (RandomTime(..), CycleYear(..))+import Data.HodaTime.LocalTime (localTime, hour, minute, second)+import Data.HodaTime.CalendarDate (day, next, previous, dayOfWeek) import Data.HodaTime.Calendar.Gregorian (calendarDate, Month(..)) import Data.HodaTime.CalendarDateTime (on)+import Data.HodaTime.Period (applyPeriod, days, months, hours, minutes, seconds)  calendarDateTimeTests :: TestTree calendarDateTimeTests = testGroup "CalendarDateTimeTests Tests" [qcProps, unitTests]  qcProps :: TestTree-qcProps = testGroup "(checked by QuickCheck)" [timeLensProps, dateLensProps]+qcProps = testGroup "(checked by QuickCheck)" [timeAccessorProps, datePeriodProps]  unitTests :: TestTree unitTests = testGroup "Unit tests" [rolloverUnits] -timeLensProps :: TestTree-timeLensProps = testGroup "Time Lens"+timeAccessorProps :: TestTree+timeAccessorProps = testGroup "Time accessors"   [-     QC.testProperty "get seconds offset" $ testGet second _1-    ,QC.testProperty "get minutes offset" $ testGet minute _2-    ,QC.testProperty "get hours offset" $ testGet hour _3-    ,QC.testProperty "modify seconds offset" $ testF (modify . (+)) second _1 (+) 5-    ,QC.testProperty "modify minutes offset" $ testF (modify . (+)) minute _2 (+) 5-    ,QC.testProperty "modify hours offset" $ testF (modify . (+)) hour _3 (+) 5-    ,QC.testProperty "set seconds offset" $ testF set second _1 const 5-    ,QC.testProperty "set minutes offset" $ testF set minute _2 const 5-    ,QC.testProperty "set hours offset" $ testF set hour _3 const 5+     QC.testProperty "reads constructed components" $ \(RandomTime h m s) ->+       let value = mkTime h m s in (hour value, minute value, second value) == (h, m, s)   ]   where-    mkTime h m s = fromJust $ on <$> localTime h m s 0 <*> calendarDate 1 April 2001   -- We are already controlling that only valid values will be passed in-    offsetEq (s, m, h) off = get second off == s && get minute off == m && get hour 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' (RandomTime h m s) = get l (mkTime h m s) == get l' (s, m, h)-    testF f l l' g n (RandomTime h m s) = h < 23 - n && s < 60 - n && m < 60 - n QC.==> offsetEq (modify (g n) l' (s,m,h)) $ f n l (mkTime h m s)+    mkTime h m s = fromJust $ on <$> localTime h m s 0 <*> calendarDate 1 April 2001 -dateLensProps :: TestTree-dateLensProps = testGroup "Date Lens"+datePeriodProps :: TestTree+datePeriodProps = testGroup "Date periods"   [      QC.testProperty "first day not changed by month math" $ testMonthAdd 1     ,QC.testProperty "mid day not changed by month math" $ testMonthAdd 15     ,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 n (dayOfWeek date) date == a positive day period" $ testDirection next id+    ,QC.testProperty "previous n (dayOfWeek date) date == a negative day period" $ testDirection previous negate   ]     where       mkcd d m y = fromJust $ on <$> localTime 10 10 10 0 <*> calendarDate d m y-      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+      testMonthAdd d (CycleYear y) m add = day (applyPeriod (months add) $ mkcd d m (y + 1900)) == d       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+      testDirection dir adjust (Positive n) = dir n (dayOfWeek epochDay) epochDay == applyPeriod (days (adjust (n * 7))) epochDay       epochDay = mkcd 1 March 2000  rolloverUnits :: TestTree rolloverUnits = testGroup "Rollover"   [-     testCase "30.Jan.2000 22:57:57 + 2s == 30.Jan.2000 22:57:59" $ modify (+2) second <$> dt @?= mkLT 22 57 59 0-    ,testCase "30.Jan.2000 22:57:57 + 5s == 30.Jan.2000 22:58:02" $ modify (+5) second <$> dt @?= mkLT 22 58 2 0-    ,testCase "30.Jan.2000 22:57:57 + 5m == 30.Jan.2000 23:02:57" $ modify (+5) minute <$> dt @?= mkLT 23 02 57 0-    ,testCase "30.Jan.2000 22:57:57 + 3h == 31.Jan.2000 01:57:57" $ modify (+3) hour <$> dt @?= mkLTWithRolledDate 1 57 57 0-    ,testCase "30.Jan.2000 22:57:57 + 3723s == 31.Jan.2000 00:00:00" $ modify (+3723) second <$> dt @?= mkLTWithRolledDate 0 0 0 0-    ,testCase "30.Jan.2000 22:57:57 + 3725s == 31.Jan.2000 00:00:02" $ modify (+3725) second <$> dt @?= mkLTWithRolledDate 0 0 2 0-    ,testCase "30.Jan.2000 22:57:57 + 48h == 1.Feb.2000 22:57:57" $ modify (+48) hour <$> dt @?= mkLTWithDate monthRoll 22 57 57 0+    testCase "30.Jan.2000 22:57:57 + 2s == 30.Jan.2000 22:57:59" $ applyPeriod (seconds 2) <$> dt @?= mkLT 22 57 59 0+      ,testCase "30.Jan.2000 22:57:57 + 5s == 30.Jan.2000 22:58:02" $ applyPeriod (seconds 5) <$> dt @?= mkLT 22 58 2 0+      ,testCase "30.Jan.2000 22:57:57 + 5m == 30.Jan.2000 23:02:57" $ applyPeriod (minutes 5) <$> dt @?= mkLT 23 02 57 0+      ,testCase "30.Jan.2000 22:57:57 + 3h == 31.Jan.2000 01:57:57" $ applyPeriod (hours 3) <$> dt @?= mkLTWithRolledDate 1 57 57 0+      ,testCase "30.Jan.2000 22:57:57 + 3723s == 31.Jan.2000 00:00:00" $ applyPeriod (seconds 3723) <$> dt @?= mkLTWithRolledDate 0 0 0 0+      ,testCase "30.Jan.2000 22:57:57 + 3725s == 31.Jan.2000 00:00:02" $ applyPeriod (seconds 3725) <$> dt @?= mkLTWithRolledDate 0 0 2 0+      ,testCase "30.Jan.2000 22:57:57 + 48h == 1.Feb.2000 22:57:57" $ applyPeriod (hours 48) <$> dt @?= mkLTWithDate monthRoll 22 57 57 0   ]   where     time = localTime 22 57 57 0

@@ -14,12 +14,11 @@ 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.HodaTime.LocalTime (hour, minute, second) 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, qcProps]@@ -52,7 +51,7 @@     utcT = posixSecondsToUTCTime posT     (LocalTime _ tod) = utcToLocalTime (hoursToTimeZone 0) utcT     todT = (todHour tod, todMin tod, round . todSec $ tod)-    t = (get hour lt, get minute lt, get second lt)+    t = (hour lt, minute lt, second lt)     str = "time(" ++ show secs ++ "): "   assertEqual str todT t 

@@ -9,53 +9,41 @@ import Test.Tasty.HUnit import Data.Maybe (fromJust) -import HodaTime.Util-import Data.HodaTime.LocalTime (localTime, LocalTime, HasLocalTime(..))+import HodaTime.Util (RandomTime(..))+import Data.HodaTime.LocalTime (localTime, LocalTime, hour, minute, second)+import Data.HodaTime.Period (applyPeriod, hours, minutes, seconds)  localTimeTests :: TestTree localTimeTests = testGroup "LocalTime Tests" [qcProps, unitTests]  qcProps :: TestTree-qcProps = testGroup "(checked by QuickCheck)" [lensProps]+qcProps = testGroup "(checked by QuickCheck)" [accessorProps]  unitTests :: TestTree unitTests = testGroup "Unit tests" [rolloverUnits]  -- properties -lensProps :: TestTree-lensProps = testGroup "Lens"+accessorProps :: TestTree+accessorProps = testGroup "Accessors"   [-     QC.testProperty "get seconds offset" $ testGet second _1-    ,QC.testProperty "get minutes offset" $ testGet minute _2-    ,QC.testProperty "get hours offset" $ testGet hour _3-    ,QC.testProperty "modify seconds offset" $ testF (modify . (+)) second _1 (+) 5-    ,QC.testProperty "modify minutes offset" $ testF (modify . (+)) minute _2 (+) 5-    ,QC.testProperty "modify hours offset" $ testF (modify . (+)) hour _3 (+) 5-    ,QC.testProperty "set seconds offset" $ testF set second _1 const 5-    ,QC.testProperty "set minutes offset" $ testF set minute _2 const 5-    ,QC.testProperty "set hours offset" $ testF set hour _3 const 5+     QC.testProperty "reads constructed components" $ \(RandomTime h m s) ->+       let value = mkTime h m s in (hour value, minute value, second value) == (h, m, s)   ]   where-    mkTime h m s = fromJust . localTime h m s $ 0    -- We are already controlling that only valid values will be passed in-    offsetEq (s, m, h) off = get second off == s && get minute off == m && get hour 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' (RandomTime h m s) = get l (mkTime h m s) == get l' (s, m, h)-    testF f l l' g n (RandomTime h m s) = h < 23 - n && s < 60 - n && m < 60 - n QC.==> offsetEq (modify (g n) l' (s,m,h)) $ f n l (mkTime h m s)+    mkTime h m s = fromJust (localTime h m s 0)  rolloverUnits :: TestTree rolloverUnits = testGroup "Rollover"   [-     testCase "22:57:57 + 2s == 22:57:59" $ modify (+2) second <$> time @?= localTime 22 57 59 0-    ,testCase "22:57:57 + 5s == 22:58:02" $ modify (+5) second <$> time @?= localTime 22 58 2 0-    ,testCase "22:57:57 + 2m == 22:59:57" $ modify (+2) minute <$> time @?= localTime 22 59 57 0-    ,testCase "22:57:57 + 5m == 23:02:57" $ modify (+5) minute <$> time @?= localTime 23 02 57 0-    ,testCase "22:57:57 + 1h == 23:57:57" $ modify (+1) hour <$> time @?= localTime 23 57 57 0-    ,testCase "22:57:57 + 3h == 01:57:57" $ modify (+3) hour <$> time @?= localTime 1 57 57 0-    ,testCase "22:57:57 + 3723s == 00:00:00" $ modify (+3723) second <$> time @?= localTime 0 0 0 0-    ,testCase "22:57:57 + 3725s == 00:00:02" $ modify (+3725) second <$> time @?= localTime 0 0 2 0+    testCase "22:57:57 + 2s == 22:57:59" $ applyPeriod (seconds 2) <$> time @?= localTime 22 57 59 0+      ,testCase "22:57:57 + 5s == 22:58:02" $ applyPeriod (seconds 5) <$> time @?= localTime 22 58 2 0+      ,testCase "22:57:57 + 2m == 22:59:57" $ applyPeriod (minutes 2) <$> time @?= localTime 22 59 57 0+      ,testCase "22:57:57 + 5m == 23:02:57" $ applyPeriod (minutes 5) <$> time @?= localTime 23 02 57 0+      ,testCase "22:57:57 + 1h == 23:57:57" $ applyPeriod (hours 1) <$> time @?= localTime 23 57 57 0+      ,testCase "22:57:57 + 3h == 01:57:57" $ applyPeriod (hours 3) <$> time @?= localTime 1 57 57 0+      ,testCase "22:57:57 + 3723s == 00:00:00" $ applyPeriod (seconds 3723) <$> time @?= localTime 0 0 0 0+      ,testCase "22:57:57 + 3725s == 00:00:02" $ applyPeriod (seconds 3725) <$> time @?= localTime 0 0 2 0   ]   where     time :: Maybe LocalTime

@@ -0,0 +1,64 @@+module HodaTime.PeriodTest+(+  periodTests+)+where++import Data.Maybe (fromJust)+import Test.Tasty+import Test.Tasty.HUnit++import Data.HodaTime.Calendar.Gregorian+  (Gregorian, Month(..), calendarDate)+import Data.HodaTime.CalendarDate (CalendarDate)+import Data.HodaTime.CalendarDateTime (CalendarDateTime, on)+import qualified Data.HodaTime.Calendar.Hebrew as Hebrew+import Data.HodaTime.LocalTime (LocalTime, localTime)+import Data.HodaTime.Period++periodTests :: TestTree+periodTests = testGroup "Period"+  [ testCase "months clamp at the end of the target month" $+      applyPeriod (months 1) jan31 @?= date 29 February 2000+  , testCase "combined months are applied as one component" $+      applyPeriod (months 1 <> months 1) jan31 @?= date 31 March 2000+  , testCase "fields are applied from largest to smallest" $+      applyPeriod (years 1 <> months 1) leapDay @?= date 28 March 2001+  , testCase "time-only periods wrap LocalTime" $+      applyPeriod (hours 2) lateTime @?= time 1 30 0 0+  , testCase "negative subsecond periods wrap LocalTime" $+      applyPeriod (nanoseconds (-1)) midnightTime @?=+        time 23 59 59 999999999+  , testCase "large time periods do not overflow the representation" $+      applyPeriod (hours 100000) midnightTime @?= time 16 0 0 0+  , testCase "mixed periods carry time overflow into the date" $+      applyPeriod (months 1 <> hours 2) lateDateTime @?=+        on (time 1 30 0 0) (date 1 March 2000)+  , testCase "month periods follow the target calendar" $+      applyPeriod (months 1) hebrewShevat @?= hebrewAdarI+  , testCase "period composition has an identity" $+      (mempty <> samplePeriod, samplePeriod <> mempty) @?=+        (samplePeriod, samplePeriod)+  , testCase "period composition is associative" $+      ((years 1 <> months 2) <> days 3) @?=+        (years 1 <> (months 2 <> days 3) :: Period (CalendarDate Gregorian))+  ]+  where+    jan31 = date 31 January 2000+    leapDay = date 29 February 2000+    lateTime = time 23 30 0 0+    midnightTime = time 0 0 0 0+    lateDateTime = on lateTime jan31+    hebrewShevat = fromJust (Hebrew.calendarDate 1 Hebrew.Shevat 5784)+    hebrewAdarI = fromJust (Hebrew.calendarDate 1 Hebrew.AdarI 5784)+    samplePeriod = years 1 <> months 2 <> days 3 :: Period (CalendarDate Gregorian)++date :: Int -> Month Gregorian -> Int -> CalendarDate Gregorian+date day month year = fromJust (calendarDate day month year)++time :: Int -> Int -> Int -> Int -> LocalTime+time hour minute second nanosecond =+  fromJust (localTime hour minute second nanosecond)++_mixedPeriodType :: Period (CalendarDateTime Gregorian)+_mixedPeriodType = months 5 <> hours 2

@@ -10,17 +10,11 @@   ,RandomPersianDate(..)   ,RandomIslamicDate(..)   ,RandomHebrewDate(..)-  ,get-  ,modify-  ,set ) where  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@@ -208,14 +202,3 @@     (m, cap) <- elements months     d <- choose (1,cap)     return $ RandomHebrewDate y m d---- Lenses--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)-  -set :: s -> ((b -> Identity s) -> a -> Identity t) -> a -> t-set v = modify (const v)

@@ -10,7 +10,6 @@ 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@@ -27,7 +26,7 @@  -- | 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)+ymd x = (day x, succ . fromEnum $ month x, year x)  mkG :: Int -> G.Month G.Gregorian -> Int -> CalendarDate G.Gregorian mkG d m y = fromJust $ G.calendarDate d m y

@@ -13,6 +13,7 @@ import HodaTime.CalendarDateTimeTest import HodaTime.ZonedDateTimeTest import HodaTime.PatternTest+import HodaTime.PeriodTest import HodaTime.WithCalendarTest import HodaTime.LocaleTest import HodaTime.ClassInstanceTests@@ -21,7 +22,7 @@ main = defaultMain tests  tests :: TestTree-tests = testGroup "Tests" [instantTests, durationTests, offsetTests, localTimeTests, gregorianTests, julianTests, copticTests, persianTests, islamicTests, hebrewTests, calendarDateTimeTests, zonedDateTimeTests, patternTests, withCalendarTests, localeTests, classInstanceTests]+tests = testGroup "Tests" [instantTests, durationTests, offsetTests, localTimeTests, gregorianTests, julianTests, copticTests, persianTests, islamicTests, hebrewTests, calendarDateTimeTests, zonedDateTimeTests, patternTests, periodTests, withCalendarTests, localeTests, classInstanceTests]  {- unitTests :: TestTree