Data/Time/RFC733/Parsec.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 module Data.Time.RFC733.Parsec
   3     ( rfc733DateAndTime
   4     )
   5     where
   6
   7 import Control.Monad
   8 import Data.Fixed
   9 import Data.Time
  10 import Data.Time.Calendar.WeekDate
  11 import Data.Time.HTTP.Common
  12 import Text.Parsec
  13
  14 -- |This is a parsec parser for RFC 733 date and time strings.
  15 rfc733DateAndTime :: Stream s m Char => ParsecT s u m ZonedTime
  16 rfc733DateAndTime = dateTime
  17
  18 dateTime :: Stream s m Char => ParsecT s u m ZonedTime
  19 dateTime = do weekDay <- optionMaybe $
  20                          do w <- try longWeekDayNameP
  21                                  <|>
  22                                  shortWeekDayNameP
  23                             _ <- string ", "
  24                             return w
  25               gregDay <- date
  26               case weekDay of
  27                 Nothing
  28                     -> return ()
  29                 Just givenWD
  30                     -> assertWeekDayIsGood givenWD gregDay
  31               (tod, timeZone) <- time
  32               let lt = LocalTime gregDay tod
  33                   zt = ZonedTime lt timeZone
  34               return zt
  35
  36 date :: Stream s m Char => ParsecT s u m Day
  37 date = do day   <- read2
  38           _     <- char '-' <|> char ' '
  39           month <- try longMonthNameP
  40                    <|>
  41                    shortMonthNameP
  42           _     <- char '-' <|> char ' '
  43           year  <- try read4
  44                    <|>
  45                    liftM (+ 1900) read2
  46           _     <- char ' '
  47           assertGregorianDateIsGood year month day
  48
  49 time :: Stream s m Char => ParsecT s u m (TimeOfDay, TimeZone)
  50 time = do tod <- hour
  51           _   <- char '-' <|> char ' '
  52           tz  <- zone
  53           return (tod, tz)
  54
  55 hour :: Stream s m Char => ParsecT s u m TimeOfDay
  56 hour = do hour   <- read2
  57           _      <- optional (char ':')
  58           minute <- read2
  59           second <- option 0 $
  60                     do _ <- optional (char ':')
  61                        read2
  62           assertTimeOfDayIsGood hour minute second
  63
  64 zone :: Stream s m Char => ParsecT s u m TimeZone
  65 zone = choice [ string "GMT" >> return (TimeZone 0 False "GMT")
  66               , char 'N'
  67                 >> choice [ string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST")
  68                           , return (TimeZone (1 * 60) False "N")
  69                           ]
  70               , char 'A'
  71                 >> choice [ string "ST" >> return (TimeZone ((-4) * 60) False "AST")
  72                           , string "DT" >> return (TimeZone ((-3) * 60) False "AST")
  73                           , return (TimeZone ((-1) * 60) False "A")
  74                           ]
  75               , char 'E'
  76                 >> choice [ string "ST" >> return (TimeZone ((-5) * 60) False "EST")
  77                           , string "DT" >> return (TimeZone ((-4) * 60) True  "EDT")
  78                           ]
  79               , char 'C'
  80                 >> choice [ string "ST" >> return (TimeZone ((-6) * 60) False "CST")
  81                           , string "DT" >> return (TimeZone ((-5) * 60) True  "CDT")
  82                           ]
  83               , char 'M'
  84                 >> choice [ string "ST" >> return (TimeZone ((-7) * 60) False "MST")
  85                           , string "DT" >> return (TimeZone ((-6) * 60) True  "MDT")
  86                           , return (TimeZone ((-12) * 60) False "M")
  87                           ]
  88               , char 'P'
  89                 >> choice [ string "ST" >> return (TimeZone ((-8) * 60) False "PST")
  90                           , string "DT" >> return (TimeZone ((-7) * 60) True  "PDT")
  91                           ]
  92               , char 'Y'
  93                 >> choice [ string "ST" >> return (TimeZone ((-9) * 60) False "YST")
  94                           , string "DT" >> return (TimeZone ((-8) * 60) True  "YDT")
  95                           , return (TimeZone ( 12  * 60) False "Y")
  96                           ]
  97               , char 'H'
  98                 >> choice [ string "ST" >> return (TimeZone ((-10) * 60) False "HST")
  99                           , string "DT" >> return (TimeZone (( -9) * 60) True  "HDT")
 100                           ]
 101               , char 'B'
 102                 >> choice [ string "ST" >> return (TimeZone ((-11) * 60) False "BST")
 103                           , string "DT" >> return (TimeZone ((-10) * 60) True  "BDT")
 104                           ]
 105               , char 'Z' >> return (TimeZone 0 False "Z")
 106               , read4digitsTZ
 107               ]