| blob | 519fe1df9df747e588ee20559499f37f12bb74ba |
1 % Copyright (C) 2003 Peter Simons
2 % Copyright (C) 2003,2008 David Roundy
3 %
4 % This program is free software; you can redistribute it and/or modify
5 % it under the terms of the GNU General Public License as published by
6 % the Free Software Foundation; either version 2, or (at your option)
7 % any later version.
8 %
9 % This program is distributed in the hope that it will be useful,
10 % but WITHOUT ANY WARRANTY; without even the implied warranty of
11 % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 % GNU General Public License for more details.
13 %
14 % You should have received a copy of the GNU General Public License
15 % along with this program; see the file COPYING. If not, write to
16 % the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
17 % Boston, MA 02110-1301, USA.
19 This module is intended to provide backwards-compatibility in the parsing
20 of darcs patches. In other words: don't change it, new features don't get
21 added here. The only user should be Darcs.Patch.Info.
23 \begin{code}
24 module OldDate ( readUTCDate, showIsoDateTime ) where
26 import Text.ParserCombinators.Parsec
27 import System.Time
28 import Data.Char ( toUpper, isDigit )
29 import Control.Monad ( liftM, liftM2 )
31 -- | Read/interpret a date string, assuming UTC if timezone
32 -- is not specified in the string
33 readUTCDate :: String -> CalendarTime
34 readUTCDate = readDate 0
36 readDate :: Int -> String -> CalendarTime
37 readDate tz d =
38 case parseDate tz d of
39 Left e -> error e
40 Right ct -> ct
42 parseDate :: Int -> String -> Either String CalendarTime
43 parseDate tz d =
44 if length d >= 14 && and (map isDigit $ take 14 d)
45 then Right $
46 CalendarTime (read $ take 4 d)
47 (toEnum $ (+ (-1)) $ read $ take 2 $ drop 4 d)
48 (read $ take 2 $ drop 6 d) -- Day
49 (read $ take 2 $ drop 8 d) -- Hour
50 (read $ take 2 $ drop 10 d) -- Minute
51 (read $ take 2 $ drop 12 d) -- Second
52 0 Sunday 0 -- Picosecond, weekday and day of year unknown
53 "GMT" 0 False
54 else let dt = do { x <- date_time tz; eof; return x }
55 in case parse dt "" d of
56 Left e -> Left $ "bad date: "++d++" - "++show e
57 Right ct -> Right ct
59 showIsoDateTime :: CalendarTime -> String
60 showIsoDateTime ct = concat [ show $ ctYear ct
61 , twoDigit . show . (+1) . fromEnum $ ctMonth ct
62 , twoDigit . show $ ctDay ct
63 , twoDigit . show $ ctHour ct
64 , twoDigit . show $ ctMin ct
65 , twoDigit . show $ ctSec ct
66 ]
67 where twoDigit [] = undefined
68 twoDigit x@(_:[]) = '0' : x
69 twoDigit x@(_:_:[]) = x
70 twoDigit _ = undefined
72 ----- Parser Combinators ---------------------------------------------
74 -- |Case-insensitive variant of Parsec's 'char' function.
76 caseChar :: Char -> GenParser Char a Char
77 caseChar c = satisfy (\x -> toUpper x == toUpper c)
79 -- |Case-insensitive variant of Parsec's 'string' function.
81 caseString :: String -> GenParser Char a ()
82 caseString cs = mapM_ caseChar cs <?> cs
84 -- |Match a parser at least @n@ times.
86 manyN :: Int -> GenParser a b c -> GenParser a b [c]
87 manyN n p
88 | n <= 0 = return []
89 | otherwise = liftM2 (++) (count n p) (many p)
91 -- |Match a parser at least @n@ times, but no more than @m@ times.
93 manyNtoM :: Int -> Int -> GenParser a b c -> GenParser a b [c]
94 manyNtoM n m p
95 | n < 0 = return []
96 | n > m = return []
97 | n == m = count n p
98 | n == 0 = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m]))
99 | otherwise = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p)
102 ----- Date/Time Parser -----------------------------------------------
104 date_time :: Int -> CharParser a CalendarTime
105 date_time tz =
106 choice [try $ cvs_date_time tz,
107 try $ iso8601_date_time tz,
108 old_date_time]
110 cvs_date_time :: Int -> CharParser a CalendarTime
111 cvs_date_time tz =
112 do y <- year
113 char '/'
114 mon <- month_num
115 char '/'
116 d <- day
117 my_spaces
118 h <- hour
119 char ':'
120 m <- minute
121 char ':'
122 s <- second
123 z <- option tz $ my_spaces >> zone
124 return (CalendarTime y mon d h m s 0 Monday 0 "" z False)
126 old_date_time :: CharParser a CalendarTime
127 old_date_time = do wd <- day_name
128 my_spaces
129 mon <- month_name
130 my_spaces
131 d <- day
132 my_spaces
133 h <- hour
134 char ':'
135 m <- minute
136 char ':'
137 s <- second
138 my_spaces
139 z <- zone
140 my_spaces
141 y <- year
142 return (CalendarTime y mon d h m s 0 wd 0 "" z False)
144 {- FIXME: In case you ever want to use this outside of darcs, you should note
145 that this implementation of ISO 8601 is not complete.
147 reluctant to implement (ambiguous!):
148 * years > 9999
149 * truncated representations with implied century (89 for 1989)
150 unimplemented:
151 * repeated durations (not relevant)
152 * lowest order component fractions in intervals
153 * negative dates (BC)
154 unverified or too relaxed:
155 * the difference between 24h and 0h
156 * allows stuff like 2005-1212; either you use the hyphen all the way
157 (2005-12-12) or you don't use it at all (20051212), but you don't use
158 it halfway, likewise with time
159 * No bounds checking whatsoever on intervals!
160 (next action: read iso doc to see if bounds-checking required?) -}
161 iso8601_date_time :: Int -> CharParser a CalendarTime
162 iso8601_date_time localTz = try $
163 do d <- iso8601_date
164 t <- option id $ try $ do optional $ oneOf " T"
165 iso8601_time
166 return $ t $ d { ctTZ = localTz }
168 iso8601_date :: CharParser a CalendarTime
169 iso8601_date =
170 do d <- calendar_date <|> week_date <|> ordinal_date
171 return $ foldr ($) nullCalendar d
172 where
173 calendar_date = -- yyyy-mm-dd
174 try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ]
175 -- allow other variants to be parsed correctly
176 notFollowedBy (digit <|> char 'W')
177 return d
178 week_date = --yyyy-Www-dd
179 try $ do yfn <- year_
180 optional dash
181 char 'W'
182 -- offset human 'week 1' -> computer 'week 0'
183 w' <- (\x -> x-1) `liftM` two_digits
184 wd <- option 1 $ do { optional dash; n_digits 1 }
185 let y = yfn nullCalendar
186 firstDay = ctWDay y
187 -- things that make this complicated
188 -- 1. iso8601 weeks start from Monday; Haskell weeks start from Sunday
189 -- 2. the first week is the one that contains at least Thursday
190 -- if the year starts after Thursday, then some days of the year
191 -- will have already passed before the first week
192 let afterThursday = firstDay == Sunday || firstDay > Thursday
193 w = if afterThursday then w'+1 else w'
194 diff c = c { ctDay = (7 * w) + wd - (fromEnum firstDay) }
195 return [(toUTCTime.toClockTime.diff.yfn)]
196 ordinal_date = -- yyyy-ddd
197 try $ optchain year_ [ (dash, yearDay_) ]
198 --
199 year_ = try $ do y <- four_digits <?> "year (0000-9999)"
200 return $ \c -> c { ctYear = y }
201 month_ = try $ do m <- two_digits <?> "month (1 to 12)"
202 -- we (artificially) use ctPicosec to indicate
203 -- whether the month has been specified.
204 return $ \c -> c { ctMonth = intToMonth m, ctPicosec = 0 }
205 day_ = try $ do d <- two_digits <?> "day in month (1 to 31)"
206 return $ \c -> c { ctDay = d }
207 yearDay_ = try $ do d <- n_digits 3 <?> "day in year (1 to 366)"
208 return $ \c -> c { ctYDay = d }
209 dash = char '-'
211 -- we return a function which sets the time on another calendar
212 iso8601_time :: CharParser a (CalendarTime -> CalendarTime)
213 iso8601_time = try $
214 do ts <- optchain hour_ [ (colon , min_)
215 , (colon , sec_)
216 , (oneOf ",.", pico_) ]
217 z <- option id $ choice [ zulu , offset ]
218 return $ foldr (.) id (z:ts)
219 where
220 hour_ = do h <- two_digits
221 return $ \c -> c { ctHour = h }
222 min_ = do m <- two_digits
223 return $ \c -> c { ctMin = m }
224 sec_ = do s <- two_digits
225 return $ \c -> c { ctSec = s }
226 pico_ = do digs <- many digit
227 let picoExp = 12
228 digsExp = length digs
229 let frac | null digs = 0
230 | digsExp > picoExp = read $ take picoExp digs
231 | otherwise = 10 ^ (picoExp - digsExp) * (read digs)
232 return $ \c -> c { ctPicosec = frac }
233 zulu = do { char 'Z'; return (\c -> c { ctTZ = 0 }) }
234 offset = do sign <- choice [ do { char '+' >> return 1 }
235 , do { char '-' >> return (-1) } ]
236 h <- two_digits
237 m <- option 0 $ do { optional colon; two_digits }
238 return $ \c -> c { ctTZ = sign * 60 * ((h*60)+m) }
239 colon = char ':'
241 optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b]
242 optchain p next = try $
243 do r1 <- p
244 r2 <- case next of
245 [] -> return []
246 ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 }
247 return (r1:r2)
249 n_digits :: Int -> CharParser a Int
250 n_digits n = read `liftM` count n digit
252 two_digits, four_digits :: CharParser a Int
253 two_digits = n_digits 2
254 four_digits = n_digits 4
256 my_spaces :: CharParser a String
257 my_spaces = manyN 1 $ char ' '
259 day_name :: CharParser a Day
260 day_name = choice
261 [ caseString "Mon" >> return Monday
262 , try (caseString "Tue") >> return Tuesday
263 , caseString "Wed" >> return Wednesday
264 , caseString "Thu" >> return Thursday
265 , caseString "Fri" >> return Friday
266 , try (caseString "Sat") >> return Saturday
267 , caseString "Sun" >> return Sunday
268 ]
270 year :: CharParser a Int
271 year = four_digits
273 month_num :: CharParser a Month
274 month_num = do mn <- manyNtoM 1 2 digit
275 return $ intToMonth $ (read mn :: Int)
277 intToMonth :: Int -> Month
278 intToMonth 1 = January
279 intToMonth 2 = February
280 intToMonth 3 = March
281 intToMonth 4 = April
282 intToMonth 5 = May
283 intToMonth 6 = June
284 intToMonth 7 = July
285 intToMonth 8 = August
286 intToMonth 9 = September
287 intToMonth 10 = October
288 intToMonth 11 = November
289 intToMonth 12 = December
290 intToMonth _ = error "invalid month!"
292 month_name :: CharParser a Month
293 month_name = choice
294 [ try (caseString "Jan") >> return January
295 , caseString "Feb" >> return February
296 , try (caseString "Mar") >> return March
297 , try (caseString "Apr") >> return April
298 , caseString "May" >> return May
299 , try (caseString "Jun") >> return June
300 , caseString "Jul" >> return July
301 , caseString "Aug" >> return August
302 , caseString "Sep" >> return September
303 , caseString "Oct" >> return October
304 , caseString "Nov" >> return November
305 , caseString "Dec" >> return December
306 ]
308 day :: CharParser a Int
309 day = do d <- manyNtoM 1 2 digit
310 return (read d :: Int)
312 hour :: CharParser a Int
313 hour = two_digits
315 minute :: CharParser a Int
316 minute = two_digits
318 second :: CharParser a Int
319 second = two_digits
321 zone :: CharParser a Int
322 zone = choice
323 [ do { char '+'; h <- hour; m <- minute; return (((h*60)+m)*60) }
324 , do { char '-'; h <- hour; m <- minute; return (-((h*60)+m)*60) }
325 , mkZone "UTC" 0
326 , mkZone "UT" 0
327 , mkZone "GMT" 0
328 , mkZone "EST" (-5)
329 , mkZone "EDT" (-4)
330 , mkZone "CST" (-6)
331 , mkZone "CDT" (-5)
332 , mkZone "MST" (-7)
333 , mkZone "MDT" (-6)
334 , mkZone "PST" (-8)
335 , mkZone "PDT" (-7)
336 , mkZone "CEST" 2
337 , mkZone "EEST" 3
338 -- if we don't understand it, just give a GMT answer...
339 , do { manyTill (oneOf $ ['a'..'z']++['A'..'Z']++[' '])
340 (lookAhead space_digit);
341 return 0 }
342 ]
343 where mkZone n o = try $ do { caseString n; return (o*60*60) }
344 space_digit = try $ do { char ' '; oneOf ['0'..'9'] }
346 nullCalendar :: CalendarTime
347 nullCalendar = CalendarTime 0 January 0 0 0 0 1 Sunday 0 "" 0 False
348 \end{code}