module Data.Time.Calendar.Hebrew
( HebrewDate (..)
, Month (..)
, fromHebrew
, toHebrew
, anniversaryInYear
, nextAnniversary
#if TEST
, testSuite
#endif
) where
import Control.Applicative ((<$>))
import Control.Arrow
import Control.Monad
import Data.Time.Calendar (Day (..), fromGregorian)
import Data.Time.Calendar.WeekDate (toWeekDate)
import Data.Typeable (Typeable)
import Control.Exception (Exception)
import qualified Safe.Failure as SF
import Control.Failure
#if TEST
import Test.Framework (testGroup, Test)
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck (testProperty)
import Test.HUnit hiding (Test)
import Test.QuickCheck
#endif
import Data.Object
data Month = Tishrei | Cheshvan | Kislev | Tevet | Shevat
| Adar | Adar1 | Adar2
| Nissan | Iyar | Sivan | Tammuz | Av | Elul
deriving (Eq, Ord, Show, Enum, Read)
data YearType = Chaser | Ksidran | Shlema
deriving (Eq, Ord, Show, Enum)
data YearLeap = Leap | NonLeap
deriving (Eq, Ord, Show, Enum)
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)
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
lunarMonth :: TotalChalakim
lunarMonth = joinChalakim 0 29 12 793
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
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
_ -> NonLeap
in res
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
monthsTilTishrei :: Years -> Months
monthsTilTishrei (Years i) = Months $ (235 * i 234) `div` 19
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
#if TEST
case_monthsTilTishrei :: Assertion
case_monthsTilTishrei = do
0 @=? monthsTilTishrei 1
12 @=? monthsTilTishrei 2
24 @=? monthsTilTishrei 3
37 @=? monthsTilTishrei 4
235 @=? monthsTilTishrei 20
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
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)
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
prop_dateToFromJulian :: YearLeap -> YearType -> Julian -> Bool
prop_dateToFromJulian yl yt j =
j == uncurry (julianFromDate yl yt) (dateFromJulian yl yt j)
#endif
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
3 -> 1
4 -> 2
5 -> 1
6 -> 2
_ -> error $ "roshHashana: d ==" ++ show d
| d `elem` [0, 3, 5] = 1
| d == 2 &&
isLeapYear y == NonLeap &&
(s > 9 ||
s == 9 && c > 204) = 2
| isLeapYear (y 1) == Leap &&
d == 1 &&
(s > 15 ||
s == 15 && c > 589) = 2
| otherwise = 0
#if TEST
case_firstRoshHashana :: Assertion
case_firstRoshHashana = roshHashana 1 @?= 1
#endif
dayOfWeek :: TotalDays -> Weekday
dayOfWeek t =
let (_, w) = weeksFromDays t
in w
#if TEST
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
| 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
data HebrewDate = HebrewDate
{ year :: Int
, month :: Month
, date :: Int
}
deriving Eq
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)
#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
-> HebrewDate
-> HebrewDate
anniversaryInYear y (HebrewDate _ m d) = clip $ HebrewDate y m d
#if TEST
caseAnniversaryInYear :: IO ()
caseAnniversaryInYear = do
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
-> HebrewDate
-> HebrewDate
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)
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 "caseAnniversaryInYear" caseAnniversaryInYear
, testCase "caseNextAnniversary" caseNextAnniversary
]
instance Arbitrary Chalakim where
coarbitrary = undefined
arbitrary = fromIntegral <$> (arbitrary :: Gen Int)
instance Arbitrary Days where
coarbitrary = undefined
arbitrary = fromIntegral . (+ 1) . (`mod` 353)
<$> (arbitrary :: Gen Int)
instance Arbitrary Years where
coarbitrary = undefined
arbitrary = fromIntegral . (+ 1) . (`mod` 6000)
<$> (arbitrary :: Gen Int)
enumAll :: Enum e => [e]
enumAll = enumFrom $ toEnum 1
instance Arbitrary YearLeap where
coarbitrary = undefined
arbitrary = elements enumAll
instance Arbitrary YearType where
coarbitrary = undefined
arbitrary = elements enumAll
instance Arbitrary HebrewDate where
coarbitrary = undefined
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
instance ConvertSuccess Month String where
convertSuccess = show
instance ConvertAttempt String Month where
convertAttempt s = wrapFailure (\_ -> InvalidHebrewMonth s) $ SF.read s
data InvalidHebrewMonth = InvalidHebrewMonth String
deriving (Show, Typeable)
instance Exception InvalidHebrewMonth