1{-# OPTIONS -fno-warn-orphans #-} 2module Data.Time.Format.Parse.Instances() where 3 4#if !MIN_VERSION_base(4,8,0) 5import Control.Applicative ((<$>),(<*>)) 6#endif 7import Data.Char 8import Data.Fixed 9import Data.List 10import Data.Ratio 11import Data.Traversable 12import Text.Read(readMaybe) 13import Data.Time.Clock.Internal.DiffTime 14import Data.Time.Clock.Internal.NominalDiffTime 15import Data.Time.Clock.Internal.UniversalTime 16import Data.Time.Clock.POSIX 17import Data.Time.Clock.Internal.UTCTime 18import Data.Time.Calendar.Days 19import Data.Time.Calendar.Gregorian 20import Data.Time.Calendar.CalendarDiffDays 21import Data.Time.Calendar.OrdinalDate 22import Data.Time.Calendar.WeekDate 23import Data.Time.Calendar.Private(clipValid) 24import Data.Time.LocalTime.Internal.CalendarDiffTime 25import Data.Time.LocalTime.Internal.TimeZone 26import Data.Time.LocalTime.Internal.TimeOfDay 27import Data.Time.LocalTime.Internal.LocalTime 28import Data.Time.LocalTime.Internal.ZonedTime 29import Data.Time.Format.Locale 30import Data.Time.Format.Parse.Class 31 32data DayComponent = Century Integer -- century of all years 33 | CenturyYear Integer -- 0-99, last two digits of both real years and week years 34 | YearMonth Int -- 1-12 35 | MonthDay Int -- 1-31 36 | YearDay Int -- 1-366 37 | WeekDay Int -- 1-7 (mon-sun) 38 | YearWeek WeekType Int -- 1-53 or 0-53 39 40data WeekType = ISOWeek | SundayWeek | MondayWeek 41 42instance ParseTime Day where 43 substituteTimeSpecifier _ = timeSubstituteTimeSpecifier 44 parseTimeSpecifier _ = timeParseTimeSpecifier 45 buildTime l = let 46 47 -- 'Nothing' indicates a parse failure, 48 -- while 'Just []' means no information 49 f :: Char -> String -> Maybe [DayComponent] 50 f c x = let 51 ra :: (Read a) => Maybe a 52 ra = readMaybe x 53 54 zeroBasedListIndex :: [String] -> Maybe Int 55 zeroBasedListIndex ss = elemIndex (map toUpper x) $ fmap (map toUpper) ss 56 57 oneBasedListIndex :: [String] -> Maybe Int 58 oneBasedListIndex ss = do 59 index <- zeroBasedListIndex ss 60 return $ 1 + index 61 62 in case c of 63 -- %C: century (all but the last two digits of the year), 00 - 99 64 'C' -> do 65 a <- ra 66 return [Century a] 67 -- %f century (all but the last two digits of the year), 00 - 99 68 'f' -> do 69 a <- ra 70 return [Century a] 71 -- %Y: year 72 'Y' -> do 73 a <- ra 74 return [Century (a `div` 100), CenturyYear (a `mod` 100)] 75 -- %G: year for Week Date format 76 'G' -> do 77 a <- ra 78 return [Century (a `div` 100), CenturyYear (a `mod` 100)] 79 -- %y: last two digits of year, 00 - 99 80 'y' -> do 81 a <- ra 82 return [CenturyYear a] 83 -- %g: last two digits of year for Week Date format, 00 - 99 84 'g' -> do 85 a <- ra 86 return [CenturyYear a] 87 -- %B: month name, long form (fst from months locale), January - December 88 'B' -> do 89 a <- oneBasedListIndex $ fmap fst $ months l 90 return [YearMonth a] 91 -- %b: month name, short form (snd from months locale), Jan - Dec 92 'b' -> do 93 a <- oneBasedListIndex $ fmap snd $ months l 94 return [YearMonth a] 95 -- %m: month of year, leading 0 as needed, 01 - 12 96 'm' -> do 97 raw <- ra 98 a <- clipValid 1 12 raw 99 return [YearMonth a] 100 -- %d: day of month, leading 0 as needed, 01 - 31 101 'd' -> do 102 raw <- ra 103 a <- clipValid 1 31 raw 104 return [MonthDay a] 105 -- %e: day of month, leading space as needed, 1 - 31 106 'e' -> do 107 raw <- ra 108 a <- clipValid 1 31 raw 109 return [MonthDay a] 110 -- %V: week for Week Date format, 01 - 53 111 'V' -> do 112 raw <- ra 113 a <- clipValid 1 53 raw 114 return [YearWeek ISOWeek a] 115 -- %U: week number of year, where weeks start on Sunday (as sundayStartWeek), 00 - 53 116 'U' -> do 117 raw <- ra 118 a <- clipValid 0 53 raw 119 return [YearWeek SundayWeek a] 120 -- %W: week number of year, where weeks start on Monday (as mondayStartWeek), 00 - 53 121 'W' -> do 122 raw <- ra 123 a <- clipValid 0 53 raw 124 return [YearWeek MondayWeek a] 125 -- %u: day for Week Date format, 1 - 7 126 'u' -> do 127 raw <- ra 128 a <- clipValid 1 7 raw 129 return [WeekDay a] 130 -- %a: day of week, short form (snd from wDays locale), Sun - Sat 131 'a' -> do 132 a' <- zeroBasedListIndex $ fmap snd $ wDays l 133 let a = if a' == 0 then 7 else a' 134 return [WeekDay a] 135 -- %A: day of week, long form (fst from wDays locale), Sunday - Saturday 136 'A' -> do 137 a' <- zeroBasedListIndex $ fmap fst $ wDays l 138 let a = if a' == 0 then 7 else a' 139 return [WeekDay a] 140 -- %w: day of week number, 0 (= Sunday) - 6 (= Saturday) 141 'w' -> do 142 raw <- ra 143 a' <- clipValid 0 6 raw 144 let a = if a' == 0 then 7 else a' 145 return [WeekDay a] 146 -- %j: day of year for Ordinal Date format, 001 - 366 147 'j' -> do 148 raw <- ra 149 a <- clipValid 1 366 raw 150 return [YearDay a] 151 -- unrecognised, pass on to other parsers 152 _ -> return [] 153 154 buildDay :: [DayComponent] -> Maybe Day 155 buildDay cs = let 156 safeLast x xs = last (x:xs) 157 y = let 158 d = safeLast 70 [x | CenturyYear x <- cs] 159 c = safeLast (if d >= 69 then 19 else 20) [x | Century x <- cs] 160 in 100 * c + d 161 rest (YearMonth m:_) = let 162 d = safeLast 1 [x | MonthDay x <- cs] 163 in fromGregorianValid y m d 164 rest (YearDay d:_) = fromOrdinalDateValid y d 165 rest (YearWeek wt w:_) = let 166 d = safeLast 4 [x | WeekDay x <- cs] 167 in case wt of 168 ISOWeek -> fromWeekDateValid y w d 169 SundayWeek -> fromSundayStartWeekValid y w (d `mod` 7) 170 MondayWeek -> fromMondayStartWeekValid y w d 171 rest (_:xs) = rest xs 172 rest [] = rest [YearMonth 1] 173 174 in rest cs 175 176 in \pairs -> do 177 components <- for pairs $ \(c,x) -> f c x 178 buildDay $ concat components 179 180mfoldl :: (Monad m) => (a -> b -> m a) -> m a -> [b] -> m a 181mfoldl f = let 182 mf ma b = do 183 a <- ma 184 f a b 185 in foldl mf 186 187instance ParseTime TimeOfDay where 188 substituteTimeSpecifier _ = timeSubstituteTimeSpecifier 189 parseTimeSpecifier _ = timeParseTimeSpecifier 190 buildTime l = let 191 f t@(TimeOfDay h m s) (c,x) = let 192 ra :: (Read a) => Maybe a 193 ra = readMaybe x 194 195 getAmPm = let 196 upx = map toUpper x 197 (amStr,pmStr) = amPm l 198 in if upx == amStr 199 then Just $ TimeOfDay (h `mod` 12) m s 200 else if upx == pmStr 201 then Just $ TimeOfDay (if h < 12 then h + 12 else h) m s 202 else Nothing 203 204 in case c of 205 'P' -> getAmPm 206 'p' -> getAmPm 207 'H' -> do 208 raw <- ra 209 a <- clipValid 0 23 raw 210 return $ TimeOfDay a m s 211 'I' -> do 212 raw <- ra 213 a <- clipValid 1 12 raw 214 return $ TimeOfDay a m s 215 'k' -> do 216 raw <- ra 217 a <- clipValid 0 23 raw 218 return $ TimeOfDay a m s 219 'l' -> do 220 raw <- ra 221 a <- clipValid 1 12 raw 222 return $ TimeOfDay a m s 223 'M' -> do 224 raw <- ra 225 a <- clipValid 0 59 raw 226 return $ TimeOfDay h a s 227 'S' -> do 228 raw <- ra 229 a <- clipValid 0 60 raw 230 return $ TimeOfDay h m (fromInteger a) 231 'q' -> do 232 a <- ra 233 return $ TimeOfDay h m (mkPico (floor s) a) 234 'Q' -> if null x then Just t else do 235 ps <- readMaybe $ take 12 $ rpad 12 '0' $ drop 1 x 236 return $ TimeOfDay h m (mkPico (floor s) ps) 237 _ -> Just t 238 239 in mfoldl f (Just midnight) 240 241rpad :: Int -> a -> [a] -> [a] 242rpad n c xs = xs ++ replicate (n - length xs) c 243 244mkPico :: Integer -> Integer -> Pico 245mkPico i f = fromInteger i + fromRational (f % 1000000000000) 246 247instance ParseTime LocalTime where 248 substituteTimeSpecifier _ = timeSubstituteTimeSpecifier 249 parseTimeSpecifier _ = timeParseTimeSpecifier 250 buildTime l xs = LocalTime <$> (buildTime l xs) <*> (buildTime l xs) 251 252enumDiff :: (Enum a) => a -> a -> Int 253enumDiff a b = (fromEnum a) - (fromEnum b) 254 255getMilZoneHours :: Char -> Maybe Int 256getMilZoneHours c | c < 'A' = Nothing 257getMilZoneHours c | c <= 'I' = Just $ 1 + enumDiff c 'A' 258getMilZoneHours 'J' = Nothing 259getMilZoneHours c | c <= 'M' = Just $ 10 + enumDiff c 'K' 260getMilZoneHours c | c <= 'Y' = Just $ (enumDiff 'N' c) - 1 261getMilZoneHours 'Z' = Just 0 262getMilZoneHours _ = Nothing 263 264getMilZone :: Char -> Maybe TimeZone 265getMilZone c = let 266 yc = toUpper c 267 in do 268 hours <- getMilZoneHours yc 269 return $ TimeZone (hours * 60) False [yc] 270 271getKnownTimeZone :: TimeLocale -> String -> Maybe TimeZone 272getKnownTimeZone locale x = find (\tz -> map toUpper x == timeZoneName tz) (knownTimeZones locale) 273 274instance ParseTime TimeZone where 275 substituteTimeSpecifier _ = timeSubstituteTimeSpecifier 276 parseTimeSpecifier _ = timeParseTimeSpecifier 277 buildTime l = let 278 f :: Char -> String -> TimeZone -> Maybe TimeZone 279 f 'z' str (TimeZone _ dst name) | Just offset <- readTzOffset str = Just $ TimeZone offset dst name 280 f 'z' _ _ = Nothing 281 f 'Z' str _ | Just offset <- readTzOffset str = Just $ TimeZone offset False "" 282 f 'Z' str _ | Just zone <- getKnownTimeZone l str = Just zone 283 f 'Z' "UTC" _ = Just utc 284 f 'Z' [c] _ | Just zone <- getMilZone c = Just zone 285 f 'Z' _ _ = Nothing 286 f _ _ tz = Just tz 287 in foldl (\mt (c,s) -> mt >>= f c s) (Just $ minutesToTimeZone 0) 288 289readTzOffset :: String -> Maybe Int 290readTzOffset str = let 291 292 getSign '+' = Just 1 293 getSign '-' = Just (-1) 294 getSign _ = Nothing 295 296 calc s h1 h2 m1 m2 = do 297 sign <- getSign s 298 h <- readMaybe [h1,h2] 299 m <- readMaybe [m1,m2] 300 return $ sign * (60 * h + m) 301 302 in case str of 303 (s:h1:h2:':':m1:m2:[]) -> calc s h1 h2 m1 m2 304 (s:h1:h2:m1:m2:[]) -> calc s h1 h2 m1 m2 305 _ -> Nothing 306 307instance ParseTime ZonedTime where 308 substituteTimeSpecifier _ = timeSubstituteTimeSpecifier 309 parseTimeSpecifier _ = timeParseTimeSpecifier 310 buildTime l xs = let 311 f (ZonedTime (LocalTime _ tod) z) ('s',x) = do 312 a <- readMaybe x 313 let 314 s = fromInteger a 315 (_,ps) = properFraction (todSec tod) :: (Integer,Pico) 316 s' = s + fromRational (toRational ps) 317 return $ utcToZonedTime z (posixSecondsToUTCTime s') 318 f t _ = Just t 319 in mfoldl f (ZonedTime <$> (buildTime l xs) <*> (buildTime l xs)) xs 320 321instance ParseTime UTCTime where 322 substituteTimeSpecifier _ = timeSubstituteTimeSpecifier 323 parseTimeSpecifier _ = timeParseTimeSpecifier 324 buildTime l xs = zonedTimeToUTC <$> buildTime l xs 325 326instance ParseTime UniversalTime where 327 substituteTimeSpecifier _ = timeSubstituteTimeSpecifier 328 parseTimeSpecifier _ = timeParseTimeSpecifier 329 buildTime l xs = localTimeToUT1 0 <$> buildTime l xs 330 331buildTimeMonths :: [(Char,String)] -> Maybe Integer 332buildTimeMonths xs = do 333 tt <- for xs $ \(c,s) -> case c of 334 'y' -> fmap ((*) 12) $ readMaybe s 335 'b' -> readMaybe s 336 'B' -> readMaybe s 337 _ -> return 0 338 return $ sum tt 339 340buildTimeDays :: [(Char,String)] -> Maybe Integer 341buildTimeDays xs = do 342 tt <- for xs $ \(c,s) -> case c of 343 'w' -> fmap ((*) 7) $ readMaybe s 344 'd' -> readMaybe s 345 'D' -> readMaybe s 346 _ -> return 0 347 return $ sum tt 348 349buildTimeSeconds :: [(Char,String)] -> Maybe Pico 350buildTimeSeconds xs = do 351 tt <- for xs $ \(c,s) -> let 352 readInt :: Integer -> Maybe Pico 353 readInt t = do 354 i <- readMaybe s 355 return $ fromInteger $ i * t 356 in case c of 357 'h' -> readInt 3600 358 'H' -> readInt 3600 359 'm' -> readInt 60 360 'M' -> readInt 60 361 's' -> readMaybe s 362 'S' -> readMaybe s 363 _ -> return 0 364 return $ sum tt 365 366instance ParseTime NominalDiffTime where 367 parseTimeSpecifier _ = durationParseTimeSpecifier 368 buildTime _ xs = do 369 dd <- buildTimeDays xs 370 tt <- buildTimeSeconds xs 371 return $ (fromInteger dd * 86400) + realToFrac tt 372 373instance ParseTime DiffTime where 374 parseTimeSpecifier _ = durationParseTimeSpecifier 375 buildTime _ xs = do 376 dd <- buildTimeDays xs 377 tt <- buildTimeSeconds xs 378 return $ (fromInteger dd * 86400) + realToFrac tt 379 380instance ParseTime CalendarDiffDays where 381 parseTimeSpecifier _ = durationParseTimeSpecifier 382 buildTime _ xs = do 383 mm <- buildTimeMonths xs 384 dd <- buildTimeDays xs 385 return $ CalendarDiffDays mm dd 386 387instance ParseTime CalendarDiffTime where 388 parseTimeSpecifier _ = durationParseTimeSpecifier 389 buildTime locale xs = do 390 mm <- buildTimeMonths xs 391 tt <- buildTime locale xs 392 return $ CalendarDiffTime mm tt 393