hebrew-time 0.0.0 → 0.0.1

raw patch · 3 files changed

+157/−26 lines, 3 filesdep +failuredep +safe-failuredep −bytestring-classdep ~data-objectdep ~timenew-component:exe:runtestsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: failure, safe-failure

Dependencies removed: bytestring-class

Dependency ranges changed: data-object, time

API changes (from Hackage documentation)

Files

• Data/Time/Calendar/Hebrew.hs +126/−17
• hebrew-time.cabal +23/−9
• runtests.hs +8/−0

@@ -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

@@ -1,5 +1,5 @@ name:            hebrew-time-version:         0.0.0+version:         0.0.1 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -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

@@ -0,0 +1,8 @@+import Test.Framework (defaultMain)++import qualified Data.Time.Calendar.Hebrew++main :: IO ()+main = defaultMain+    [ Data.Time.Calendar.Hebrew.testSuite+    ]