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
162
163
164
165
166
167
168
169
170
|
{- scheduled activities
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Utility.Scheduled (
Schedule(..),
Recurrance(..),
TimeOfDay(..),
Duration(..),
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
| Divisable Int Recurrance
deriving (Eq, Show, Ord)
type WeekDay = Int
type MonthDay = Int
type YearDay = Int
data TimeOfDay
= AnyTime
| SpecificTime Hour Minute
deriving (Eq, Show, Ord)
type Hour = Int
type Minute = Int
data Duration = MinutesDuration Int
deriving (Eq, Show, Ord)
fromRecurrance :: Recurrance -> String
fromRecurrance (Divisable n r) =
fromRecurrance' (++ "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 = "on day " ++ show n ++ " of " ++ s
toRecurrance :: String -> Maybe Recurrance
toRecurrance s = case words s of
("every":"day":[]) -> Just Daily
("on":"day":sd:"of":"every":something:[]) -> parse something sd
("days":"divisible":"by":sn:[]) ->
Divisable <$> getdivisor sn <*> pure Daily
("on":"day":sd:"of":something:"divisible":"by":sn:[]) ->
Divisable
<$> getdivisor sn
<*> parse something sd
_ -> Nothing
where
parse "week" sd = withday Weekly sd
parse "month" sd = withday Monthly sd
parse "year" sd = withday Yearly sd
parse v sd
| "s" `isSuffixOf` v = parse (reverse $ drop 1 $ reverse v) sd
| otherwise = Nothing
withday c sd = c <$> readish sd
getdivisor sn = do
n <- readish sn
if n > 0
then Just n
else Nothing
fromTimeOfDay :: TimeOfDay -> String
fromTimeOfDay AnyTime = "any time"
fromTimeOfDay (SpecificTime h m) = show h ++ ":" ++ show m
toTimeOfDay :: String -> Maybe TimeOfDay
toTimeOfDay "any time" = Just AnyTime
toTimeOfDay s =
let (h, m) = separate (== ':') s
in SpecificTime <$> readish h <*> readish m
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
, SpecificTime
<$> nonNegative arbitrary
<*> 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
|
