new Data.Week module with DayOfWeek type (#69)
authorAshley Yakeley <ashley@semantic.org>
Wed, 10 Jan 2018 01:45:10 +0000 (17:45 -0800)
committerAshley Yakeley <ashley@semantic.org>
Wed, 10 Jan 2018 01:45:10 +0000 (17:45 -0800)
changelog.md
lib/Data/Time/Calendar.hs
lib/Data/Time/Calendar/Week.hs [new file with mode: 0644]
test/main/Main.hs
test/main/Test/Calendar/Week.hs [new file with mode: 0644]
time.cabal

index 4d23862..f25554b 100644 (file)
@@ -1,6 +1,7 @@
 # Change Log
 
 ## [1.9]
+- new Data.Week module with DayOfWeek type
 - parseTimeM: use MonadFail constraint when supported
 
 ## [1.8.0.4]
index 92029fa..f211409 100644 (file)
@@ -1,9 +1,11 @@
 module Data.Time.Calendar
 (
     module Data.Time.Calendar.Days,
-    module Data.Time.Calendar.Gregorian
+    module Data.Time.Calendar.Gregorian,
+    module Data.Time.Calendar.Week
 ) where
 
 import Data.Time.Calendar.Days
 import Data.Time.Calendar.Gregorian
+import Data.Time.Calendar.Week
 import Data.Time.Format()
diff --git a/lib/Data/Time/Calendar/Week.hs b/lib/Data/Time/Calendar/Week.hs
new file mode 100644 (file)
index 0000000..c3ea05e
--- /dev/null
@@ -0,0 +1,43 @@
+module Data.Time.Calendar.Week where
+
+import Data.Time.Calendar.Days
+
+data DayOfWeek
+    = Monday
+    | Tuesday
+    | Wednesday
+    | Thursday
+    | Friday
+    | Saturday
+    | Sunday
+    deriving (Eq, Show, Read)
+
+-- | As an enumeration 'DayOfWeek' is \"circular\", so for example @[Tuesday ..]@ will give an endless sequence.
+-- 'toEnum' gives [1 .. 7] for [Monday .. Sunday].
+-- 'fromEnum' performs mod 7 to give a cycle of days.
+instance Enum DayOfWeek where
+    toEnum i =
+        case mod i 7 of
+            0 -> Sunday
+            1 -> Monday
+            2 -> Tuesday
+            3 -> Wednesday
+            4 -> Thursday
+            5 -> Friday
+            _ -> Saturday
+    fromEnum Monday = 1
+    fromEnum Tuesday = 2
+    fromEnum Wednesday = 3
+    fromEnum Thursday = 4
+    fromEnum Friday = 5
+    fromEnum Saturday = 6
+    fromEnum Sunday = 7
+    enumFromTo wd1 wd2
+        | wd1 == wd2 = [wd1]
+    enumFromTo wd1 wd2 = wd1 : enumFromTo (succ wd1) wd2
+    enumFromThenTo wd1 wd2 wd3
+        | wd2 == wd3 = [wd1, wd2]
+    enumFromThenTo wd1 wd2 wd3 = wd1 : enumFromThenTo wd2 (toEnum $ (2 * fromEnum wd2) - (fromEnum wd1)) wd3
+
+dayOfWeek :: Day -> DayOfWeek
+dayOfWeek (ModifiedJulianDay d) = toEnum $ fromInteger $ d + 3
index 23621d3..a8f4cc5 100644 (file)
@@ -9,6 +9,7 @@ import Test.Calendar.Easter
 import Test.Calendar.LongWeekYears
 import Test.Calendar.MonthDay
 import Test.Calendar.Valid
+import Test.Calendar.Week
 import Test.Clock.Conversion
 import Test.Clock.Resolution
 import Test.Clock.TAI
@@ -27,7 +28,8 @@ tests = testGroup "Time" [
         longWeekYears,
         testMonthDay,
         testEaster,
-        testValid
+        testValid,
+        testWeek
         ],
     testGroup "Clock" [
         testClockConversion,
diff --git a/test/main/Test/Calendar/Week.hs b/test/main/Test/Calendar/Week.hs
new file mode 100644 (file)
index 0000000..0da4d2c
--- /dev/null
@@ -0,0 +1,93 @@
+module Test.Calendar.Week
+    ( testWeek
+    ) where
+
+import Data.Time.Calendar
+import Data.Time.Calendar.WeekDate
+import Test.Tasty
+import Test.Tasty.HUnit
+
+testDay :: TestTree
+testDay =
+    testCase "day" $ do
+        let day = fromGregorian 2018 1 9
+        assertEqual "" (ModifiedJulianDay 58127) day
+        assertEqual "" (2018, 2, 2) $ toWeekDate day
+        assertEqual "" Tuesday $ dayOfWeek day
+
+allDaysOfWeek :: [DayOfWeek]
+allDaysOfWeek = [Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday]
+
+testAllDays :: String -> (DayOfWeek -> IO ()) -> TestTree
+testAllDays name f = testGroup name $ fmap (\wd -> testCase (show wd) $ f wd) allDaysOfWeek
+
+testSucc :: TestTree
+testSucc = testAllDays "succ" $ \wd -> assertEqual "" (toEnum $ succ $ fromEnum wd) $ succ wd
+
+testPred :: TestTree
+testPred = testAllDays "pred" $ \wd -> assertEqual "" (toEnum $ pred $ fromEnum wd) $ pred wd
+
+testSequences :: TestTree
+testSequences =
+    testGroup
+        "sequence"
+        [ testCase "[Monday .. Sunday]" $ assertEqual "" allDaysOfWeek [Monday .. Sunday]
+        , testCase "[Wednesday .. Wednesday]" $ assertEqual "" [Wednesday] [Wednesday .. Wednesday]
+        , testCase "[Sunday .. Saturday]" $
+          assertEqual "" [Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday] [Sunday .. Saturday]
+        , testCase "[Thursday .. Wednesday]" $
+          assertEqual "" [Thursday, Friday, Saturday, Sunday, Monday, Tuesday, Wednesday] [Thursday .. Wednesday]
+        , testCase "[Tuesday ..]" $
+          assertEqual
+              ""
+              [ Tuesday
+              , Wednesday
+              , Thursday
+              , Friday
+              , Saturday
+              , Sunday
+              , Monday
+              , Tuesday
+              , Wednesday
+              , Thursday
+              , Friday
+              , Saturday
+              , Sunday
+              , Monday
+              , Tuesday
+              ] $
+          take 15 [Tuesday ..]
+        , testCase "[Wednesday, Tuesday ..]" $
+          assertEqual
+              ""
+              [ Wednesday
+              , Tuesday
+              , Monday
+              , Sunday
+              , Saturday
+              , Friday
+              , Thursday
+              , Wednesday
+              , Tuesday
+              , Monday
+              , Sunday
+              , Saturday
+              , Friday
+              , Thursday
+              , Wednesday
+              ] $
+          take 15 [Wednesday,Tuesday ..]
+        , testCase "[Sunday, Friday ..]" $
+          assertEqual "" [Sunday, Friday, Wednesday, Monday, Saturday, Thursday, Tuesday, Sunday] $
+          take 8 [Sunday,Friday ..]
+        , testCase "[Monday,Sunday .. Tuesday]" $
+          assertEqual "" [Monday, Sunday, Saturday, Friday, Thursday, Wednesday, Tuesday] [Monday,Sunday .. Tuesday]
+        , testCase "[Thursday, Saturday .. Tuesday]" $
+          assertEqual "" [Thursday, Saturday, Monday, Wednesday, Friday, Sunday, Tuesday] [Thursday,Saturday .. Tuesday]
+        ]
+
+testReadShow :: TestTree
+testReadShow = testAllDays "read show" $ \wd -> assertEqual "" wd $ read $ show wd
+
+testWeek :: TestTree
+testWeek = testGroup "Week" [testDay, testSucc, testPred, testSequences, testReadShow]
index d3befb8..055dc27 100644 (file)
@@ -56,6 +56,7 @@ library
         build-depends: Win32
     exposed-modules:
         Data.Time.Calendar,
+        Data.Time.Calendar.Week,
         Data.Time.Calendar.MonthDay,
         Data.Time.Calendar.OrdinalDate,
         Data.Time.Calendar.WeekDate,
@@ -151,6 +152,7 @@ test-suite test-main
         Test.Calendar.MonthDay
         Test.Calendar.MonthDayRef
         Test.Calendar.Valid
+        Test.Calendar.Week
         Test.Clock.Conversion
         Test.Clock.Resolution
         Test.Clock.TAI