module Darcs.Patch.OldDate ( readUTCDate, showIsoDateTime ) where
import Text.ParserCombinators.Parsec
import System.Time
import Data.Char ( toUpper, isDigit )
import Control.Monad ( liftM, liftM2 )
import qualified Data.ByteString.Char8 as B
import Data.Maybe ( fromMaybe )
readUTCDate :: String -> CalendarTime
readUTCDate = readDate 0
readDate :: Int -> String -> CalendarTime
readDate tz d =
case parseDate tz d of
Left e -> error e
Right ct -> ct
parseDate :: Int -> String -> Either String CalendarTime
parseDate tz d =
if length d >= 14 && B.all isDigit bd
then Right $
CalendarTime (readI $ B.take 4 bd)
(toEnum $ (+ (1)) $ readI $ B.take 2 $ B.drop 4 bd)
(readI $ B.take 2 $ B.drop 6 bd)
(readI $ B.take 2 $ B.drop 8 bd)
(readI $ B.take 2 $ B.drop 10 bd)
(readI $ B.take 2 $ B.drop 12 bd)
0 Sunday 0
"GMT" 0 False
else let dt = do { x <- date_time tz; eof; return x }
in case parse dt "" d of
Left e -> Left $ "bad date: "++d++" - "++show e
Right ct -> Right ct
where bd = B.pack (take 14 d)
readI s = fst $ fromMaybe (error "parseDate: invalid date") (B.readInt s)
showIsoDateTime :: CalendarTime -> String
showIsoDateTime ct = concat [ show $ ctYear ct
, twoDigit . show . (+1) . fromEnum $ ctMonth ct
, twoDigit . show $ ctDay ct
, twoDigit . show $ ctHour ct
, twoDigit . show $ ctMin ct
, twoDigit . show $ ctSec ct
]
where twoDigit [] = undefined
twoDigit x@(_:[]) = '0' : x
twoDigit x@(_:_:[]) = x
twoDigit _ = undefined
caseChar :: Char -> GenParser Char a Char
caseChar c = satisfy (\x -> toUpper x == toUpper c)
caseString :: String -> GenParser Char a ()
caseString cs = mapM_ caseChar cs <?> cs
manyN :: Int -> GenParser a b c -> GenParser a b [c]
manyN n p
| n <= 0 = return []
| otherwise = liftM2 (++) (count n p) (many p)
manyNtoM :: Int -> Int -> GenParser a b c -> GenParser a b [c]
manyNtoM n m p
| n < 0 = return []
| n > m = return []
| n == m = count n p
| n == 0 = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m]))
| otherwise = liftM2 (++) (count n p) (manyNtoM 0 (mn) p)
date_time :: Int -> CharParser a CalendarTime
date_time tz =
choice [try $ cvs_date_time tz,
try $ iso8601_date_time tz,
old_date_time]
cvs_date_time :: Int -> CharParser a CalendarTime
cvs_date_time tz =
do y <- year
char '/'
mon <- month_num
char '/'
d <- day
my_spaces
h <- hour
char ':'
m <- minute
char ':'
s <- second
z <- option tz $ my_spaces >> zone
return (CalendarTime y mon d h m s 0 Monday 0 "" z False)
old_date_time :: CharParser a CalendarTime
old_date_time = do wd <- day_name
my_spaces
mon <- month_name
my_spaces
d <- day
my_spaces
h <- hour
char ':'
m <- minute
char ':'
s <- second
my_spaces
z <- zone
my_spaces
y <- year
return (CalendarTime y mon d h m s 0 wd 0 "" z False)
iso8601_date_time :: Int -> CharParser a CalendarTime
iso8601_date_time localTz = try $
do d <- iso8601_date
t <- option id $ try $ do optional $ oneOf " T"
iso8601_time
return $ t $ d { ctTZ = localTz }
iso8601_date :: CharParser a CalendarTime
iso8601_date =
do d <- calendar_date <|> week_date <|> ordinal_date
return $ foldr ($) nullCalendar d
where
calendar_date =
try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ]
notFollowedBy (digit <|> char 'W')
return d
week_date =
try $ do yfn <- year_
optional dash
char 'W'
w' <- (\x -> x1) `liftM` two_digits
wd <- option 1 $ do { optional dash; n_digits 1 }
let y = yfn nullCalendar
firstDay = ctWDay y
let afterThursday = firstDay == Sunday || firstDay > Thursday
w = if afterThursday then w'+1 else w'
diff c = c { ctDay = (7 * w) + wd (fromEnum firstDay) }
return [(toUTCTime.toClockTime.diff.yfn)]
ordinal_date =
try $ optchain year_ [ (dash, yearDay_) ]
year_ = try $ do y <- four_digits <?> "year (0000-9999)"
return $ \c -> c { ctYear = y }
month_ = try $ do m <- two_digits <?> "month (1 to 12)"
return $ \c -> c { ctMonth = intToMonth m, ctPicosec = 0 }
day_ = try $ do d <- two_digits <?> "day in month (1 to 31)"
return $ \c -> c { ctDay = d }
yearDay_ = try $ do d <- n_digits 3 <?> "day in year (1 to 366)"
return $ \c -> c { ctYDay = d }
dash = char '-'
iso8601_time :: CharParser a (CalendarTime -> CalendarTime)
iso8601_time = try $
do ts <- optchain hour_ [ (colon , min_)
, (colon , sec_)
, (oneOf ",.", pico_) ]
z <- option id $ choice [ zulu , offset ]
return $ foldr (.) id (z:ts)
where
hour_ = do h <- two_digits
return $ \c -> c { ctHour = h }
min_ = do m <- two_digits
return $ \c -> c { ctMin = m }
sec_ = do s <- two_digits
return $ \c -> c { ctSec = s }
pico_ = do digs <- many digit
let picoExp = 12
digsExp = length digs
let frac | null digs = 0
| digsExp > picoExp = read $ take picoExp digs
| otherwise = 10 ^ (picoExp digsExp) * (read digs)
return $ \c -> c { ctPicosec = frac }
zulu = do { char 'Z'; return (\c -> c { ctTZ = 0 }) }
offset = do sign <- choice [ do { char '+' >> return 1 }
, do { char '-' >> return (1) } ]
h <- two_digits
m <- option 0 $ do { optional colon; two_digits }
return $ \c -> c { ctTZ = sign * 60 * ((h*60)+m) }
colon = char ':'
optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b]
optchain p next = try $
do r1 <- p
r2 <- case next of
[] -> return []
((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 }
return (r1:r2)
n_digits :: Int -> CharParser a Int
n_digits n = read `liftM` count n digit
two_digits, four_digits :: CharParser a Int
two_digits = n_digits 2
four_digits = n_digits 4
my_spaces :: CharParser a String
my_spaces = manyN 1 $ char ' '
day_name :: CharParser a Day
day_name = choice
[ caseString "Mon" >> return Monday
, try (caseString "Tue") >> return Tuesday
, caseString "Wed" >> return Wednesday
, caseString "Thu" >> return Thursday
, caseString "Fri" >> return Friday
, try (caseString "Sat") >> return Saturday
, caseString "Sun" >> return Sunday
]
year :: CharParser a Int
year = four_digits
month_num :: CharParser a Month
month_num = do mn <- manyNtoM 1 2 digit
return $ intToMonth $ (read mn :: Int)
intToMonth :: Int -> Month
intToMonth 1 = January
intToMonth 2 = February
intToMonth 3 = March
intToMonth 4 = April
intToMonth 5 = May
intToMonth 6 = June
intToMonth 7 = July
intToMonth 8 = August
intToMonth 9 = September
intToMonth 10 = October
intToMonth 11 = November
intToMonth 12 = December
intToMonth _ = error "invalid month!"
month_name :: CharParser a Month
month_name = choice
[ try (caseString "Jan") >> return January
, caseString "Feb" >> return February
, try (caseString "Mar") >> return March
, try (caseString "Apr") >> return April
, caseString "May" >> return May
, try (caseString "Jun") >> return June
, caseString "Jul" >> return July
, caseString "Aug" >> return August
, caseString "Sep" >> return September
, caseString "Oct" >> return October
, caseString "Nov" >> return November
, caseString "Dec" >> return December
]
day :: CharParser a Int
day = do d <- manyNtoM 1 2 digit
return (read d :: Int)
hour :: CharParser a Int
hour = two_digits
minute :: CharParser a Int
minute = two_digits
second :: CharParser a Int
second = two_digits
zone :: CharParser a Int
zone = choice
[ do { char '+'; h <- hour; m <- minute; return (((h*60)+m)*60) }
, do { char '-'; h <- hour; m <- minute; return (((h*60)+m)*60) }
, mkZone "UTC" 0
, mkZone "UT" 0
, mkZone "GMT" 0
, mkZone "EST" (5)
, mkZone "EDT" (4)
, mkZone "CST" (6)
, mkZone "CDT" (5)
, mkZone "MST" (7)
, mkZone "MDT" (6)
, mkZone "PST" (8)
, mkZone "PDT" (7)
, mkZone "CEST" 2
, mkZone "EEST" 3
, do { manyTill (oneOf $ ['a'..'z']++['A'..'Z']++[' '])
(lookAhead space_digit);
return 0 }
]
where mkZone n o = try $ do { caseString n; return (o*60*60) }
space_digit = try $ do { char ' '; oneOf ['0'..'9'] }
nullCalendar :: CalendarTime
nullCalendar = CalendarTime 0 January 0 0 0 0 1 Sunday 0 "" 0 False