hebrew-time 0.1.1 → 0.1.2
raw patch · 9 files changed
+572/−594 lines, 9 filesdep +hebrew-timedep +hspecdep −HUnitdep −test-frameworkdep −test-framework-hunitdep ~QuickCheckdep ~basedep ~time
Dependencies added: hebrew-time, hspec
Dependencies removed: HUnit, test-framework, test-framework-hunit, test-framework-quickcheck2
Dependency ranges changed: QuickCheck, base, time
Files
- ChangeLog.md +5/−0
- Data/Time/Calendar/Hebrew.hs +0/−552
- README.md +6/−0
- hebrew-time.cabal +54/−34
- runtests.hs +0/−8
- src/Data/Time/Calendar/Hebrew.hs +27/−0
- src/Data/Time/Calendar/Hebrew/Internal.hs +286/−0
- test/Data/Time/Calendar/HebrewSpec.hs +193/−0
- test/Spec.hs +1/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# hebrew-time++## 0.1.2++* Properly handle next anniversaries in leap years
− Data/Time/Calendar/Hebrew.hs
@@ -1,552 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE CPP #-}---------------------------------------------------------------- Module : Data.Time.Calendar.Hebrew--- Copyright : Michael Snoyman--- License : BSD3------ Maintainer : Michael Snoyman <michael@snoyman.com>--- Stability : Unstable--- Portability : portable------ Conversion to and from Hebrew dates.--------------------------------------------------------------module Data.Time.Calendar.Hebrew- ( -- * Data types- HebrewDate (..)- , Month (..)- -- * Conversions- , fromHebrew- , toHebrew- , monthHebrew- -- * Anniversaries- , anniversaryInYear- , nextAnniversary-#if TEST- -- * Testing- , testSuite-#endif- ) where--import Data.Typeable (Typeable)-import Data.Data (Data)-import Control.Arrow-import Data.Time.Calendar (Day (..))--#if TEST-import Control.Applicative ((<$>))-import Data.Time.Calendar.WeekDate (toWeekDate)-import Data.Time.Calendar (fromGregorian)-import Test.Framework (testGroup, Test)-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit hiding (Test)-import Test.QuickCheck-#endif-------- data definitions-data Month = Tishrei | Cheshvan | Kislev | Tevet | Shevat- | Adar | Adar1 | Adar2- | Nissan | Iyar | Sivan | Tammuz | Av | Elul- deriving (Eq, Ord, Show, Enum, Read, Data, Typeable)-data YearType = Chaser | Ksidran | Shlema- deriving (Eq, Ord, Show, Enum)-data YearLeap = Leap | NonLeap- deriving (Eq, Ord, Show, Enum)--monthHebrew :: Month -> String-monthHebrew Tishrei = "תשרי"-monthHebrew Cheshvan = "חשון"-monthHebrew Kislev = "כסלו"-monthHebrew Tevet = "טבת"-monthHebrew Shevat = "שבט"-monthHebrew Adar = "אדר"-monthHebrew Adar1 = "אדר א"-monthHebrew Adar2 = "אדר ב"-monthHebrew Nissan = "ניסן"-monthHebrew Iyar = "אייר"-monthHebrew Sivan = "סיון"-monthHebrew Tammuz = "תמוז"-monthHebrew Av = "אב"-monthHebrew Elul = "אלול"-------- newtypes-newtype Chalakim = Chalakim Integer- deriving (Eq, Ord, Show, Enum, Num, Real, Integral)-type TotalChalakim = Chalakim--newtype Shaot = Shaot Integer- deriving (Eq, Ord, Show, Enum, Num, Real, Integral)--newtype Days = Days Integer- deriving (Eq, Ord, Show, Enum, Num, Real, Integral)-type Weekday = Days-type Julian = Days-type TotalDays = Days-type Date = Days--newtype Weeks = Weeks Integer- deriving (Eq, Ord, Show, Enum, Num, Real, Integral)--newtype Months = Months Integer- deriving (Eq, Ord, Show, Enum, Num, Real, Integral)--newtype Years = Years Integer- deriving (Eq, Ord, Show, Enum, Num, Real, Integral)-------- simple conversions-daysFromWeeks :: Weeks -> Days-daysFromWeeks (Weeks w) = Days (w * 7)--weeksFromDays :: Days -> (Weeks, Days)-weeksFromDays (Days d) = (Weeks *** Days) (d `divMod` 7)--shaotFromDays :: Days -> Shaot-shaotFromDays (Days d) = Shaot (d * 24)--daysFromShaot :: Shaot -> (Days, Shaot)-daysFromShaot (Shaot s) = (Days *** Shaot) (s `divMod` 24)--chalakimFromShaot :: Shaot -> Chalakim-chalakimFromShaot (Shaot s) = Chalakim (s * 1080)--shaotFromChalakim :: Chalakim -> (Shaot, Chalakim)-shaotFromChalakim (Chalakim c) = (Shaot *** Chalakim) (c `divMod` 1080)--chalakimFromMonths :: Months -> Chalakim-chalakimFromMonths (Months m) = Chalakim m * lunarMonth-------- constants-lunarMonth :: TotalChalakim-lunarMonth = joinChalakim 0 29 12 793-------- building functions-splitChalakim :: TotalChalakim -> (Weeks, Weekday, Shaot, Chalakim)-splitChalakim tc =- let (s', c) = shaotFromChalakim tc- (d', s) = daysFromShaot s'- (w, d) = weeksFromDays d'- in (w, d, s, c)--#if TEST-case_splitChalakim :: Assertion-case_splitChalakim = do- splitChalakim 1080 @=? (0, 0, 1, 0)- splitChalakim (15 * 24 * 1080) @=? (2, 1, 0, 0)-#endif--joinChalakim :: Weeks -> Days -> Shaot -> Chalakim -> TotalChalakim-joinChalakim w d s c =- chalakimFromShaot (shaotFromDays (daysFromWeeks w + d) + s) + c--#if TEST-prop_joinSplitChalakim :: TotalChalakim -> Bool-prop_joinSplitChalakim tc = tc == uncurry4 joinChalakim (splitChalakim tc)- where- uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e- uncurry4 f (a, b, c, d) = f a b c d-#endif-------- year dependent constants-isLeapYear :: Years -> YearLeap-isLeapYear y =- let res =- case y `mod` 19 of- 3 -> Leap- 6 -> Leap- 8 -> Leap- 11 -> Leap- 14 -> Leap- 17 -> Leap- 0 -> Leap -- 19- _ -> NonLeap- in res--monthsTilTishrei :: Years -> Months-monthsTilTishrei (Years i) = Months $ (235 * i - 234) `div` 19--#if TEST-case_monthsTilTishrei :: Assertion-case_monthsTilTishrei = do- 0 @=? monthsTilTishrei 1- 12 @=? monthsTilTishrei 2- 24 @=? monthsTilTishrei 3- 37 @=? monthsTilTishrei 4- 235 @=? monthsTilTishrei 20--extraMonthCount :: Years -> Months-extraMonthCount i =- case i of- 0 -> 0- 1 -> 0- 2 -> 0- 3 -> 1- 4 -> 1- 5 -> 1- 6 -> 2- 7 -> 2- 8 -> 3- 9 -> 3- 10 -> 3- 11 -> 4- 12 -> 4- 13 -> 4- 14 -> 5- 15 -> 5- 16 -> 5- 17 -> 6- 18 -> 6- _ -> error $ "extraMonthCount: " ++ show i--monthsTilTishreiLong :: Years -> Months-monthsTilTishreiLong (Years y') =- let (machzorim, y) = (y' - 1) `divMod` 19- base = Months $ (y' - 1) * 12 + machzorim * 7- extra = extraMonthCount $ Years y- in base + extra--prop_monthsTilTishrei :: Years -> Bool-prop_monthsTilTishrei y = monthsTilTishrei y == monthsTilTishreiLong y-#endif--firstTishrei :: TotalChalakim-firstTishrei = joinChalakim 0 1 5 204--moladTishrei :: Years -> TotalChalakim-moladTishrei y = chalakimFromMonths (monthsTilTishrei y) + firstTishrei--#if TEST-case_moladTishrei :: Assertion-case_moladTishrei = do- let testMolad w x y z = do- let (_, d, s, c) = splitChalakim $ moladTishrei w- in (w, d, s, c) @?= (w, x, y, z)- testMolad 5764 5 10 491- testMolad 1 1 5 204- testMolad 2 5 14 0- testMolad 3 2 22 876- testMolad 4 1 20 385- testMolad 5 6 5 181- testMolad 6 3 13 1057- testMolad 7 2 11 566- testMolad 8 6 20 362- testMolad 9 5 17 951- testMolad 10 3 2 747- testMolad 11 0 11 543- testMolad 18 0 15 414- testMolad 19 5 0 210- testMolad 20 3 21 799-#endif--monthLength :: YearLeap -> YearType -> Month -> Days-monthLength _ _ Tishrei = 30-monthLength _ _ Tevet = 29-monthLength _ _ Shevat = 30-monthLength _ _ Nissan = 30-monthLength _ _ Iyar = 29-monthLength _ _ Sivan = 30-monthLength _ _ Tammuz = 29-monthLength _ _ Av = 30-monthLength _ _ Elul = 29-monthLength Leap _ Adar = 0-monthLength Leap _ Adar1 = 30-monthLength Leap _ Adar2 = 29-monthLength NonLeap _ Adar = 29-monthLength NonLeap _ Adar1 = 0-monthLength NonLeap _ Adar2 = 0-monthLength _ Shlema Cheshvan = 30-monthLength _ _ Cheshvan = 29-monthLength _ Chaser Kislev = 29-monthLength _ _ Kislev = 30-------- conversion functions-dateFromJulian :: YearLeap -> YearType -> Julian -> (Month, Date)-dateFromJulian yl yt j' =- let ml = monthLength yl yt- helper :: Month -> Julian -> (Month, Date)- helper m j- | ml m >= j = (m, j)- | m == Elul =- error $ "Invalid dateFromJulain args: " ++ show (yl, yt, j', j)- | otherwise = helper (succ m) (j - ml m)- in helper Tishrei j'--#if TEST-julianFromDate :: YearLeap -> YearType -> Month -> Date -> Julian-julianFromDate yl yt m d =- let ml = monthLength yl yt- months = case m of- Tishrei -> []- _ -> enumFromTo Tishrei (pred m)- in d + sum (map ml months)--prop_dateToFromJulian :: YearLeap -> YearType -> Julian -> Bool-prop_dateToFromJulian yl yt j =- j == uncurry (julianFromDate yl yt) (dateFromJulian yl yt j)-#endif-------- determining year stuff-roshHashana :: Years -> TotalDays-roshHashana y = daysFromWeeks w + d + dechiyot- where- (w, d, s, c) = splitChalakim $ moladTishrei y- dechiyot- | s > 18 || s == 18 && c > 0 =- case d of- 0 -> 1- 1 -> 1- 2 -> 2 -- otherwise it would be Wednesday- 3 -> 1- 4 -> 2 -- otherwise it would be Friday- 5 -> 1- 6 -> 2 -- otherwise it would be Sunday- _ -> error $ "roshHashana: d ==" ++ show d- | d `elem` [0, 3, 5] = 1 -- ADU rosh- | d == 2 &&- isLeapYear y == NonLeap &&- (s > 9 ||- s == 9 && c > 204) = 2- | isLeapYear (y - 1) == Leap &&- d == 1 &&- (s > 15 ||- s == 15 && c > 589) = 1- | otherwise = 0--#if TEST-case_firstRoshHashana :: Assertion-case_firstRoshHashana = roshHashana 1 @?= 1--dayOfWeek :: TotalDays -> Weekday-dayOfWeek t =- let (_, w) = weeksFromDays t- in w--prop_validRoshHashanaDay :: Years -> Bool-prop_validRoshHashanaDay = (`elem` [1, 2, 4, 6]) . dayOfWeek . roshHashana-#endif--yearLength :: Years -> TotalDays-yearLength y = roshHashana (y + 1) - roshHashana y--#if TEST-prop_yearLength :: Years -> Bool-prop_yearLength y =- let l = yearLength y- in l `elem` [353, 354, 355, 383, 384, 385]-#endif--julianFromDays :: TotalDays -> (Years, Julian)-julianFromDays td = uncurry helper $ approx td where- helper :: Years -> TotalDays -> (Years, Julian)- helper y d -- FIXME do not use yearLength here...- | yearLength y < d = helper (y + 1) (d - yearLength y)- | otherwise = (y, fromIntegral d)- approx :: TotalDays -> (Years, TotalDays)- approx (Days td') =- let minYears = Years $ td' `div` 366- Days rh = roshHashana minYears- rem' = Days $ td' - rh + 1- in (minYears, rem')--#if TEST-prop_roshHashana_julianFromDays :: Years -> Bool-prop_roshHashana_julianFromDays y = (y, 1) == julianFromDays (roshHashana y)-#endif--yearDef :: TotalDays -> TotalDays -> (YearLeap, YearType)-yearDef a b = case b - a of- 353 -> (NonLeap, Chaser)- 354 -> (NonLeap, Ksidran)- 355 -> (NonLeap, Shlema)- 383 -> (Leap, Chaser)- 384 -> (Leap, Ksidran)- 385 -> (Leap, Shlema)- x -> error $ "Invalid year length: " ++ show x-------- convert dates-data HebrewDate = HebrewDate- { year :: Int- , month :: Month- , date :: Int- }- deriving (Eq, Data, Typeable)-instance Show HebrewDate where- show (HebrewDate y m d) = show d ++ " " ++ show m ++ ", " ++ show y--epochOffset :: Integral i => i-epochOffset = 2052004--fromHebrew :: HebrewDate -> Day-fromHebrew h =- let Days td = totalDaysFromHebrew h- in ModifiedJulianDay $ td - epochOffset--toHebrew :: Day -> HebrewDate-toHebrew d' =- let jd = toModifiedJulianDay d' + epochOffset- td = fromIntegral jd- (y, j) = julianFromDays td- (yl, yt) = yearDef (roshHashana y) (roshHashana $ y + 1)- (m, d) = dateFromJulian yl yt j- in HebrewDate (fromIntegral y) m (fromIntegral d)--totalDaysFromHebrew :: HebrewDate -> TotalDays-totalDaysFromHebrew (HebrewDate y m d) =- let rh = roshHashana $ Years $ fromIntegral y- rh2 = roshHashana $ Years $ fromIntegral $ y + 1- (yl, yt) = yearDef rh rh2- ml = monthLength yl yt- ds = fromIntegral $ sum $ map ml [Tishrei ..m]- in rh + ds + fromIntegral d - fromIntegral (ml m) - 1--#if TEST-prop_fromToHebrew :: Integer -> Bool-prop_fromToHebrew d' =- let d = ModifiedJulianDay d'- in d == fromHebrew (toHebrew d)--prop_sameWeekday :: HebrewDate -> Bool-prop_sameWeekday h =- let td = totalDaysFromHebrew h- wd1 = dayOfWeek td- d = fromHebrew h- (_, _, wd2) = toWeekDate d- wd2' = fromIntegral wd2 `mod` 7- in wd1 == wd2'--case_integralSpotCheck :: Assertion-case_integralSpotCheck = do- (toModifiedJulianDay $ fromGregorian 2009 9 26) @=?- (toModifiedJulianDay $ fromHebrew $ HebrewDate 5770 Tishrei 8)- dayOfWeek (roshHashana 5770) @?= 6- roshHashana 5770 @=? totalDaysFromHebrew (HebrewDate 5770 Tishrei 1)- dayOfWeek (totalDaysFromHebrew $ HebrewDate 5770 Tishrei 3) @?= 1--case_spotChecks :: Assertion-case_spotChecks = do- fromGregorian 1984 9 27 @=? fromHebrew (HebrewDate 5745 Tishrei 1)- fromGregorian 1985 1 12 @=? fromHebrew (HebrewDate 5745 Tevet 19)- fromGregorian 1986 9 8 @=? fromHebrew (HebrewDate 5746 Elul 4)--case_year3932 :: Assertion-case_year3932 = do- 2 @=? dayOfWeek (roshHashana 3932)-#endif--clip :: HebrewDate -> HebrewDate-clip (HebrewDate y m d) =- let y' = Years $ fromIntegral y- (yl, yt) = yearDef (roshHashana y') (roshHashana $ y' + 1)- m' = adjustMonth yl m- ml = fromIntegral $ monthLength yl yt m'- d' = if d > ml then ml else d- in HebrewDate y m' d'--adjustMonth :: YearLeap -> Month -> Month-adjustMonth Leap Adar = Adar2-adjustMonth Leap x = x-adjustMonth NonLeap Adar1 = Adar-adjustMonth NonLeap Adar2 = Adar-adjustMonth NonLeap x = x--anniversaryInYear :: Int -- ^ year- -> HebrewDate- -> HebrewDate-anniversaryInYear y (HebrewDate _ m d) = clip $ HebrewDate y m d--#if TEST-caseAnniversaryInYear :: IO ()-caseAnniversaryInYear = do- -- Year 5770 is just the current year at time of writing- -- Year 3 is a chaser leap year- -- Year 4 is a leap year- HebrewDate 5770 Tishrei 1 @=?- anniversaryInYear 5770 (HebrewDate 1 Tishrei 1)- HebrewDate 3 Cheshvan 29 @=?- anniversaryInYear 3 (HebrewDate 1 Cheshvan 30)- HebrewDate 3 Kislev 29 @=?- anniversaryInYear 3 (HebrewDate 1 Kislev 30)- HebrewDate 3 Adar2 1 @=?- anniversaryInYear 3 (HebrewDate 1 Adar 1)- HebrewDate 4 Adar 1 @=?- anniversaryInYear 4 (HebrewDate 1 Adar1 1)- HebrewDate 4 Adar 1 @=?- anniversaryInYear 4 (HebrewDate 1 Adar2 1)- HebrewDate 4 Adar 29 @=?- anniversaryInYear 4 (HebrewDate 1 Adar1 30)-#endif--nextAnniversary :: HebrewDate -- ^ so to say current date- -> HebrewDate -- ^ date of event- -> HebrewDate -- ^ first anniversary of event after current-nextAnniversary (HebrewDate cy cm cd) hd@(HebrewDate _y m d)- | cm > m || cm == m && cd > d = anniversaryInYear (cy + 1) hd- | otherwise = anniversaryInYear cy hd--#if TEST-caseNextAnniversary :: IO ()-caseNextAnniversary = do- HebrewDate 5770 Tishrei 2 @=?- nextAnniversary (HebrewDate 5770 Tishrei 1) (HebrewDate 1 Tishrei 2)- HebrewDate 5771 Tishrei 2 @=?- nextAnniversary (HebrewDate 5770 Tishrei 3) (HebrewDate 1 Tishrei 2)- HebrewDate 5775 Adar 1 @=?- nextAnniversary (HebrewDate 5775 Tishrei 1) (HebrewDate 5774 Adar2 1)- HebrewDate 5775 Cheshvan 29 @=?- nextAnniversary (HebrewDate 5775 Tishrei 1) (HebrewDate 5774 Cheshvan 30)-------- testing-testSuite :: Test-testSuite = testGroup "Data.Time.Calendar.Hebrew"- [ testProperty "join and split chalakim" prop_joinSplitChalakim- , testProperty "to/from julian date" prop_dateToFromJulian- , testCase "first rosh hashana is day 1" case_firstRoshHashana- , testProperty "rosh hashana/julianFromDays" prop_roshHashana_julianFromDays- , testProperty "to/from hebrew" prop_fromToHebrew- , testCase "splitChalakim " case_splitChalakim- , testCase "molad tishrei" case_moladTishrei- , testProperty "months til tishrei" prop_monthsTilTishrei- , testProperty "valid year length" prop_yearLength- , testCase "months til tishrei case" case_monthsTilTishrei- , testProperty "rosh hashana valid weekday" prop_validRoshHashanaDay- , testProperty "greg/hebrew same weekday" prop_sameWeekday- , testCase "integral date spot check" case_integralSpotCheck- , testCase "individual date spot checks" case_spotChecks- , testCase "year 3932" case_year3932- , testCase "caseAnniversaryInYear" caseAnniversaryInYear- , testCase "caseNextAnniversary" caseNextAnniversary- ]--instance Arbitrary Chalakim where- arbitrary = fromIntegral <$> (arbitrary :: Gen Int)--instance Arbitrary Days where- arbitrary = fromIntegral . (+ 1) . (`mod` 353)- <$> (arbitrary :: Gen Int)--instance Arbitrary Years where- arbitrary = fromIntegral . (+ 1) . (`mod` 6000)- <$> (arbitrary :: Gen Int)--enumAll :: Enum e => [e]-enumAll = enumFrom $ toEnum 1--instance Arbitrary YearLeap where- arbitrary = elements enumAll--instance Arbitrary YearType where- arbitrary = elements enumAll--instance Arbitrary HebrewDate where- arbitrary = do- m <- elements [Tishrei, Cheshvan, Kislev, Tevet, Shevat,- Nissan, Iyar, Sivan, Tammuz, Av, Elul]- y <- (+ 1) . (`mod` 6000) <$> arbitrary- day <- (+ 1) . (`mod` 29) <$> arbitrary- return $! HebrewDate y m day-#endif
+ README.md view
@@ -0,0 +1,6 @@+# hebrew-time++[](https://travis-ci.org/snoyberg/hebrew-time)++Types and functions for converting dates from the Hebrew calendar to+and from Gregorian dates (provided by the `time` package).
hebrew-time.cabal view
@@ -1,38 +1,58 @@-name: hebrew-time-version: 0.1.1-license: MIT-license-file: LICENSE-author: Michael Snoyman <michael@snoyman.com>-maintainer: Michael Snoyman <michael@snoyman.com>-synopsis: Hebrew dates and prayer times.-description: Conversion to and from Hebrew dates.-category: Data-stability: stable-cabal-version: >= 1.10-build-type: Simple-homepage: https://github.com/snoyberg/hebrew-time+cabal-version: 1.12 -library- build-depends: base >= 4 && < 5,- time >= 1.1.3- exposed-modules: Data.Time.Calendar.Hebrew- ghc-options: -Wall- default-language: Haskell98+-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 5d1b5bb50ee77597dd672f23ac3bdc6bad8c8b8ab5af83930b43c3234d40544d -test-suite runtests- type: exitcode-stdio-1.0- default-language: Haskell98- cpp-options: -DTEST- build-depends: test-framework,- test-framework-quickcheck2,- test-framework-hunit,- HUnit,- base,- time,- QuickCheck >= 2 && < 3- ghc-options: -Wall- main-is: runtests.hs+name: hebrew-time+version: 0.1.2+synopsis: Hebrew dates and prayer times.+description: Conversion to and from Hebrew dates.+category: Data+homepage: https://github.com/snoyberg/hebrew-time#readme+bug-reports: https://github.com/snoyberg/hebrew-time/issues+author: Michael Snoyman <michael@snoyman.com>+maintainer: Michael Snoyman <michael@snoyman.com>+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md source-repository head- type: git- location: git://github.com/snoyberg/hebrew-time.git+ type: git+ location: https://github.com/snoyberg/hebrew-time++library+ exposed-modules:+ Data.Time.Calendar.Hebrew+ Data.Time.Calendar.Hebrew.Internal+ other-modules:+ Paths_hebrew_time+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ base >=4.9 && <5+ , time >=1.6+ default-language: Haskell2010++test-suite runtests+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Data.Time.Calendar.HebrewSpec+ Paths_hebrew_time+ hs-source-dirs:+ test+ ghc-options: -Wall+ build-depends:+ QuickCheck+ , base >=4.9 && <5+ , hebrew-time+ , hspec+ , time >=1.6+ default-language: Haskell2010
− runtests.hs
@@ -1,8 +0,0 @@-import Test.Framework (defaultMain)--import qualified Data.Time.Calendar.Hebrew--main :: IO ()-main = defaultMain- [ Data.Time.Calendar.Hebrew.testSuite- ]
+ src/Data/Time/Calendar/Hebrew.hs view
@@ -0,0 +1,27 @@+---------------------------------------------------------+--+-- Module : Data.Time.Calendar.Hebrew+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Unstable+-- Portability : portable+--+-- Conversion to and from Hebrew dates.+--+---------------------------------------------------------+module Data.Time.Calendar.Hebrew+ ( -- * Data types+ HebrewDate (..)+ , Month (..)+ -- * Conversions+ , fromHebrew+ , toHebrew+ , monthHebrew+ -- * Anniversaries+ , anniversaryInYear+ , nextAnniversary+ ) where++import Data.Time.Calendar.Hebrew.Internal
+ src/Data/Time/Calendar/Hebrew/Internal.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Data.Time.Calendar.Hebrew.Internal where++import Data.Typeable (Typeable)+import Data.Data (Data)+import Control.Arrow+import Data.Time.Calendar (Day (..))++------ data definitions+data Month = Tishrei | Cheshvan | Kislev | Tevet | Shevat+ | Adar | Adar1 | Adar2+ | Nissan | Iyar | Sivan | Tammuz | Av | Elul+ deriving (Eq, Ord, Show, Enum, Read, Data, Typeable)+data YearType = Chaser | Ksidran | Shlema+ deriving (Eq, Ord, Show, Enum)+data YearLeap = Leap | NonLeap+ deriving (Eq, Ord, Show, Enum)++monthHebrew :: Month -> String+monthHebrew Tishrei = "תשרי"+monthHebrew Cheshvan = "חשון"+monthHebrew Kislev = "כסלו"+monthHebrew Tevet = "טבת"+monthHebrew Shevat = "שבט"+monthHebrew Adar = "אדר"+monthHebrew Adar1 = "אדר א"+monthHebrew Adar2 = "אדר ב"+monthHebrew Nissan = "ניסן"+monthHebrew Iyar = "אייר"+monthHebrew Sivan = "סיון"+monthHebrew Tammuz = "תמוז"+monthHebrew Av = "אב"+monthHebrew Elul = "אלול"++------ newtypes+newtype Chalakim = Chalakim Integer+ deriving (Eq, Ord, Show, Enum, Num, Real, Integral)+type TotalChalakim = Chalakim++newtype Shaot = Shaot Integer+ deriving (Eq, Ord, Show, Enum, Num, Real, Integral)++newtype Days = Days Integer+ deriving (Eq, Ord, Show, Enum, Num, Real, Integral)+type Weekday = Days+type Julian = Days+type TotalDays = Days+type Date = Days++newtype Weeks = Weeks Integer+ deriving (Eq, Ord, Show, Enum, Num, Real, Integral)++newtype Months = Months Integer+ deriving (Eq, Ord, Show, Enum, Num, Real, Integral)++newtype Years = Years Integer+ deriving (Eq, Ord, Show, Enum, Num, Real, Integral)++------ simple conversions+daysFromWeeks :: Weeks -> Days+daysFromWeeks (Weeks w) = Days (w * 7)++weeksFromDays :: Days -> (Weeks, Days)+weeksFromDays (Days d) = (Weeks *** Days) (d `divMod` 7)++shaotFromDays :: Days -> Shaot+shaotFromDays (Days d) = Shaot (d * 24)++daysFromShaot :: Shaot -> (Days, Shaot)+daysFromShaot (Shaot s) = (Days *** Shaot) (s `divMod` 24)++chalakimFromShaot :: Shaot -> Chalakim+chalakimFromShaot (Shaot s) = Chalakim (s * 1080)++shaotFromChalakim :: Chalakim -> (Shaot, Chalakim)+shaotFromChalakim (Chalakim c) = (Shaot *** Chalakim) (c `divMod` 1080)++chalakimFromMonths :: Months -> Chalakim+chalakimFromMonths (Months m) = Chalakim m * lunarMonth++------ constants+lunarMonth :: TotalChalakim+lunarMonth = joinChalakim 0 29 12 793++------ building functions+splitChalakim :: TotalChalakim -> (Weeks, Weekday, Shaot, Chalakim)+splitChalakim tc =+ let (s', c) = shaotFromChalakim tc+ (d', s) = daysFromShaot s'+ (w, d) = weeksFromDays d'+ in (w, d, s, c)++joinChalakim :: Weeks -> Days -> Shaot -> Chalakim -> TotalChalakim+joinChalakim w d s c =+ chalakimFromShaot (shaotFromDays (daysFromWeeks w + d) + s) + c++------ year dependent constants+isLeapYear :: Years -> YearLeap+isLeapYear y =+ let res =+ case y `mod` 19 of+ 3 -> Leap+ 6 -> Leap+ 8 -> Leap+ 11 -> Leap+ 14 -> Leap+ 17 -> Leap+ 0 -> Leap -- 19+ _ -> NonLeap+ in res++monthsTilTishrei :: Years -> Months+monthsTilTishrei (Years i) = Months $ (235 * i - 234) `div` 19++firstTishrei :: TotalChalakim+firstTishrei = joinChalakim 0 1 5 204++moladTishrei :: Years -> TotalChalakim+moladTishrei y = chalakimFromMonths (monthsTilTishrei y) + firstTishrei++monthLength :: YearLeap -> YearType -> Month -> Days+monthLength _ _ Tishrei = 30+monthLength _ _ Tevet = 29+monthLength _ _ Shevat = 30+monthLength _ _ Nissan = 30+monthLength _ _ Iyar = 29+monthLength _ _ Sivan = 30+monthLength _ _ Tammuz = 29+monthLength _ _ Av = 30+monthLength _ _ Elul = 29+monthLength Leap _ Adar = 0+monthLength Leap _ Adar1 = 30+monthLength Leap _ Adar2 = 29+monthLength NonLeap _ Adar = 29+monthLength NonLeap _ Adar1 = 0+monthLength NonLeap _ Adar2 = 0+monthLength _ Shlema Cheshvan = 30+monthLength _ _ Cheshvan = 29+monthLength _ Chaser Kislev = 29+monthLength _ _ Kislev = 30++------ conversion functions+dateFromJulian :: YearLeap -> YearType -> Julian -> (Month, Date)+dateFromJulian yl yt j' =+ let ml = monthLength yl yt+ helper :: Month -> Julian -> (Month, Date)+ helper m j+ | ml m >= j = (m, j)+ | m == Elul =+ error $ "Invalid dateFromJulain args: " ++ show (yl, yt, j', j)+ | otherwise = helper (succ m) (j - ml m)+ in helper Tishrei j'++------ determining year stuff+roshHashana :: Years -> TotalDays+roshHashana y = daysFromWeeks w + d + dechiyot+ where+ (w, d, s, c) = splitChalakim $ moladTishrei y+ dechiyot+ | s > 18 || s == 18 && c > 0 =+ case d of+ 0 -> 1+ 1 -> 1+ 2 -> 2 -- otherwise it would be Wednesday+ 3 -> 1+ 4 -> 2 -- otherwise it would be Friday+ 5 -> 1+ 6 -> 2 -- otherwise it would be Sunday+ _ -> error $ "roshHashana: d ==" ++ show d+ | d `elem` [0, 3, 5] = 1 -- ADU rosh+ | d == 2 &&+ isLeapYear y == NonLeap &&+ (s > 9 ||+ s == 9 && c > 204) = 2+ | isLeapYear (y - 1) == Leap &&+ d == 1 &&+ (s > 15 ||+ s == 15 && c > 589) = 1+ | otherwise = 0++yearLength :: Years -> TotalDays+yearLength y = roshHashana (y + 1) - roshHashana y++julianFromDays :: TotalDays -> (Years, Julian)+julianFromDays td = uncurry helper $ approx td where+ helper :: Years -> TotalDays -> (Years, Julian)+ helper y d -- FIXME do not use yearLength here...+ | yearLength y < d = helper (y + 1) (d - yearLength y)+ | otherwise = (y, fromIntegral d)+ approx :: TotalDays -> (Years, TotalDays)+ approx (Days td') =+ let minYears = Years $ td' `div` 366+ Days rh = roshHashana minYears+ rem' = Days $ td' - rh + 1+ in (minYears, rem')++yearDef :: TotalDays -> TotalDays -> (YearLeap, YearType)+yearDef a b = case b - a of+ 353 -> (NonLeap, Chaser)+ 354 -> (NonLeap, Ksidran)+ 355 -> (NonLeap, Shlema)+ 383 -> (Leap, Chaser)+ 384 -> (Leap, Ksidran)+ 385 -> (Leap, Shlema)+ x -> error $ "Invalid year length: " ++ show x++------ convert dates+data HebrewDate = HebrewDate+ { year :: Int+ , month :: Month+ , date :: Int+ }+ deriving (Eq, Data, Typeable)+instance Show HebrewDate where+ show (HebrewDate y m d) = show d ++ " " ++ show m ++ ", " ++ show y++epochOffset :: Integral i => i+epochOffset = 2052004++fromHebrew :: HebrewDate -> Day+fromHebrew h =+ let Days td = totalDaysFromHebrew h+ in ModifiedJulianDay $ td - epochOffset++toHebrew :: Day -> HebrewDate+toHebrew d' =+ let jd = toModifiedJulianDay d' + epochOffset+ td = fromIntegral jd+ (y, j) = julianFromDays td+ (yl, yt) = yearDef (roshHashana y) (roshHashana $ y + 1)+ (m, d) = dateFromJulian yl yt j+ in HebrewDate (fromIntegral y) m (fromIntegral d)++totalDaysFromHebrew :: HebrewDate -> TotalDays+totalDaysFromHebrew (HebrewDate y m d) =+ let rh = roshHashana $ Years $ fromIntegral y+ rh2 = roshHashana $ Years $ fromIntegral $ y + 1+ (yl, yt) = yearDef rh rh2+ ml = monthLength yl yt+ ds = fromIntegral $ sum $ map ml [Tishrei ..m]+ in rh + ds + fromIntegral d - fromIntegral (ml m) - 1++clip :: HebrewDate -> HebrewDate+clip (HebrewDate y m d) =+ let y' = Years $ fromIntegral y+ (yl, yt) = yearDef (roshHashana y') (roshHashana $ y' + 1)+ m' = adjustMonth yl m+ ml = fromIntegral $ monthLength yl yt m'+ d' = if d > ml then ml else d+ in HebrewDate y m' d'++adjustMonth :: YearLeap -> Month -> Month+adjustMonth Leap Adar = Adar2+adjustMonth Leap x = x+adjustMonth NonLeap Adar1 = Adar+adjustMonth NonLeap Adar2 = Adar+adjustMonth NonLeap x = x++anniversaryInYear :: Int -- ^ year+ -> HebrewDate+ -> HebrewDate+anniversaryInYear y (HebrewDate _ m d) = clip $ HebrewDate y m d++nextAnniversary :: HebrewDate -- ^ so to say current date+ -> HebrewDate -- ^ date of event+ -> HebrewDate -- ^ first anniversary of event after current+nextAnniversary curr hd+ | geHD thisYear curr = thisYear+ | otherwise = nextYear+ where+ thisYear = anniversaryInYear (year curr) hd+ nextYear = anniversaryInYear (year curr + 1) hd++geHD :: HebrewDate -> HebrewDate -> Bool+geHD (HebrewDate y1 m1 d1) (HebrewDate y2 m2 d2) =+ case compare y1 y2 of+ LT -> False+ GT -> True+ EQ ->+ case compare m1 m2 of+ LT -> False+ GT -> True+ EQ -> d1 >= d2
+ test/Data/Time/Calendar/HebrewSpec.hs view
@@ -0,0 +1,193 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Data.Time.Calendar.HebrewSpec (spec) where++import Data.Time.Calendar.Hebrew.Internal+import Test.Hspec+import Test.Hspec.QuickCheck++import Control.Applicative ((<$>))+import Data.Time.Calendar.WeekDate (toWeekDate)+import Data.Time.Calendar (fromGregorian, Day (..))+import Test.QuickCheck++spec :: Spec+spec = do+ prop "join and split chalakim" $ \tc ->+ uncurry4 joinChalakim (splitChalakim tc) `shouldBe` tc+ prop "to/from julian date" $ \yl yt j ->+ uncurry (julianFromDate yl yt) (dateFromJulian yl yt j) `shouldBe` j+ it "first rosh hashana is day 1" $+ roshHashana 1 `shouldBe` 1+ prop "rosh hashana/julianFromDays" $ \y ->+ julianFromDays (roshHashana y) `shouldBe` (y, 1)+ prop "to/from hebrew" $ \d' ->+ let d = ModifiedJulianDay d'+ in fromHebrew (toHebrew d) `shouldBe` d+ it "splitChalakim " $ do+ splitChalakim 1080 `shouldBe` (0, 0, 1, 0)+ splitChalakim (15 * 24 * 1080) `shouldBe` (2, 1, 0, 0)+ it "molad tishrei" $ do+ let testMolad w x y z =+ let (_, d, s, c) = splitChalakim $ moladTishrei w+ in (w, d, s, c) `shouldBe` (w, x, y, z)+ testMolad 5764 5 10 491+ testMolad 1 1 5 204+ testMolad 2 5 14 0+ testMolad 3 2 22 876+ testMolad 4 1 20 385+ testMolad 5 6 5 181+ testMolad 6 3 13 1057+ testMolad 7 2 11 566+ testMolad 8 6 20 362+ testMolad 9 5 17 951+ testMolad 10 3 2 747+ testMolad 11 0 11 543+ testMolad 18 0 15 414+ testMolad 19 5 0 210+ testMolad 20 3 21 799+ prop "months til tishrei" $ \y ->+ monthsTilTishrei y == monthsTilTishreiLong y+ prop "valid year length" $ \y ->+ let l = yearLength y+ in l `elem` [353, 354, 355, 383, 384, 385]+ it "months til tishrei case" $ do+ monthsTilTishrei 1 `shouldBe` 0+ monthsTilTishrei 2 `shouldBe` 12+ monthsTilTishrei 3 `shouldBe` 24+ monthsTilTishrei 4 `shouldBe` 37+ monthsTilTishrei 20 `shouldBe` 235+ prop "rosh hashana valid weekday" $+ (`elem` [1, 2, 4, 6]) . dayOfWeek . roshHashana+ prop "greg/hebrew same weekday" $ \h ->+ let td = totalDaysFromHebrew h+ wd1 = dayOfWeek td+ d = fromHebrew h+ (_, _, wd2) = toWeekDate d+ wd2' = fromIntegral wd2 `mod` 7+ in wd1 == wd2'+ it "integral date spot check" $ do+ (toModifiedJulianDay $ fromGregorian 2009 9 26) `shouldBe`+ (toModifiedJulianDay $ fromHebrew $ HebrewDate 5770 Tishrei 8)+ dayOfWeek (roshHashana 5770) `shouldBe` 6+ roshHashana 5770 `shouldBe` totalDaysFromHebrew (HebrewDate 5770 Tishrei 1)+ dayOfWeek (totalDaysFromHebrew $ HebrewDate 5770 Tishrei 3) `shouldBe` 1+ it "individual date spot checks" $ do+ fromGregorian 1984 9 27 `shouldBe` fromHebrew (HebrewDate 5745 Tishrei 1)+ fromGregorian 1985 1 12 `shouldBe` fromHebrew (HebrewDate 5745 Tevet 19)+ fromGregorian 1986 9 8 `shouldBe` fromHebrew (HebrewDate 5746 Elul 4)+ it "year 3932" $ dayOfWeek (roshHashana 3932) `shouldBe` 2+ it "caseAnniversaryInYear" $ do+ -- Year 5770 is just the current year at time of writing+ -- Year 3 is a chaser leap year+ -- Year 4 is a leap year+ HebrewDate 5770 Tishrei 1 `shouldBe`+ anniversaryInYear 5770 (HebrewDate 1 Tishrei 1)+ HebrewDate 3 Cheshvan 29 `shouldBe`+ anniversaryInYear 3 (HebrewDate 1 Cheshvan 30)+ HebrewDate 3 Kislev 29 `shouldBe`+ anniversaryInYear 3 (HebrewDate 1 Kislev 30)+ HebrewDate 3 Adar2 1 `shouldBe`+ anniversaryInYear 3 (HebrewDate 1 Adar 1)+ HebrewDate 4 Adar 1 `shouldBe`+ anniversaryInYear 4 (HebrewDate 1 Adar1 1)+ HebrewDate 4 Adar 1 `shouldBe`+ anniversaryInYear 4 (HebrewDate 1 Adar2 1)+ HebrewDate 4 Adar 29 `shouldBe`+ anniversaryInYear 4 (HebrewDate 1 Adar1 30)+ it "caseNextAnniversary" $ do+ HebrewDate 5770 Tishrei 2 `shouldBe`+ nextAnniversary (HebrewDate 5770 Tishrei 1) (HebrewDate 1 Tishrei 2)+ HebrewDate 5771 Tishrei 2 `shouldBe`+ nextAnniversary (HebrewDate 5770 Tishrei 3) (HebrewDate 1 Tishrei 2)+ HebrewDate 5775 Adar 1 `shouldBe`+ nextAnniversary (HebrewDate 5775 Tishrei 1) (HebrewDate 5774 Adar2 1)+ HebrewDate 5775 Cheshvan 29 `shouldBe`+ nextAnniversary (HebrewDate 5775 Tishrei 1) (HebrewDate 5774 Cheshvan 30)+ prop "anniversary year works" $ \d (Years y') ->+ let y = fromIntegral y'+ in year (anniversaryInYear y d) `shouldBe` y+ it "anniversary leap year examples" $ do+ let today = toHebrew $ fromGregorian 2019 2 17+ orig = toHebrew $ fromGregorian 1956 3 4+ expected = anniversaryInYear 5779 orig+ actual = nextAnniversary today orig+ expected `shouldBe` HebrewDate 5779 Adar2 21+ actual `shouldBe` expected++uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e+uncurry4 f (a, b, c, d) = f a b c d++extraMonthCount :: Years -> Months+extraMonthCount i =+ case i of+ 0 -> 0+ 1 -> 0+ 2 -> 0+ 3 -> 1+ 4 -> 1+ 5 -> 1+ 6 -> 2+ 7 -> 2+ 8 -> 3+ 9 -> 3+ 10 -> 3+ 11 -> 4+ 12 -> 4+ 13 -> 4+ 14 -> 5+ 15 -> 5+ 16 -> 5+ 17 -> 6+ 18 -> 6+ _ -> error $ "extraMonthCount: " ++ show i++monthsTilTishreiLong :: Years -> Months+monthsTilTishreiLong (Years y') =+ let (machzorim, y) = (y' - 1) `divMod` 19+ base = Months $ (y' - 1) * 12 + machzorim * 7+ extra = extraMonthCount $ Years y+ in base + extra+++julianFromDate :: YearLeap -> YearType -> Month -> Date -> Julian+julianFromDate yl yt m d =+ let ml = monthLength yl yt+ months = case m of+ Tishrei -> []+ _ -> enumFromTo Tishrei (pred m)+ in d + sum (map ml months)++dayOfWeek :: TotalDays -> Weekday+dayOfWeek t =+ let (_, w) = weeksFromDays t+ in w++enumAll :: Enum e => [e]+enumAll = enumFrom $ toEnum 1++-- orphan arbitrary instances+instance Arbitrary Chalakim where+ arbitrary = fromIntegral <$> (arbitrary :: Gen Int)++instance Arbitrary Days where+ arbitrary = fromIntegral . (+ 1) . (`mod` 353)+ <$> (arbitrary :: Gen Int)++instance Arbitrary Years where+ arbitrary = fromIntegral . (+ 1) . (`mod` 6000)+ <$> (arbitrary :: Gen Int)++instance Arbitrary YearLeap where+ arbitrary = elements enumAll++instance Arbitrary YearType where+ arbitrary = elements enumAll++instance Arbitrary HebrewDate where+ arbitrary = do+ m <- elements [Tishrei, Cheshvan, Kislev, Tevet, Shevat,+ Nissan, Iyar, Sivan, Tammuz, Av, Elul]+ y <- (+ 1) . (`mod` 6000) <$> arbitrary+ day <- (+ 1) . (`mod` 29) <$> arbitrary+ return $! HebrewDate y m day+
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}