diff --git a/Data/Time/Calendar/Hebrew.hs b/Data/Time/Calendar/Hebrew.hs --- a/Data/Time/Calendar/Hebrew.hs +++ b/Data/Time/Calendar/Hebrew.hs @@ -1,4 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE CPP #-} --------------------------------------------------------- -- -- Module : Data.Time.Calendar.Hebrew @@ -17,23 +21,34 @@ , Month (..) , fromHebrew , toHebrew + -- * Anniversaries + , anniversaryInYear + , nextAnniversary +#if TEST -- * Testing , 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 -import Data.ByteString.Class ------ data definitions data Month = Tishrei | Cheshvan | Kislev | Tevet | Shevat @@ -45,6 +60,27 @@ data YearLeap = Leap | NonLeap deriving (Eq, Ord, Show, Enum) +{- FIXME use some translation package +instance CanTranslate Month where + tryTranslate x "en" = Just $ convertSuccess $ show x + tryTranslate Tishrei "he" = Just "תשרי" + tryTranslate Cheshvan "he" = Just "חשון" + tryTranslate Kislev "he" = Just "כסלו" + tryTranslate Tevet "he" = Just "טבת" + tryTranslate Shevat "he" = Just "שבט" + tryTranslate Adar "he" = Just "אדר" + tryTranslate Adar1 "he" = Just "אדר א" + tryTranslate Adar2 "he" = Just "אדר ב" + tryTranslate Nissan "he" = Just "ניסן" + tryTranslate Iyar "he" = Just "אייר" + tryTranslate Sivan "he" = Just "סיון" + tryTranslate Tammuz "he" = Just "תמוז" + tryTranslate Av "he" = Just "אב" + tryTranslate Elul "he" = Just "אלול" + + defaultTranslate = convertSuccess . show +-} + ------ newtypes newtype Chalakim = Chalakim Integer deriving (Eq, Ord, Show, Enum, Num, Real, Integral) @@ -103,20 +139,24 @@ (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 @@ -167,6 +207,7 @@ extra = extraMonthCount $ Years y in base + extra +#if TEST case_monthsTilTishrei :: Assertion case_monthsTilTishrei = do 0 @=? monthsTilTishrei 1 @@ -177,6 +218,7 @@ prop_monthsTilTishrei :: Years -> Bool prop_monthsTilTishrei y = monthsTilTishrei y == monthsTilTishreiLong y +#endif firstTishrei :: TotalChalakim firstTishrei = joinChalakim 0 1 5 204 @@ -184,6 +226,7 @@ moladTishrei :: Years -> TotalChalakim moladTishrei y = chalakimFromMonths (monthsTilTishrei y) + firstTishrei +#if TEST case_moladTishrei :: Assertion case_moladTishrei = do let testMolad w x y z = do @@ -204,6 +247,7 @@ testMolad 18 0 15 414 testMolad 19 5 0 210 testMolad 20 3 21 799 +#endif monthLength :: YearLeap -> YearType -> Month -> Days monthLength _ _ Tishrei = 30 @@ -246,9 +290,11 @@ | 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 ------ determining year stuff roshHashana :: Years -> TotalDays @@ -277,24 +323,30 @@ 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 @@ -309,8 +361,10 @@ 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 @@ -358,6 +412,7 @@ 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' @@ -385,7 +440,66 @@ 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 -- ^ 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) + ------ testing testSuite :: Test testSuite = testGroup "Data.Time.Calendar.Hebrew" @@ -403,6 +517,8 @@ , 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 @@ -438,20 +554,13 @@ y <- (+ 1) . (`mod` 6000) <$> arbitrary day <- (+ 1) . (`mod` 29) <$> arbitrary return $! HebrewDate y m day +#endif ------ Data.Object instances -instance ToScalar Month where - toScalar = toScalar . show -instance ToObject Month where - toObject = toObject . toScalar -readM :: (Read r, Monad m) => String -> m r -readM s = case reads s of - ((x, _):_) -> return x - _ -> fail $ "Unable to read: " ++ s -instance FromScalar Month where - fromScalar bs = - case readM $ fromLazyByteString bs of - Just x -> return x - Nothing -> fail $ "Invalid hebrew month: " ++ fromLazyByteString bs -instance FromObject Month where - fromObject o = fromObject o >>= fromScalar +----- Data.Object.Text instances +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 diff --git a/hebrew-time.cabal b/hebrew-time.cabal --- a/hebrew-time.cabal +++ b/hebrew-time.cabal @@ -1,5 +1,5 @@ name: hebrew-time -version: 0.0.0 +version: 0.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -12,15 +12,29 @@ build-type: Simple homepage: http://github.com/snoyberg/hebrew-time/tree/master +flag buildtests + description: Build the executable to run unit tests + default: False + library build-depends: base >= 4 && < 5, - time >= 1.1.3, - test-framework, - test-framework-quickcheck, - test-framework-hunit, - HUnit, - QuickCheck >= 1 && < 2, - bytestring-class, - data-object >= 0.0.2 + time >= 1.1.3 && < 1.2, + data-object >= 0.2.0 && < 0.3, + failure >= 0.0.0 && < 0.1, + safe-failure >= 0.4.0 && < 0.5 exposed-modules: Data.Time.Calendar.Hebrew ghc-options: -Wall + +executable runtests + if flag(buildtests) + Buildable: True + cpp-options: -DTEST + build-depends: test-framework, + test-framework-quickcheck, + test-framework-hunit, + HUnit, + QuickCheck >= 1 && < 2 + else + Buildable: False + ghc-options: -Wall + main-is: runtests.hs diff --git a/runtests.hs b/runtests.hs new file mode 100644 --- /dev/null +++ b/runtests.hs @@ -0,0 +1,8 @@ +import Test.Framework (defaultMain) + +import qualified Data.Time.Calendar.Hebrew + +main :: IO () +main = defaultMain + [ Data.Time.Calendar.Hebrew.testSuite + ]