Update documentation a bit.
[todos:todos.git] / Todos / Dates.hs
1 {-# LANGUAGE UnicodeSyntax #-}
2 -- | Operations with dates
3 module Todos.Dates
4   (parseDate, getCurrentDateTime,
5    pSpecDates)
6   where
7
8 import Data.Char (toUpper)
9 import Data.Function (on)
10 import Data.List
11 import Data.Time.Calendar
12 import Data.Time.Clock
13 import Data.Time.LocalTime
14 import Text.ParserCombinators.Parsec
15
16 import Todos.Types
17 import Todos.Unicode
18 import Todos.Config
19 import Todos.ParserTypes
20
21 getCurrentDateTime ∷  IO DateTime
22 getCurrentDateTime = do
23   zt ← getZonedTime
24   let lt = zonedTimeToLocalTime zt
25       ld = localDay lt
26       ltod = localTimeOfDay lt
27       (y,m,d) = toGregorian ld
28       h = todHour ltod
29       min = todMin ltod
30       s = round $ todSec ltod
31   return $ DateTime (fromIntegral y) m d h min s
32
33 uppercase ∷ String → String
34 uppercase = map toUpper
35
36 isPrefixOfI ∷  String → String → Bool
37 p `isPrefixOfI` s = (uppercase p) `isPrefixOf` (uppercase s)
38
39 lookupS ∷ String → [(String,a)] → Maybe a
40 lookupS _ [] = Nothing
41 lookupS k ((k',v):other) | k `isPrefixOfI` k' = Just v
42                          | otherwise          = lookupS k other
43
44 monthsN ∷ [(String,Int)]
45 monthsN = zip months [1..]
46
47 lookupMonth ∷ String → Maybe Int
48 lookupMonth n = lookupS n monthsN
49
50 date ∷  Int → Int → Int → DateTime
51 date y m d = DateTime y m d 0 0 0
52
53 addTime ∷  DateTime → Time → DateTime
54 addTime dt t = dt {
55                  hour = tHour t + hour dt,
56                  minute = tMinute t + minute dt,
57                  second = tSecond t + second dt }
58
59 times ∷ Int → TParser t → TParser [t]
60 times 0 _ = return []
61 times n p = do
62   ts ← times (n-1) p
63   t ← optionMaybe p
64   case t of
65     Just t' → return (ts ++ [t'])
66     Nothing → return ts
67                                
68 number ∷ Int → Int → TParser Int
69 number n m = do
70   t ← read `fmap` (n `times` digit)
71   if t > m
72     then fail "number too large"
73     else return t
74
75 pYear ∷ TParser Int
76 pYear = do
77   y ← number 4 10000
78   if y < 2000
79     then return (y+2000)
80     else return y
81
82 pMonth ∷ TParser Int
83 pMonth = number 2 12
84
85 pDay ∷ TParser Int
86 pDay = number 2 31
87
88 euroNumDate ∷ TParser DateTime
89 euroNumDate = do
90   d ← pDay
91   char '.'
92   m ← pMonth
93   char '.'
94   y ← pYear
95   return $ date y m d
96
97 americanDate ∷ TParser DateTime
98 americanDate = do
99   y ← pYear
100   char '/'
101   m ← pMonth
102   char '/'
103   d ← pDay
104   return $ date y m d
105
106 euroNumDate' ∷ Int → TParser DateTime
107 euroNumDate' year = do
108   d ← pDay
109   char '.'
110   m ← pMonth
111   return $ date year m d
112
113 americanDate' ∷ Int → TParser DateTime
114 americanDate' year = do
115   m ← pMonth
116   char '/'
117   d ← pDay
118   return $ date year m d
119
120 strDate ∷ TParser DateTime
121 strDate = do
122   d ← pDay
123   space
124   ms ← many1 letter
125   case lookupMonth ms of
126     Nothing → fail $ "unknown month: "++ms
127     Just m  → do
128       space
129       y ← pYear
130       notFollowedBy $ char ':'
131       return $ date y m d
132
133 strDate' ∷ Int → TParser DateTime
134 strDate' year = do
135   d ← pDay
136   space
137   ms ← many1 letter
138   case lookupMonth ms of
139     Nothing → fail $ "unknown month: "++ms
140     Just m  → return $ date year m d
141
142 time24 ∷ TParser Time
143 time24 = do
144   h ← number 2 23
145   char ':'
146   m ← number 2 59
147   x ← optionMaybe $ char ':'
148   case x of
149     Nothing → return $ Time h m 0
150     Just _ → do
151       s ← number 2 59
152       notFollowedBy letter
153       return $ Time h m s
154
155 ampm ∷ TParser Int
156 ampm = do
157   s ← many1 letter
158   case map toUpper s of
159     "AM" → return 0
160     "PM" → return 12
161     _ → fail "AM/PM expected"
162
163 time12 ∷ TParser Time
164 time12 = do
165   h ← number 2 12
166   char ':'
167   m ← number 2 59
168   x ← optionMaybe $ char ':'
169   s ← case x of
170             Nothing → return 0
171             Just s' → number 2 59
172   optional space
173   hd ← ampm
174   return $ Time (h+hd) m s
175
176 pAbsDate ∷ Int → TParser DateTime
177 pAbsDate year = do
178   date ← choice $ map try $ map ($ year) $ [
179                               const euroNumDate,
180                               const americanDate,
181                               const strDate,
182                               strDate',
183                               euroNumDate',
184                               americanDate']
185   optional $ char ','
186   s ← optionMaybe space
187   case s of
188     Nothing → return date
189     Just _ → do
190       t ← choice $ map try [time12,time24]
191       return $ date `addTime` t
192
193 data DateIntervalType = Day | Week | Month | Year
194   deriving (Eq,Show,Read)
195
196 data DateInterval = Days ℤ
197                   | Weeks ℤ
198                   | Months ℤ
199                   | Years ℤ
200   deriving (Eq,Show)
201
202 convertTo ∷  DateTime → Day
203 convertTo dt = fromGregorian (fromIntegral $ year dt) (month dt) (day dt)
204
205 convertFrom ∷  Day → DateTime
206 convertFrom dt = 
207   let (y,m,d) = toGregorian dt
208   in  date (fromIntegral y) m d
209
210 modifyDate ∷  (t → Day → Day) → t → DateTime → DateTime
211 modifyDate fn x dt = convertFrom $ fn x $ convertTo dt
212
213 addInterval ∷  DateTime → DateInterval → DateTime
214 addInterval dt (Days ds) = modifyDate addDays ds dt
215 addInterval dt (Weeks ws) = modifyDate addDays (ws*7) dt
216 addInterval dt (Months ms) = modifyDate addGregorianMonthsClip ms dt
217 addInterval dt (Years ys) = modifyDate addGregorianYearsClip ys dt
218
219 maybePlural ∷ String → TParser String
220 maybePlural str = do
221   r ← string str
222   optional $ char 's'
223   return (capitalize r)
224
225 pDateInterval ∷ TParser DateIntervalType
226 pDateInterval = do
227   s ← choice $ map maybePlural ["day", "week", "month", "year"]
228   return $ read s
229
230 pRelDate ∷ DateTime → TParser DateTime
231 pRelDate date = do
232   offs ← (try futureDate) <|> (try passDate) <|> (try today) <|> (try tomorrow) <|> yesterday
233   return $ date `addInterval` offs
234
235 futureDate ∷ TParser DateInterval
236 futureDate = do
237   string "in "
238   n ← many1 digit
239   char ' '
240   tp ← pDateInterval
241   case tp of
242     Day →   return $ Days (read n)
243     Week →  return $ Weeks (read n)
244     Month → return $ Months (read n)
245     Year →  return $ Years (read n)
246
247 passDate ∷ TParser DateInterval
248 passDate = do
249   n ← many1 digit
250   char ' '
251   tp ← pDateInterval
252   string " ago"
253   case tp of
254     Day →   return $ Days $ - (read n)
255     Week →  return $ Weeks $ - (read n)
256     Month → return $ Months $ - (read n)
257     Year →  return $ Years $ - (read n)
258
259 today ∷ TParser DateInterval
260 today = do
261   string "today"
262   return $ Days 0
263
264 tomorrow ∷ TParser DateInterval
265 tomorrow = do
266   string "tomorrow"
267   return $ Days 1
268
269 yesterday ∷ TParser DateInterval
270 yesterday = do
271   string "yesterday"
272   return $ Days (-1)
273
274 pDate ∷ DateTime → TParser DateTime
275 pDate date =  (try $ pRelDate date) <|> (try $ pAbsDate $ year date)
276
277 dateType ∷ String → DateType
278 dateType "start" = StartDate
279 dateType "end"   = EndDate
280 dateType "deadline" = Deadline
281 dateType _ = error "unknown date type"
282
283 -- | Parse date/time with date type
284 pSpecDate ∷ DateTime → TParser (DateType, DateTime)
285 pSpecDate date = do
286   tp ← choice $ map string ["start","end","deadline"]
287   string ": "
288   dt ← pDate date
289   return (dateType tp, dt)
290
291 -- | Parse set of dates with types (in parenthesis)
292 pSpecDates ∷ DateTime → TParser [(DateType, DateTime)]
293 pSpecDates date = do
294   char '('
295   pairs ← (pSpecDate date) `sepBy1` (string "; ")
296   string ") "
297   return pairs
298
299 -- | Parse date/time
300 parseDate ∷ BaseConfig
301           → DateTime  -- ^ Current date/time
302           → String    -- ^ String to parse
303           → Either ParseError DateTime
304 parseDate conf date s = runParser (pDate date) conf "" s
305