module WASH.Utility.ISO8601 where
import Char
import Monad
import Time
import System.IO.Unsafe
import WASH.Utility.IntToString
import WASH.Utility.SimpleParser
secondsToString seconds =
intToString 20 seconds
isoDateToString isoDate =
let seconds = unsafePerformIO $ isoDateToSeconds isoDate
in secondsToString seconds
isoDateAndTimeToString isoDateAndTime =
let seconds = unsafePerformIO $ isoDateAndTimeToSeconds isoDateAndTime
in secondsToString seconds
applyToCalT :: (CalendarTime -> a) -> IO a
applyToCalT g =
do clkT <- getClockTime
calT <- toCalendarTime clkT
return $ g calT
isoDateAndTimeToSeconds :: ISODateAndTime -> IO Integer
isoDateAndTimeToSeconds isoDateAndTime =
applyToCalT $ toSeconds isoDateAndTime
isoTimeToSeconds :: ISOTime -> IO Integer
isoTimeToSeconds isoTime =
applyToCalT $ toSeconds isoTime
isoDateToSeconds :: ISODate -> IO Integer
isoDateToSeconds isoDate =
applyToCalT $ toSeconds isoDate
class ToSeconds iso where
toSeconds :: iso -> CalendarTime -> Integer
toRawSeconds :: iso -> CalendarTime -> Integer
toRawSeconds = toSeconds
instance ToSeconds ISODateAndTime where
toSeconds isoDateAndTime@(ISODateAndTime isoDate isoTime) calT =
let rawseconds = toRawSeconds isoDateAndTime calT in
case addLeapSeconds leapSeconds rawseconds of
NotLeapSecond seconds -> seconds
LeapSecond seconds -> seconds + leapSecondCorrection isoTime
toRawSeconds (ISODateAndTime isoDate isoTime) calT =
toRawSeconds isoDate calT + toRawSeconds isoTime calT
leapSecondCorrection (ISOTime isoHourSpec isoMinuteSpec isoSecondSpec isoTimeZoneSpec) =
case isoSecondSpec of
Second ss -> if ss == 0 then 1 else 0
NoSecond -> 1
instance ToSeconds ISODate where
toSeconds isoDate calT =
case addLeapSeconds leapSeconds (toRawSeconds isoDate calT) of
NotLeapSecond seconds -> seconds
LeapSecond seconds -> seconds + 1
toRawSeconds (ISODate isoYearSpec isoDayOfYearSpec) calT =
let year = isoYearSpecToYear isoYearSpec calT
in
secondsPerDay * fromIntegral (yearsToDays year) +
isoDaysOfYearToSeconds year isoDayOfYearSpec calT
isoDaysOfYearToSeconds year NoDayOfYear calT =
0
isoDaysOfYearToSeconds year (MonthDay isoMonthSpec isoDayOfMonthSpec) calT =
let month = isoMonthSpecToMonth isoMonthSpec calT
dayOfMonth = isoDayOfMonthSpecToDayOfMonth isoDayOfMonthSpec calT
in
fromIntegral(dayOfMonth 1 + daysUptoMonth year month) * secondsPerDay
isoDaysOfYearToSeconds year (DayOfYear ddd) calT =
fromIntegral ddd * secondsPerDay
isoDaysOfYearToSeconds year (WeekAndDay (Week ww) NoDayOfWeek) calT =
fromIntegral (7 * (ww 1)) * secondsPerDay
isoDaysOfYearToSeconds year (WeekAndDay (Week ww) (DayOfWeek d)) calT =
let weekdayOfJan1 = yearsToWeekDay year in
fromIntegral (7 * (ww 1) + d weekdayOfJan1) * secondsPerDay
isoDaysOfYearToSeconds year (WeekAndDay ImplicitWeek (DayOfWeek d)) calT =
let weekdayOfJan1 = yearsToWeekDay year
ww = (ctYDay calT + weekdayOfJan1 + 5) `div` 7
in
fromIntegral (7 * (ww 1) + d weekdayOfJan1) * secondsPerDay
isoDaysOfYearToSeconds year (WeekAndDay _ _) calT =
error "Sorry, this combination of week and day does not make sense!"
isoMonthSpecToMonth ImplicitMonth calT =
fromEnum (ctMonth calT) + 1
isoMonthSpecToMonth (Month mm) calT =
mm
isoDayOfMonthSpecToDayOfMonth NoDayOfMonth calT =
1
isoDayOfMonthSpecToDayOfMonth (DayOfMonth dd) calT =
dd
daysUptoMonth year month =
let daysPerMonth = [31, 28 + leapDays year, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] in
sum (take (month1) daysPerMonth)
isoYearSpecToYear ImplicitYear calT =
(ctYear calT)
isoYearSpecToYear (ImplicitCentury yy) calT =
(100 * (ctYear calT `div` 100) + yy)
isoYearSpecToYear (Century cc) calT =
(100 * cc)
isoYearSpecToYear (ImplicitDecade y) calT =
(10 * (ctYear calT `div` 10) + y)
isoYearSpecToYear (Year ccyy) calT =
ccyy
leapDays year =
if leapYear year then 1 else 0
leapYear year =
year `mod` 4 == 0 && (year `mod` 100 /= 0 || year `mod` 400 == 0)
yearsToDays ccyy =
let nrOfYears = ccyy 1970
leapYears = [ year | year <- [1970 .. ccyy1] , leapYear year ]
nrOfLeapDays = length leapYears
in
365 * nrOfYears + nrOfLeapDays
yearsToWeekDay ccyy =
let nrOfDays = yearsToDays ccyy
jan_1_1970 = 4
in 1 + (nrOfDays + 6) `mod` 7
leapSeconds :: [Integer]
leapSeconds =
[
00000000000078796800,
00000000000094694400 + 1,
00000000000126230400 + 2,
00000000000157766400 + 3,
00000000000189302400 + 4,
00000000000220924800 + 5,
00000000000252460800 + 6,
00000000000283996800 + 7,
00000000000315532800 + 8,
00000000000362793600 + 9,
00000000000394329600 + 10,
00000000000425865600 + 11,
00000000000489024000 + 12,
00000000000567993600 + 13,
00000000000631152000 + 14,
00000000000662688000 + 15,
00000000000709948800 + 16,
00000000000741484800 + 17,
00000000000773020800 + 18,
00000000000820454400 + 19,
00000000000867715200 + 20,
00000000000915148800 + 21
]
data LeapSeconds = LeapSecond Integer | NotLeapSecond Integer
deriving Show
addLeapSeconds [] seconds = NotLeapSecond seconds
addLeapSeconds (ls: rest) seconds =
if ls > seconds then NotLeapSecond seconds else
if ls == seconds then LeapSecond seconds else
addLeapSeconds rest (seconds+1)
secondsPerMinute = 60
secondsPerHour = 60 * secondsPerMinute
secondsPerDay = 24 * secondsPerHour
secondsPerYear = 365 * secondsPerDay
instance ToSeconds ISOTime where
toSeconds (ISOTime isoHourSpec isoMinuteSpec isoSecondSpec isoTimeZoneSpec) calT =
toSeconds isoHourSpec calT +
toSeconds isoMinuteSpec calT +
toSeconds isoSecondSpec calT +
toSeconds isoTimeZoneSpec calT
instance ToSeconds ISOHourSpec where
toSeconds ImplicitHour calT = fromIntegral (3600 * ctHour calT ctTZ calT)
toSeconds (Hour hh) calT = fromIntegral (3600 * hh ctTZ calT)
instance ToSeconds ISOMinuteSpec where
toSeconds ImplicitMinute calT = fromIntegral (60 * ctMin calT)
toSeconds (Minute mm) calT = fromIntegral (60 * mm)
toSeconds NoMinute calT = 0
instance ToSeconds ISOSecondSpec where
toSeconds (Second ss) calT = fromIntegral ss
toSeconds NoSecond calT = 0
instance ToSeconds ISOTimeZoneSpec where
toSeconds LocalTime calT = 0
toSeconds UTCTime calT = fromIntegral (ctTZ calT)
toSeconds (PlusTime (Hour hh) isoMinuteSpec) calT =
fromIntegral (ctTZ calT (3600 * hh + 60 * minutes isoMinuteSpec))
toSeconds (MinusTime (Hour hh) isoMinuteSpec) calT =
fromIntegral (ctTZ calT + (3600 * hh + 60 * minutes isoMinuteSpec))
minutes ImplicitMinute = 0
minutes (Minute mm) = mm
minutes NoMinute = 0
isoDateToClockTime :: ISODate -> ClockTime
isoDateToClockTime isoDate =
let seconds = unsafePerformIO $ isoDateToSeconds isoDate
in secondsToClockTime seconds
isoDateAndTimeToClockTime :: ISODateAndTime -> ClockTime
isoDateAndTimeToClockTime isoDateAndTime =
let seconds = unsafePerformIO $ isoDateAndTimeToSeconds isoDateAndTime
in secondsToClockTime seconds
secondsToClockTime seconds =
let tdiff = TimeDiff { tdYear =0,
tdMonth =0,
tdDay =0,
tdHour =0,
tdMin =0,
tdSec = fromIntegral seconds,
tdPicosec =0
}
in addToClockTime tdiff epochClkT
epochClkT = toClockTime epoch
epoch = CalendarTime { ctYear = 1970,
ctMonth = January,
ctDay = 1,
ctHour = 0,
ctMin = 0,
ctSec = 0,
ctPicosec= 0,
ctWDay = Thursday,
ctYDay = 0,
ctTZName = "UTC",
ctTZ = 0,
ctIsDST = False
}
data ISODateAndTime =
ISODateAndTime ISODate ISOTime
deriving Show
data ISODate =
ISODate ISOYearSpec ISODayOfYearSpec
deriving Show
data ISOYearSpec
= ImplicitYear | ImplicitCentury Int | Century Int | ImplicitDecade Int | Year Int
deriving Show
data ISODayOfYearSpec
= NoDayOfYear
| MonthDay ISOMonthSpec ISODayOfMonthSpec
| DayOfYear Int
| WeekAndDay ISOWeekSpec ISODayOfWeekSpec
deriving Show
data ISOMonthSpec
= ImplicitMonth | Month Int
deriving Show
data ISODayOfMonthSpec
= NoDayOfMonth | DayOfMonth Int
deriving Show
data ISOWeekSpec
= ImplicitWeek | AnyWeek | Week Int
deriving Show
data ISODayOfWeekSpec
= NoDayOfWeek | DayOfWeek Int
deriving Show
data ISOTime
= ISOTime ISOHourSpec ISOMinuteSpec ISOSecondSpec ISOTimeZoneSpec
deriving Show
data ISOHourSpec
= ImplicitHour | Hour Int
deriving Show
data ISOMinuteSpec
= ImplicitMinute | Minute Int | NoMinute
deriving Show
data ISOSecondSpec
= Second Int | NoSecond
deriving Show
data ISOTimeZoneSpec
= LocalTime | UTCTime | PlusTime ISOHourSpec ISOMinuteSpec | MinusTime ISOHourSpec ISOMinuteSpec
deriving Show
updateTZ (ISOTime isoHourSpec isoMinuteSpec isoSecondSpec _) isoTimeZoneSpec =
ISOTime isoHourSpec isoMinuteSpec isoSecondSpec isoTimeZoneSpec
digitval = digitToInt
skipHyphen = char '-' >> return ()
skipColon = char ':' >> return ()
skipSolidus = char '/' >> return ()
skipMinus = char '-' >> return ()
skipPlus = char '+' >> return ()
skipP = oneOf "pP" >> return ()
skipT = oneOf "tT" >> return ()
skipW = oneOf "wW" >> return ()
skipZ = oneOf "zZ" >> return ()
parseDateFromString :: String -> Maybe ISODate
parseDateFromString = parseFromString parseDate
parseTimeFromString :: String -> Maybe ISOTime
parseTimeFromString = parseFromString parseTime
parseDateAndTimeFromString :: String -> Maybe ISODateAndTime
parseDateAndTimeFromString = parseFromString parseDateAndTime
parseDate =
parseBasicOrExtended parseDateInternal
parseTime =
parseBasicOrExtended parseTimeInternal
parseDateAndTime =
parseBasicOrExtended parseTimeAndDateInternal
parseBasicOrExtended parser =
parser True <|> parser False
parseTimeAndDateInternal extended =
do isodate <- parseDateInternal extended
isotime <- option (ISOTime (Hour 0) NoMinute NoSecond UTCTime)
(skipT >> parseTimeInternal extended)
return $ ISODateAndTime isodate isotime
parseDateInternal False =
(try $ do ccyy <- parseFourDigits
mm <- parseTwoDigits
dd <- parseTwoDigits
return $ ISODate (Year ccyy) $ MonthDay (Month mm) (DayOfMonth dd))
<|>
(try $ do ccyy <- parseFourDigits
skipHyphen
mm <- parseTwoDigits
return $ ISODate (Year ccyy) $ MonthDay (Month mm) NoDayOfMonth)
<|>
(try $ do ccyy <- parseFourDigits
return $ ISODate (Year ccyy) NoDayOfYear)
<|>
(try $ do cc <- parseTwoDigits
return $ ISODate (Century cc) NoDayOfYear)
<|>
(try $ do yy <- parseTwoDigits
mm <- parseTwoDigits
dd <- parseTwoDigits
return $ ISODate (ImplicitCentury yy) $ MonthDay (Month mm) (DayOfMonth dd))
<|>
(try $ do skipHyphen
yy <- parseTwoDigits
mm <- parseTwoDigits
return $ ISODate (ImplicitCentury yy) $ MonthDay (Month mm) NoDayOfMonth)
<|>
(try $ do skipHyphen
yy <- parseTwoDigits
return $ ISODate (ImplicitCentury yy) NoDayOfYear)
<|>
(try $ do skipHyphen
skipHyphen
mm <- parseTwoDigits
dd <- parseTwoDigits
return $ ISODate ImplicitYear $ MonthDay (Month mm) (DayOfMonth dd))
<|>
(try $ do skipHyphen
skipHyphen
mm <- parseTwoDigits
return $ ISODate ImplicitYear $ MonthDay (Month mm) NoDayOfMonth)
<|>
(try $ do skipHyphen
skipHyphen
skipHyphen
dd <- parseTwoDigits
return $ ISODate ImplicitYear $ MonthDay ImplicitMonth (DayOfMonth dd))
<|>
(try $ do ccyy <- parseFourDigits
ddd <- parseOrdinalDay
return $ ISODate (Year ccyy) $ DayOfYear ddd)
<|>
(try $ do yy <- parseTwoDigits
ddd <- parseOrdinalDay
return $ ISODate (ImplicitCentury yy) $ DayOfYear ddd)
<|>
(try $ do skipHyphen
ddd <- parseOrdinalDay
return $ ISODate ImplicitYear $ DayOfYear ddd)
<|>
(try $ do ccyy <- parseFourDigits
skipW
ww <- parseTwoDigits
checkWeeks ww
d <- parseWeekDay
return $ ISODate (Year ccyy) $ WeekAndDay (Week ww) (DayOfWeek d))
<|>
(try $ do ccyy <- parseFourDigits
skipW
ww <- parseTwoDigits
checkWeeks ww
return $ ISODate (Year ccyy) $ WeekAndDay (Week ww) NoDayOfWeek)
<|>
(try $ do yy <- parseTwoDigits
skipW
ww <- parseTwoDigits
checkWeeks ww
d <- parseWeekDay
return $ ISODate (ImplicitCentury yy) $ WeekAndDay (Week ww) (DayOfWeek d))
<|>
(try $ do yy <- parseTwoDigits
skipW
ww <- parseTwoDigits
checkWeeks ww
return $ ISODate (ImplicitCentury yy) $ WeekAndDay (Week ww) NoDayOfWeek)
<|>
(try $ do skipHyphen
y <- parseOneDigit
skipW
ww <- parseTwoDigits
checkWeeks ww
d <- parseWeekDay
return $ ISODate (ImplicitDecade y) $ WeekAndDay (Week ww) (DayOfWeek d))
<|>
(try $ do skipHyphen
skipW
ww <- parseTwoDigits
checkWeeks ww
d <- parseWeekDay
return $ ISODate ImplicitYear $ WeekAndDay (Week ww) (DayOfWeek d))
<|>
(try $ do skipHyphen
skipW
ww <- parseTwoDigits
checkWeeks ww
return $ ISODate ImplicitYear $ WeekAndDay (Week ww) NoDayOfWeek)
<|>
(try $ do skipHyphen
skipW
skipHyphen
d <- parseWeekDay
return $ ISODate ImplicitYear $ WeekAndDay ImplicitWeek (DayOfWeek d))
<|>
(try $ do skipHyphen
skipHyphen
skipHyphen
d <- parseWeekDay
return $ ISODate ImplicitYear $ WeekAndDay AnyWeek (DayOfWeek d))
parseDateInternal True =
(try $ do ccyy <- parseFourDigits
skipHyphen
mm <- parseTwoDigits
skipHyphen
dd <- parseTwoDigits
return $ ISODate (Year ccyy) $ MonthDay (Month mm) (DayOfMonth dd))
<|>
(try $ do yy <- parseTwoDigits
skipHyphen
mm <- parseTwoDigits
skipHyphen
dd <- parseTwoDigits
return $ ISODate (ImplicitCentury yy) $ MonthDay (Month mm) (DayOfMonth dd))
<|>
(try $ do skipHyphen
yy <- parseTwoDigits
skipHyphen
mm <- parseTwoDigits
return $ ISODate (ImplicitCentury yy) $ MonthDay (Month mm) NoDayOfMonth)
<|>
(try $ do skipHyphen
skipHyphen
mm <- parseTwoDigits
skipHyphen
dd <- parseTwoDigits
return $ ISODate ImplicitYear $ MonthDay (Month mm) (DayOfMonth dd))
<|>
(try $ do ccyy <- parseFourDigits
skipHyphen
ddd <- parseOrdinalDay
return $ ISODate (Year ccyy) $ DayOfYear ddd)
<|>
(try $ do yy <- parseTwoDigits
skipHyphen
ddd <- parseOrdinalDay
return $ ISODate (ImplicitCentury yy) $ DayOfYear ddd)
<|>
(try $ do ccyy <- parseFourDigits
skipHyphen
skipW
ww <- parseTwoDigits
checkWeeks ww
skipHyphen
d <- parseWeekDay
return $ ISODate (Year ccyy) $ WeekAndDay (Week ww) (DayOfWeek d))
<|>
(try $ do ccyy <- parseFourDigits
skipHyphen
skipW
ww <- parseTwoDigits
checkWeeks ww
return $ ISODate (Year ccyy) $ WeekAndDay (Week ww) NoDayOfWeek)
<|>
(try $ do yy <- parseTwoDigits
skipHyphen
skipW
ww <- parseTwoDigits
checkWeeks ww
skipHyphen
d <- parseWeekDay
return $ ISODate (ImplicitCentury yy) $ WeekAndDay (Week ww) (DayOfWeek d))
<|>
(try $ do yy <- parseTwoDigits
skipHyphen
skipW
ww <- parseTwoDigits
checkWeeks ww
return $ ISODate (ImplicitCentury yy) $ WeekAndDay (Week ww) NoDayOfWeek)
<|>
(try $ do skipHyphen
y <- parseOneDigit
skipHyphen
skipW
ww <- parseTwoDigits
checkWeeks ww
skipHyphen
d <- parseWeekDay
return $ ISODate (ImplicitDecade y) $ WeekAndDay (Week ww) (DayOfWeek d))
<|>
(try $ do skipHyphen
skipW
ww <- parseTwoDigits
checkWeeks ww
skipHyphen
d <- parseWeekDay
return $ ISODate ImplicitYear $ WeekAndDay (Week ww) (DayOfWeek d))
parseTimeInternal extended =
do localtime <- parseLocalTimeInternal extended
tzsuffix <- option LocalTime $ parseTZsuffix extended
return $ updateTZ localtime tzsuffix
parseTZsuffix extended =
(do skipZ
return UTCTime)
<|>
(do skipPlus
(hours, minutes) <- parseHoursMinutes extended
return $ PlusTime hours minutes)
<|>
(do skipMinus
(hours, minutes) <- parseHoursMinutes extended
return $ MinusTime hours minutes)
parseHoursMinutes False =
do hh <- parseTwoDigits
mm <- option NoMinute $ (liftM Minute) parseTwoDigits
return (Hour hh, mm)
parseHoursMinutes True =
do hh <- parseTwoDigits
mm <- option NoMinute $ (liftM Minute) (skipColon >> parseTwoDigits)
return (Hour hh, mm)
parseLocalTimeInternal False =
(try $ do hh <- parseTwoDigits
mm <- parseTwoDigits
ss <- parseTwoDigits
checkHours hh
checkMinutes mm
checkSeconds ss
return $ ISOTime (Hour hh) (Minute mm) (Second ss) LocalTime)
<|>
(try $ do hh <- parseTwoDigits
mm <- parseTwoDigits
checkHours hh
checkMinutes mm
return $ ISOTime (Hour hh) (Minute mm) NoSecond LocalTime)
<|>
(try $ do hh <- parseTwoDigits
checkHours hh
return $ ISOTime (Hour hh) NoMinute NoSecond LocalTime)
<|>
(try $ do skipHyphen
mm <- parseTwoDigits
ss <- parseTwoDigits
checkMinutes mm
checkSeconds ss
return $ ISOTime ImplicitHour (Minute mm) (Second ss) LocalTime)
<|>
(try $ do skipHyphen
mm <- parseTwoDigits
checkMinutes mm
return $ ISOTime ImplicitHour (Minute mm) NoSecond LocalTime)
<|>
(try $ do skipHyphen
skipHyphen
ss <- parseTwoDigits
checkSeconds ss
return $ ISOTime ImplicitHour ImplicitMinute (Second ss) LocalTime)
parseLocalTimeInternal True =
(try $ do hh <- parseTwoDigits
skipColon
mm <- parseTwoDigits
skipColon
ss <- parseTwoDigits
checkHours hh
checkMinutes mm
checkSeconds ss
return $ ISOTime (Hour hh) (Minute mm) (Second ss) LocalTime)
<|>
(try $ do hh <- parseTwoDigits
skipColon
mm <- parseTwoDigits
checkHours hh
checkMinutes mm
return $ ISOTime (Hour hh) (Minute mm) NoSecond LocalTime)
<|>
(try $ do skipHyphen
mm <- parseTwoDigits
skipColon
ss <- parseTwoDigits
checkMinutes mm
checkSeconds ss
return $ ISOTime ImplicitHour (Minute mm) (Second ss) LocalTime)
instance Read ISOTime where
readsPrec i = parserToRead parseTime
instance Read ISODate where
readsPrec i = parserToRead parseDate
instance Read ISODateAndTime where
readsPrec i = parserToRead parseDateAndTime
checkSeconds ss = if ss > 60 then fail "more than 60 seconds" else return ()
checkMinutes mm = if mm > 59 then fail "more than 59 minutes" else return ()
checkHours hh = if hh > 24 then fail "more than 24 hours" else return ()
checkDays ddd = if ddd < 1 || ddd > 366 then fail "illegal ordinal day" else return ()
checkWeeks ww = if ww < 1 || ww > 53 then fail "illegal week nr" else return ()
parseWeekDay = do d0 <- oneOf "1234567"
return (digitval d0)
parseOneDigit = do d0 <- digit
return (digitval d0)
parseTwoDigits = do d1 <- digit
vv <- parseOneDigit
return (10 * digitval d1 + vv)
parseThreeDigits = do d2 <- digit
vv <- parseTwoDigits
let vvv = 100 * digitval d2 + vv
return vvv
parseOrdinalDay = do vvv <- parseThreeDigits
checkDays vvv
return vvv
parseFourDigits = do d3 <- digit
vvv <- parseThreeDigits
return (1000 * digitval d3 + vvv)