Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • Haskell-mouse/time
1 result
Show changes
Commits on Source (61)
Hide whitespace changes
Inline Side-by-side
Showing
with 175 additions and 146 deletions
.github/workflows/ci.yml
View file @ baab563e
...@@ -10,14 +10,14 @@ jobs: ...@@ -10,14 +10,14 @@ jobs:
fail-fast: false fail-fast: false
matrix: matrix:
os: [ubuntu-latest, macOS-latest] os: [ubuntu-latest, macOS-latest]
ghc: ['9.0.1', '8.10.7', '8.8.4'] ghc: ['9.2.2', '9.0.2', '8.10.7']
steps: steps:
- uses: actions/checkout@v2 - uses: actions/checkout@v3
- uses: haskell/actions/setup@v1.2.6 - uses: haskell/actions/setup@v2.0.0
id: setup-haskell-cabal id: setup-haskell-cabal
with: with:
ghc-version: ${{ matrix.ghc }} ghc-version: ${{ matrix.ghc }}
- uses: actions/cache@v2.1.6 - uses: actions/cache@v3
name: Cache cabal stuff name: Cache cabal stuff
with: with:
path: | path: |
...@@ -42,14 +42,14 @@ jobs: ...@@ -42,14 +42,14 @@ jobs:
strategy: strategy:
fail-fast: false fail-fast: false
matrix: matrix:
ghc: ['9.0.1', '8.10.7', '8.8.4'] ghc: ['9.2.2', '9.0.2', '8.10.7']
steps: steps:
- uses: actions/checkout@v2 - uses: actions/checkout@v3
- uses: haskell/actions/setup@v1.2.6 - uses: haskell/actions/setup@v2.0.0
id: setup-haskell-cabal id: setup-haskell-cabal
with: with:
ghc-version: ${{ matrix.ghc }} ghc-version: ${{ matrix.ghc }}
- uses: actions/cache@v2.1.6 - uses: actions/cache@v3
name: Cache cabal stuff name: Cache cabal stuff
with: with:
path: | path: |
...@@ -74,12 +74,12 @@ jobs: ...@@ -74,12 +74,12 @@ jobs:
build-freebsd: build-freebsd:
# See https://github.com/vmactions/freebsd-vm#under-the-hood. # See https://github.com/vmactions/freebsd-vm#under-the-hood.
runs-on: macos-latest runs-on: macos-10.15
steps: steps:
- uses: actions/checkout@v2 - uses: actions/checkout@v3
- name: Build - name: Build
id: build-freebsd id: build-freebsd
uses: vmactions/freebsd-vm@v0.1.5 uses: vmactions/freebsd-vm@v0.1.6
with: with:
usesh: true usesh: true
mem: 4096 mem: 4096
......
.gitignore
View file @ baab563e
...@@ -5,6 +5,7 @@ conf* ...@@ -5,6 +5,7 @@ conf*
a.out a.out
configure configure
dist/ dist/
dist-newstyle/
dist-install dist-install
ghc.mk ghc.mk
lib/include/HsTimeConfig.h lib/include/HsTimeConfig.h
......
Checklist
View file @ baab563e
...@@ -17,6 +17,7 @@ Before release: ...@@ -17,6 +17,7 @@ Before release:
4. Update changelog, add current UTC date 4. Update changelog, add current UTC date
date -u
changelog.md changelog.md
5. Use latest LTS resolver 5. Use latest LTS resolver
...@@ -41,7 +42,7 @@ Before release: ...@@ -41,7 +42,7 @@ Before release:
8. Format source 8. Format source
./format-all ./format-all -b
9. Build & test 9. Build & test
...@@ -53,7 +54,7 @@ Before release: ...@@ -53,7 +54,7 @@ Before release:
11. Inspect generated haddock, if necessary 11. Inspect generated haddock, if necessary
`stack path --local-doc-root`/index.html dist/doc/html/time/index.html
12. Commit and push changes to repo 12. Commit and push changes to repo
......
LICENSE
View file @ baab563e
TimeLib is Copyright (c) Ashley Yakeley and contributors, 2004-2021. All rights reserved. TimeLib is Copyright (c) Ashley Yakeley and contributors, 2004-2022. All rights reserved.
Certain sections are Copyright 2004, The University Court of the University of Glasgow. All rights reserved. Certain sections are Copyright 2004, The University Court of the University of Glasgow. All rights reserved.
Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
......
aclocal.m4
View file @ baab563e
# FP_DECL_ALTZONE # FP_DECL_ALTZONE
# --------------- # ---------------
# Defines HAVE_DECL_ALTZONE to 1 if declared, 0 otherwise. # Defines HAVE_DECL_ALTZONE to 1 if declared, 0 otherwise.
# #
# Used by base package. # Used by base package.
AC_DEFUN([FP_DECL_ALTZONE], AC_DEFUN([FP_DECL_ALTZONE],
[AC_REQUIRE([AC_HEADER_TIME])dnl [
AC_CHECK_HEADERS([sys/time.h]) AC_CHECK_HEADERS_ONCE([sys/time.h])
AC_CHECK_DECLS([altzone], [], [],[#if TIME_WITH_SYS_TIME
# include <sys/time.h> AC_CHECK_HEADERS([sys/time.h])
# include <time.h> AC_CHECK_DECLS([altzone], [], [],[
#else #if HAVE_SYS_TIME_H
# if HAVE_SYS_TIME_H #include <sys/time.h>
# include <sys/time.h> #endif
# else #include <time.h>
# include <time.h> ])
# endif ])# FP_DECL_ALTZONE
#endif])
])# FP_DECL_ALTZONE
build
View file @ baab563e
...@@ -5,3 +5,4 @@ ghcup set ghc latest ...@@ -5,3 +5,4 @@ ghcup set ghc latest
cabal v1-install --only-dependencies --enable-tests cabal v1-install --only-dependencies --enable-tests
cabal v1-configure --enable-tests cabal v1-configure --enable-tests
cabal v1-test cabal v1-test
cabal v1-haddock
cabal.project 0 → 100644
View file @ baab563e
packages: time.cabal
tests: true
changelog.md
View file @ baab563e
# Change Log # Change Log
## [1.12.2] - 2022-05-14
- add weekFirstDay, weekLastDay, weekAllDays
- expose formatting/parsing internals
- fix: handle +HH format for ISO8601 timeOffsetFormat etc.
- fix clock_REALTIME for WebAssembly
## [1.12.1] - 2021-10-24 ## [1.12.1] - 2021-10-24
- add DayPeriod class for periods of days - add DayPeriod class for periods of days
- add QuarterDay pattern and DayOfQuarter type synonym - add QuarterDay pattern and DayOfQuarter type synonym
......
configure.ac
View file @ baab563e
AC_INIT([Haskell time package],[1.12.1],[ashley@semantic.org],[time]) AC_INIT([Haskell time package],[1.12.2],[ashley@semantic.org],[time])
# Safety check: Ensure that we are in the correct source directory. # Safety check: Ensure that we are in the correct source directory.
AC_CONFIG_SRCDIR([lib/include/HsTime.h]) AC_CONFIG_SRCDIR([lib/include/HsTime.h])
......
format-all
View file @ baab563e
#!/bin/bash -e #!/bin/bash -e
stack build --no-test --no-bench --no-haddock fourmolu if [ "$1" == "-b" ]
for f in `find -name '*.hs' -not -path '*.stack-work/*' -not -path '*/dist/*' | grep -xvf .format.ignore`; do `stack path --local-install-root`/bin/fourmolu -i -o -XPatternSynonyms $f || exit; done then stack build --no-test --no-bench --no-haddock fourmolu
fi
for f in `find -name '*.hs' -not -path '*.stack-work/*' -not -path '*/dist/*' | grep -xvf .format.ignore`
do `stack path --local-install-root`/bin/fourmolu -i -o -XPatternSynonyms $f || exit
done
fourmolu.yaml
View file @ baab563e
respectful: false respectful: false
haddock-style: single-line haddock-style: single-line
consistent-let: true
fullcheck
View file @ baab563e
...@@ -4,9 +4,9 @@ git pull ...@@ -4,9 +4,9 @@ git pull
autoreconf -i autoreconf -i
PATH=$HOME/.ghcup/bin:$PATH PATH=$HOME/.ghcup/bin:$PATH
ghcup upgrade ghcup upgrade
ghcup install cabal latest ghcup install cabal latest
ghcup set cabal latest ghcup set cabal latest
for c in 8.8.4 8.10.7 9.0.1 for c in 8.10.7 9.0.2 9.2.2
do do
ghcup install ghc $c ghcup install ghc $c
ghcup set ghc $c ghcup set ghc $c
...@@ -14,5 +14,6 @@ cabal update ...@@ -14,5 +14,6 @@ cabal update
cabal v1-install --only-dependencies --enable-tests cabal v1-install --only-dependencies --enable-tests
cabal v1-configure --enable-tests cabal v1-configure --enable-tests
cabal v1-test cabal v1-test
cabal v1-haddock
done done
echo OK echo OK
fullcheck.ps1
View file @ baab563e
...@@ -11,7 +11,7 @@ if (!$?) {Exit 1} ...@@ -11,7 +11,7 @@ if (!$?) {Exit 1}
if (!$?) {Exit 1} if (!$?) {Exit 1}
& "ghcup" "set" "cabal" "latest" & "ghcup" "set" "cabal" "latest"
if (!$?) {Exit 1} if (!$?) {Exit 1}
ForEach ($c in "8.8.4","8.10.7","9.0.1") ForEach ($c in "8.10.7","9.0.2","9.2.2")
{ {
& "ghcup" "install" "ghc" "$c" & "ghcup" "install" "ghc" "$c"
if (!$?) {Exit 1} if (!$?) {Exit 1}
...@@ -25,5 +25,7 @@ ForEach ($c in "8.8.4","8.10.7","9.0.1") ...@@ -25,5 +25,7 @@ ForEach ($c in "8.8.4","8.10.7","9.0.1")
if (!$?) {Exit 1} if (!$?) {Exit 1}
& "cabal" "v1-test" & "cabal" "v1-test"
if (!$?) {Exit 1} if (!$?) {Exit 1}
& "cabal" "v1-haddock"
if (!$?) {Exit 1}
} }
Echo "OK" Write-Output "OK"
lib/Data/Format.hs
View file @ baab563e
...@@ -61,10 +61,10 @@ parseReader readp s = ...@@ -61,10 +61,10 @@ parseReader readp s =
-- | A text format for a type -- | A text format for a type
data Format t = MkFormat data Format t = MkFormat
{ -- | Show a value in the format, if representable { formatShowM :: t -> Maybe String
formatShowM :: t -> Maybe String -- ^ Show a value in the format, if representable
, -- | Read a value in the format , formatReadP :: ReadP t
formatReadP :: ReadP t -- ^ Read a value in the format
} }
-- | Show a value in the format, or error if unrepresentable -- | Show a value in the format, or error if unrepresentable
...@@ -110,7 +110,8 @@ clipFormat (lo, hi) = filterFormat (\a -> a >= lo && a <= hi) ...@@ -110,7 +110,8 @@ clipFormat (lo, hi) = filterFormat (\a -> a >= lo && a <= hi)
instance Productish Format where instance Productish Format where
pUnit = MkFormat{formatShowM = \_ -> Just "", formatReadP = return ()} pUnit = MkFormat{formatShowM = \_ -> Just "", formatReadP = return ()}
(<**>) (MkFormat sa ra) (MkFormat sb rb) = (<**>) (MkFormat sa ra) (MkFormat sb rb) =
let sab (a, b) = do let
sab (a, b) = do
astr <- sa a astr <- sa a
bstr <- sb b bstr <- sb b
return $ astr ++ bstr return $ astr ++ bstr
...@@ -118,18 +119,20 @@ instance Productish Format where ...@@ -118,18 +119,20 @@ instance Productish Format where
a <- ra a <- ra
b <- rb b <- rb
return (a, b) return (a, b)
in MkFormat sab rab in MkFormat sab rab
(MkFormat sa ra) **> (MkFormat sb rb) = (MkFormat sa ra) **> (MkFormat sb rb) =
let s b = do let
s b = do
astr <- sa () astr <- sa ()
bstr <- sb b bstr <- sb b
return $ astr ++ bstr return $ astr ++ bstr
r = do r = do
ra ra
rb rb
in MkFormat s r in MkFormat s r
(MkFormat sa ra) <** (MkFormat sb rb) = (MkFormat sa ra) <** (MkFormat sb rb) =
let s a = do let
s a = do
astr <- sa a astr <- sa a
bstr <- sb () bstr <- sb ()
return $ astr ++ bstr return $ astr ++ bstr
...@@ -137,43 +140,47 @@ instance Productish Format where ...@@ -137,43 +140,47 @@ instance Productish Format where
a <- ra a <- ra
rb rb
return a return a
in MkFormat s r in MkFormat s r
instance Summish Format where instance Summish Format where
pVoid = MkFormat absurd pfail pVoid = MkFormat absurd pfail
(MkFormat sa ra) <++> (MkFormat sb rb) = (MkFormat sa ra) <++> (MkFormat sb rb) =
let sab (Left a) = sa a let
sab (Left a) = sa a
sab (Right b) = sb b sab (Right b) = sb b
rab = (fmap Left ra) +++ (fmap Right rb) rab = (fmap Left ra) +++ (fmap Right rb)
in MkFormat sab rab in MkFormat sab rab
literalFormat :: String -> Format () literalFormat :: String -> Format ()
literalFormat s = MkFormat{formatShowM = \_ -> Just s, formatReadP = string s >> return ()} literalFormat s = MkFormat{formatShowM = \_ -> Just s, formatReadP = string s >> return ()}
specialCaseShowFormat :: Eq a => (a, String) -> Format a -> Format a specialCaseShowFormat :: Eq a => (a, String) -> Format a -> Format a
specialCaseShowFormat (val, str) (MkFormat s r) = specialCaseShowFormat (val, str) (MkFormat s r) =
let s' t let
s' t
| t == val = Just str | t == val = Just str
s' t = s t s' t = s t
in MkFormat s' r in MkFormat s' r
specialCaseFormat :: Eq a => (a, String) -> Format a -> Format a specialCaseFormat :: Eq a => (a, String) -> Format a -> Format a
specialCaseFormat (val, str) (MkFormat s r) = specialCaseFormat (val, str) (MkFormat s r) =
let s' t let
s' t
| t == val = Just str | t == val = Just str
s' t = s t s' t = s t
r' = (string str >> return val) +++ r r' = (string str >> return val) +++ r
in MkFormat s' r' in MkFormat s' r'
optionalFormat :: Eq a => a -> Format a -> Format a optionalFormat :: Eq a => a -> Format a -> Format a
optionalFormat val = specialCaseFormat (val, "") optionalFormat val = specialCaseFormat (val, "")
casesFormat :: Eq a => [(a, String)] -> Format a casesFormat :: Eq a => [(a, String)] -> Format a
casesFormat pairs = casesFormat pairs =
let s t = lookup t pairs let
s t = lookup t pairs
r [] = pfail r [] = pfail
r ((v, str) : pp) = (string str >> return v) <++ r pp r ((v, str) : pp) = (string str >> return v) <++ r pp
in MkFormat s $ r pairs in MkFormat s $ r pairs
optionalSignFormat :: (Eq t, Num t) => Format t optionalSignFormat :: (Eq t, Num t) => Format t
optionalSignFormat = casesFormat [(1, ""), (1, "+"), (0, ""), (-1, "-")] optionalSignFormat = casesFormat [(1, ""), (1, "+"), (0, ""), (-1, "-")]
...@@ -221,10 +228,12 @@ trimTrailing s = s ...@@ -221,10 +228,12 @@ trimTrailing s = s
showNumber :: Show t => SignOption -> Maybe Int -> t -> Maybe String showNumber :: Show t => SignOption -> Maybe Int -> t -> Maybe String
showNumber signOpt mdigitcount t = showNumber signOpt mdigitcount t =
let showIt str = let
let (intPart, decPart) = break ((==) '.') str showIt str =
in (zeroPad mdigitcount intPart) ++ trimTrailing decPart let
in case show t of (intPart, decPart) = break ((==) '.') str
in (zeroPad mdigitcount intPart) ++ trimTrailing decPart
in case show t of
('-' : str) -> ('-' : str) ->
case signOpt of case signOpt of
NoSign -> Nothing NoSign -> Nothing
......
lib/Data/Time/Calendar/Days.hs
View file @ baab563e
...@@ -82,10 +82,10 @@ periodLength p = succ $ fromInteger $ diffDays (periodLastDay p) (periodFirstDay ...@@ -82,10 +82,10 @@ periodLength p = succ $ fromInteger $ diffDays (periodLastDay p) (periodFirstDay
-- --
-- @since 1.12.1 -- @since 1.12.1
periodFromDay :: DayPeriod p => Day -> (p, Int) periodFromDay :: DayPeriod p => Day -> (p, Int)
periodFromDay d = periodFromDay d = let
let p = dayPeriod d p = dayPeriod d
dt = succ $ fromInteger $ diffDays d $ periodFirstDay p dt = succ $ fromInteger $ diffDays d $ periodFirstDay p
in (p, dt) in (p, dt)
-- | Inverse of 'periodFromDay'. -- | Inverse of 'periodFromDay'.
-- --
...@@ -97,9 +97,9 @@ periodToDay p i = addDays (toInteger $ pred i) $ periodFirstDay p ...@@ -97,9 +97,9 @@ periodToDay p i = addDays (toInteger $ pred i) $ periodFirstDay p
-- --
-- @since 1.12.1 -- @since 1.12.1
periodToDayValid :: DayPeriod p => p -> Int -> Maybe Day periodToDayValid :: DayPeriod p => p -> Int -> Maybe Day
periodToDayValid p i = periodToDayValid p i = let
let d = periodToDay p i d = periodToDay p i
in if fst (periodFromDay d) == p then Just d else Nothing in if fst (periodFromDay d) == p then Just d else Nothing
instance DayPeriod Day where instance DayPeriod Day where
periodFirstDay = id periodFirstDay = id
......
lib/Data/Time/Calendar/Easter.hs
View file @ baab563e
...@@ -18,7 +18,7 @@ sundayAfter day = addDays (7 - (mod (toModifiedJulianDay day + 3) 7)) day ...@@ -18,7 +18,7 @@ sundayAfter day = addDays (7 - (mod (toModifiedJulianDay day + 3) 7)) day
-- | Given a year, find the Paschal full moon according to Orthodox Christian tradition -- | Given a year, find the Paschal full moon according to Orthodox Christian tradition
orthodoxPaschalMoon :: Year -> Day orthodoxPaschalMoon :: Year -> Day
orthodoxPaschalMoon year = addDays (- shiftedEpact) (fromJulian jyear 4 19) orthodoxPaschalMoon year = addDays (-shiftedEpact) (fromJulian jyear 4 19)
where where
shiftedEpact = mod (14 + 11 * (mod year 19)) 30 shiftedEpact = mod (14 + 11 * (mod year 19)) 30
jyear = jyear =
...@@ -32,7 +32,7 @@ orthodoxEaster = sundayAfter . orthodoxPaschalMoon ...@@ -32,7 +32,7 @@ orthodoxEaster = sundayAfter . orthodoxPaschalMoon
-- | Given a year, find the Paschal full moon according to the Gregorian method -- | Given a year, find the Paschal full moon according to the Gregorian method
gregorianPaschalMoon :: Year -> Day gregorianPaschalMoon :: Year -> Day
gregorianPaschalMoon year = addDays (- adjustedEpact) (fromGregorian year 4 19) gregorianPaschalMoon year = addDays (-adjustedEpact) (fromGregorian year 4 19)
where where
century = (div year 100) + 1 century = (div year 100) + 1
shiftedEpact = mod (14 + 11 * (mod year 19) - (div (3 * century) 4) + (div (5 + 8 * century) 25)) 30 shiftedEpact = mod (14 + 11 * (mod year 19) - (div (3 * century) 4) + (div (5 + 8 * century) 25)) 30
......
lib/Data/Time/Calendar/Gregorian.hs
View file @ baab563e
...@@ -133,46 +133,46 @@ addGregorianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addGregori ...@@ -133,46 +133,46 @@ addGregorianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addGregori
-- | Calendrical difference, with as many whole months as possible -- | Calendrical difference, with as many whole months as possible
diffGregorianDurationClip :: Day -> Day -> CalendarDiffDays diffGregorianDurationClip :: Day -> Day -> CalendarDiffDays
diffGregorianDurationClip day2 day1 = diffGregorianDurationClip day2 day1 = let
let (y1, m1, d1) = toGregorian day1 (y1, m1, d1) = toGregorian day1
(y2, m2, d2) = toGregorian day2 (y2, m2, d2) = toGregorian day2
ym1 = y1 * 12 + toInteger m1 ym1 = y1 * 12 + toInteger m1
ym2 = y2 * 12 + toInteger m2 ym2 = y2 * 12 + toInteger m2
ymdiff = ym2 - ym1 ymdiff = ym2 - ym1
ymAllowed = ymAllowed =
if day2 >= day1 if day2 >= day1
then then
if d2 >= d1 if d2 >= d1
then ymdiff then ymdiff
else ymdiff - 1 else ymdiff - 1
else else
if d2 <= d1 if d2 <= d1
then ymdiff then ymdiff
else ymdiff + 1 else ymdiff + 1
dayAllowed = addGregorianDurationClip (CalendarDiffDays ymAllowed 0) day1 dayAllowed = addGregorianDurationClip (CalendarDiffDays ymAllowed 0) day1
in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed
-- | Calendrical difference, with as many whole months as possible. -- | Calendrical difference, with as many whole months as possible.
-- Same as 'diffGregorianDurationClip' for positive durations. -- Same as 'diffGregorianDurationClip' for positive durations.
diffGregorianDurationRollOver :: Day -> Day -> CalendarDiffDays diffGregorianDurationRollOver :: Day -> Day -> CalendarDiffDays
diffGregorianDurationRollOver day2 day1 = diffGregorianDurationRollOver day2 day1 = let
let (y1, m1, d1) = toGregorian day1 (y1, m1, d1) = toGregorian day1
(y2, m2, d2) = toGregorian day2 (y2, m2, d2) = toGregorian day2
ym1 = y1 * 12 + toInteger m1 ym1 = y1 * 12 + toInteger m1
ym2 = y2 * 12 + toInteger m2 ym2 = y2 * 12 + toInteger m2
ymdiff = ym2 - ym1 ymdiff = ym2 - ym1
ymAllowed = ymAllowed =
if day2 >= day1 if day2 >= day1
then then
if d2 >= d1 if d2 >= d1
then ymdiff then ymdiff
else ymdiff - 1 else ymdiff - 1
else else
if d2 <= d1 if d2 <= d1
then ymdiff then ymdiff
else ymdiff + 1 else ymdiff + 1
dayAllowed = addGregorianDurationRollOver (CalendarDiffDays ymAllowed 0) day1 dayAllowed = addGregorianDurationRollOver (CalendarDiffDays ymAllowed 0) day1
in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed
-- orphan instance -- orphan instance
instance Show Day where instance Show Day where
......
lib/Data/Time/Calendar/Julian.hs
View file @ baab563e
...@@ -125,43 +125,43 @@ addJulianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addJulianMont ...@@ -125,43 +125,43 @@ addJulianDurationRollOver (CalendarDiffDays m d) day = addDays d $ addJulianMont
-- | Calendrical difference, with as many whole months as possible -- | Calendrical difference, with as many whole months as possible
diffJulianDurationClip :: Day -> Day -> CalendarDiffDays diffJulianDurationClip :: Day -> Day -> CalendarDiffDays
diffJulianDurationClip day2 day1 = diffJulianDurationClip day2 day1 = let
let (y1, m1, d1) = toJulian day1 (y1, m1, d1) = toJulian day1
(y2, m2, d2) = toJulian day2 (y2, m2, d2) = toJulian day2
ym1 = y1 * 12 + toInteger m1 ym1 = y1 * 12 + toInteger m1
ym2 = y2 * 12 + toInteger m2 ym2 = y2 * 12 + toInteger m2
ymdiff = ym2 - ym1 ymdiff = ym2 - ym1
ymAllowed = ymAllowed =
if day2 >= day1 if day2 >= day1
then then
if d2 >= d1 if d2 >= d1
then ymdiff then ymdiff
else ymdiff - 1 else ymdiff - 1
else else
if d2 <= d1 if d2 <= d1
then ymdiff then ymdiff
else ymdiff + 1 else ymdiff + 1
dayAllowed = addJulianDurationClip (CalendarDiffDays ymAllowed 0) day1 dayAllowed = addJulianDurationClip (CalendarDiffDays ymAllowed 0) day1
in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed
-- | Calendrical difference, with as many whole months as possible. -- | Calendrical difference, with as many whole months as possible.
-- Same as 'diffJulianDurationClip' for positive durations. -- Same as 'diffJulianDurationClip' for positive durations.
diffJulianDurationRollOver :: Day -> Day -> CalendarDiffDays diffJulianDurationRollOver :: Day -> Day -> CalendarDiffDays
diffJulianDurationRollOver day2 day1 = diffJulianDurationRollOver day2 day1 = let
let (y1, m1, d1) = toJulian day1 (y1, m1, d1) = toJulian day1
(y2, m2, d2) = toJulian day2 (y2, m2, d2) = toJulian day2
ym1 = y1 * 12 + toInteger m1 ym1 = y1 * 12 + toInteger m1
ym2 = y2 * 12 + toInteger m2 ym2 = y2 * 12 + toInteger m2
ymdiff = ym2 - ym1 ymdiff = ym2 - ym1
ymAllowed = ymAllowed =
if day2 >= day1 if day2 >= day1
then then
if d2 >= d1 if d2 >= d1
then ymdiff then ymdiff
else ymdiff - 1 else ymdiff - 1
else else
if d2 <= d1 if d2 <= d1
then ymdiff then ymdiff
else ymdiff + 1 else ymdiff + 1
dayAllowed = addJulianDurationRollOver (CalendarDiffDays ymAllowed 0) day1 dayAllowed = addJulianDurationRollOver (CalendarDiffDays ymAllowed 0) day1
in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed in CalendarDiffDays ymAllowed $ diffDays day2 dayAllowed
lib/Data/Time/Calendar/JulianYearDay.hs
View file @ baab563e
...@@ -53,7 +53,8 @@ fromJulianYearAndDayValid year day = do ...@@ -53,7 +53,8 @@ fromJulianYearAndDayValid year day = do
else 365 else 365
) )
day day
let y = year - 1 let
y = year - 1
mjd = (fromIntegral day') + (365 * y) + (div y 4) - 678578 mjd = (fromIntegral day') + (365 * y) + (div y 4) - 678578
return (ModifiedJulianDay mjd) return (ModifiedJulianDay mjd)
......
lib/Data/Time/Calendar/MonthDay.hs
View file @ baab563e
...@@ -47,7 +47,8 @@ monthAndDayToDayOfYearValid :: Bool -> MonthOfYear -> DayOfMonth -> Maybe DayOfY ...@@ -47,7 +47,8 @@ monthAndDayToDayOfYearValid :: Bool -> MonthOfYear -> DayOfMonth -> Maybe DayOfY
monthAndDayToDayOfYearValid isLeap month day = do monthAndDayToDayOfYearValid isLeap month day = do
month' <- clipValid 1 12 month month' <- clipValid 1 12 month
day' <- clipValid 1 (monthLength' isLeap month') day day' <- clipValid 1 (monthLength' isLeap month') day
let day'' = fromIntegral day' let
day'' = fromIntegral day'
month'' = fromIntegral month' month'' = fromIntegral month'
k = k =
if month' <= 2 if month' <= 2
...@@ -104,4 +105,4 @@ monthLengths isleap = ...@@ -104,4 +105,4 @@ monthLengths isleap =
, 31 , 31
] ]
--J F M A M J J A S O N D -- J F M A M J J A S O N D