1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
{- scheduled activities
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Utility.Scheduled (
Schedule(..),
Recurrance(..),
TimeOfDay(..),
fromSchedule,
toSchedule,
parseSchedule,
prop_schedule_roundtrips
) where
import Common
import Utility.QuickCheck
{- Some sort of scheduled event. -}
data Schedule = Schedule Recurrance TimeOfDay Duration
deriving (Eq, Show, Ord)
data Recurrance
= Daily
| Weekly WeekDay
| Monthly MonthDay
| Yearly YearDay
-- Divisible 3 Daily is every day of the year evenly divisible by 3
| Divisable Int Recurrance
deriving (Eq, Show, Ord)
type WeekDay = Int
type MonthDay = Int
type YearDay = Int
data TimeOfDay
= AnyTime
| Hour Int
deriving (Eq, Show, Ord)
data Duration = MinutesDuration Int
deriving (Eq, Show, Ord)
fromRecurrance :: Recurrance -> String
fromRecurrance (Divisable n r) =
fromRecurrance' (\u -> "on " ++ u ++ "s divisible by " ++ show n) r
fromRecurrance r = fromRecurrance' ("every " ++) r
fromRecurrance' :: (String -> String) -> Recurrance -> String
fromRecurrance' a Daily = a "day"
fromRecurrance' a (Weekly n) = onday n (a "week")
fromRecurrance' a (Monthly n) = onday n (a "month")
fromRecurrance' a (Yearly n) = onday n (a "year")
fromRecurrance' a (Divisable _n r) = fromRecurrance' a r -- not used
onday :: Int -> String -> String
onday n s = s ++ " on day " ++ show n
toRecurrance :: String -> Maybe Recurrance
toRecurrance s = case words s of
("every":something:l) -> parse something l
("on":something:"divisible":"by":sn:l) -> do
r <- parse something l
n <- readish sn
if n > 0
then Just $ Divisable n r
else Nothing
_ -> Nothing
where
parse "day" [] = Just Daily
parse "week" l = withday Weekly l
parse "month" l = withday Monthly l
parse "year" l = withday Yearly l
parse v l
| "s" `isSuffixOf` v = parse (reverse $ drop 1 $ reverse v) l
| otherwise = Nothing
withday a ("on":"day":n:[]) = a <$> readish n
withday _ _ = Nothing
fromTimeOfDay :: TimeOfDay -> String
fromTimeOfDay AnyTime = "any time"
fromTimeOfDay (Hour n) = "hour " ++ show n
toTimeOfDay :: String -> Maybe TimeOfDay
toTimeOfDay s = case words s of
("any":"time":[]) -> Just AnyTime
("hour":n:[]) -> Hour <$> readish n
_ -> Nothing
fromDuration :: Duration -> String
fromDuration (MinutesDuration n) = show n ++ " minutes"
toDuration :: String -> Maybe Duration
toDuration s = case words s of
(n:"minutes":[]) -> MinutesDuration <$> readish n
(n:"minute":[]) -> MinutesDuration <$> readish n
_ -> Nothing
fromSchedule :: Schedule -> String
fromSchedule (Schedule recurrance timeofday duration) = unwords
[ fromRecurrance recurrance
, "at"
, fromTimeOfDay timeofday
, "for"
, fromDuration duration
]
toSchedule :: String -> Maybe Schedule
toSchedule = eitherToMaybe . parseSchedule
parseSchedule :: String -> Either String Schedule
parseSchedule s = do
r <- maybe (Left $ "bad recurrance: " ++ recurrance) Right
(toRecurrance recurrance)
t <- maybe (Left $ "bad time of day: " ++ timeofday) Right
(toTimeOfDay timeofday)
d <- maybe (Left $ "bad duration: " ++ duration) Right
(toDuration duration)
Right $ Schedule r t d
where
ws = words s
(rws, ws') = separate (== "at") ws
(tws, dws) = separate (== "for") ws'
recurrance = unwords rws
timeofday = unwords tws
duration = unwords dws
instance Arbitrary Schedule where
arbitrary = Schedule <$> arbitrary <*> arbitrary <*> arbitrary
instance Arbitrary Duration where
arbitrary = MinutesDuration <$> nonNegative arbitrary
instance Arbitrary TimeOfDay where
arbitrary = oneof
[ pure AnyTime
, Hour <$> nonNegative arbitrary
]
instance Arbitrary Recurrance where
arbitrary = oneof
[ pure Daily
, Weekly <$> nonNegative arbitrary
, Monthly <$> nonNegative arbitrary
, Yearly <$> nonNegative arbitrary
, Divisable
<$> positive arbitrary
<*> oneof -- no nested Divisibles
[ pure Daily
, Weekly <$> nonNegative arbitrary
, Monthly <$> nonNegative arbitrary
, Yearly <$> nonNegative arbitrary
]
]
prop_schedule_roundtrips :: Schedule -> Bool
prop_schedule_roundtrips s = case toSchedule $ fromSchedule s of
Just s' | s == s' -> True
_ -> False
|
