-- © 2002 Peter Thiemann
module WASH.Utility.ISO8601 where

import Control.Monad (liftM)
import Data.Char (digitToInt)
import System.IO.Unsafe
import System.Time (TimeDiff(..), addToClockTime, getClockTime, toCalendarTime, toClockTime, CalendarTime(..), ClockTime(..), Month(..), Day(..))

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
  -- |returns number of seconds since reference point
  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

-- |problem: 19720630T235960 and 19720701T000000 are both mapped to the same
-- number, 78796800, and then addLeapSeconds adds one yielding 78796801. While
-- this is correct for 19720701T000000, 19720630T235960 must be
-- 78796800. Implemented solution: if the current second specification is 0 and
-- the time to convert is the leap second, then add 1.
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			    -- we always mean 00:00:00
	
  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 (month-1) 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 .. ccyy-1] , leapYear year ]
      nrOfLeapDays = length leapYears
  in 
  365 * nrOfYears + nrOfLeapDays

-- |compute weekday of Jan 1
yearsToWeekDay ccyy =
  let nrOfDays = yearsToDays ccyy
      jan_1_1970 = 4 -- Thursday
  in  1 + (nrOfDays + 6) `mod` 7

-- |in seconds from epoch; needs to be updated when time leaps again
leapSeconds :: [Integer]
leapSeconds = 
  [ -- Leap	1972	Jun	30	23:59:60	+	S
    00000000000078796800,
    -- Leap	1972	Dec	31	23:59:60	+	S
    00000000000094694400 + 1,
    -- Leap	1973	Dec	31	23:59:60	+	S
    00000000000126230400 + 2,
    -- Leap	1974	Dec	31	23:59:60	+	S
    00000000000157766400 + 3,
    -- Leap	1975	Dec	31	23:59:60	+	S
    00000000000189302400 + 4,
    -- Leap	1976	Dec	31	23:59:60	+	S
    00000000000220924800 + 5,
    -- Leap	1977	Dec	31	23:59:60	+	S
    00000000000252460800 + 6,
    -- Leap	1978	Dec	31	23:59:60	+	S
    00000000000283996800 + 7,
    -- Leap	1979	Dec	31	23:59:60	+	S
    00000000000315532800 + 8,
    -- Leap	1981	Jun	30	23:59:60	+	S
    00000000000362793600 + 9,
    -- Leap	1982	Jun	30	23:59:60	+	S
    00000000000394329600 + 10,
    -- Leap	1983	Jun	30	23:59:60	+	S
    00000000000425865600 + 11,
    -- Leap	1985	Jun	30	23:59:60	+	S
    00000000000489024000 + 12,
    -- Leap	1987	Dec	31	23:59:60	+	S
    00000000000567993600 + 13,
    -- Leap	1989	Dec	31	23:59:60	+	S
    00000000000631152000 + 14,
    -- Leap	1990	Dec	31	23:59:60	+	S
    00000000000662688000 + 15,
    -- Leap	1992	Jun	30	23:59:60	+	S
    00000000000709948800 + 16,
    -- Leap	1993	Jun	30	23:59:60	+	S
    00000000000741484800 + 17,
    -- Leap	1994	Jun	30	23:59:60	+	S
    00000000000773020800 + 18,
    -- Leap	1995	Dec	31	23:59:60	+	S
    00000000000820454400 + 19,
    -- Leap	1997	Jun	30	23:59:60	+	S
    00000000000867715200 + 20,
    -- Leap	1998	Dec	31	23:59:60	+	S
    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
  -- seconds to 0:00 UTC
  -- may become negative to indicate previous day!
  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,		    -- ignored
			ctYDay   = 0,			    -- ignored
			ctTZName = "UTC",		    -- ignored
			ctTZ     = 0,
			ctIsDST  = False		    -- ignored
		     }

    
-- |data type for representing ISO time
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

-- |external entry point
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

-- I was pretty much fed up with the irregular format of ISO 8601. After a few
-- tries, I decided that the simplest approach was to just list all the
-- alternatives from the standard.

-- |argument determines whether extended format is parsed
parseDateInternal False =
  -- 5.2.1.1, complete representation, basic format: CCYYMMDD
  (try $ do ccyy <- parseFourDigits
	    mm <- parseTwoDigits
	    dd <- parseTwoDigits
	    return $ ISODate (Year ccyy) $ MonthDay (Month mm) (DayOfMonth dd))
  <|>
  -- !!! CHECK THIS !!!
  -- 5.2.1.2.a, a specific month, basic format: CCYY-MM
  (try $ do ccyy <- parseFourDigits
	    skipHyphen
	    mm <- parseTwoDigits
	    return $ ISODate (Year ccyy) $ MonthDay (Month mm) NoDayOfMonth)
  <|>
  -- 5.2.1.2.b, a specific year, basic format: CCYY
  (try $ do ccyy <- parseFourDigits
	    return $ ISODate (Year ccyy) NoDayOfYear)
  <|>
  -- 5.2.1.2.c, a specific century, basic format: CC
  (try $ do cc <- parseTwoDigits
	    return $ ISODate (Century cc) NoDayOfYear)
  <|>
  -- 5.2.1.3.a, truncated representation, specific date in current century, basic format: YYMMDD
  (try $ do yy <- parseTwoDigits
	    mm <- parseTwoDigits
	    dd <- parseTwoDigits
	    return $ ISODate (ImplicitCentury yy) $ MonthDay (Month mm) (DayOfMonth dd))
  <|>
  -- 5.2.1.3.b, truncated representation, specific year and month in current century, basic format: -YYMM
  (try $ do skipHyphen
	    yy <- parseTwoDigits
	    mm <- parseTwoDigits
	    return $ ISODate (ImplicitCentury yy) $ MonthDay (Month mm) NoDayOfMonth)
  <|>
  -- 5.2.1.3.c, truncated representation, specific year in current century, basic format: -YY
  (try $ do skipHyphen
	    yy <- parseTwoDigits
	    return $ ISODate (ImplicitCentury yy) NoDayOfYear)
  <|>
  -- 5.2.1.3.d, truncated representation, specific day of a month, basic format: --MMDD
  (try $ do skipHyphen
	    skipHyphen
	    mm <- parseTwoDigits
	    dd <- parseTwoDigits
	    return $ ISODate ImplicitYear $ MonthDay (Month mm) (DayOfMonth dd))
  <|>
  -- 5.2.1.3.e, truncated representation, specific month, basic format: --MM
  (try $ do skipHyphen
	    skipHyphen
	    mm <- parseTwoDigits
	    return $ ISODate ImplicitYear $ MonthDay (Month mm) NoDayOfMonth)
  <|>
  -- 5.2.1.3.f, truncated representation, specific day, basic format: ---DD
  (try $ do skipHyphen
	    skipHyphen
	    skipHyphen
	    dd <- parseTwoDigits
	    return $ ISODate ImplicitYear $ MonthDay ImplicitMonth (DayOfMonth dd))
  <|>
  -- 5.2.2 Ordinal date
  -- 5.2.2.1, complete representation, basic format: CCYYDDD
  (try $ do ccyy <- parseFourDigits
	    ddd <- parseOrdinalDay
	    return $ ISODate (Year ccyy) $ DayOfYear ddd)
  <|>
  -- 5.2.2.2.a, truncated representation, specific year and day in current century, basic format: YYDDD
  (try $ do yy <- parseTwoDigits
	    ddd <- parseOrdinalDay
	    return $ ISODate (ImplicitCentury yy) $ DayOfYear ddd)
  <|>
  -- 5.2.2.2.b, truncated representation, specific day only, basic format: -DDD
  (try $ do skipHyphen
	    ddd <- parseOrdinalDay
	    return $ ISODate ImplicitYear $ DayOfYear ddd)
  <|>
  -- 5.2.3 date by calendar week and day number
  -- 5.2.3.1, complete representation, basic format: CCYYWwwD
  (try $ do ccyy <- parseFourDigits
	    skipW
	    ww <- parseTwoDigits
	    checkWeeks ww
	    d <- parseWeekDay
	    return $ ISODate (Year ccyy) $ WeekAndDay (Week ww) (DayOfWeek d))
  <|>
  -- 5.2.3.2, reduced prec representation, basic format: CCYYWww
  (try $ do ccyy <- parseFourDigits
	    skipW
	    ww <- parseTwoDigits
	    checkWeeks ww
	    return $ ISODate (Year ccyy) $ WeekAndDay (Week ww) NoDayOfWeek)
  <|>
  -- 5.2.3.3.a, truncated representation, current century, basic format: YYWwwD
  (try $ do yy <- parseTwoDigits
	    skipW
	    ww <- parseTwoDigits
	    checkWeeks ww
	    d <- parseWeekDay
	    return $ ISODate (ImplicitCentury yy) $ WeekAndDay (Week ww) (DayOfWeek d))
  <|>
  -- 5.2.3.3.b, truncated representation, current century, year and week only, basic format: YYWww
  (try $ do yy <- parseTwoDigits
	    skipW
	    ww <- parseTwoDigits
	    checkWeeks ww
	    return $ ISODate (ImplicitCentury yy) $ WeekAndDay (Week ww) NoDayOfWeek)
  <|>
  -- 5.2.3.3.c, truncated representation, current decade, week, and day, basic format: -YWwwD
  (try $ do skipHyphen
	    y <- parseOneDigit
	    skipW
	    ww <- parseTwoDigits
	    checkWeeks ww
	    d <- parseWeekDay
	    return $ ISODate (ImplicitDecade y) $ WeekAndDay (Week ww) (DayOfWeek d))
  <|>
  -- 5.2.3.3.d, truncated representation, current year, week, and day, basic format: -WwwD
  (try $ do skipHyphen
	    skipW
	    ww <- parseTwoDigits
	    checkWeeks ww
	    d <- parseWeekDay
	    return $ ISODate ImplicitYear $ WeekAndDay (Week ww) (DayOfWeek d))
  <|>
  -- 5.2.3.3.e, truncated representation, current year, week only, basic format: -Www
  (try $ do skipHyphen
	    skipW
	    ww <- parseTwoDigits
	    checkWeeks ww
	    return $ ISODate ImplicitYear $ WeekAndDay (Week ww) NoDayOfWeek)
  <|>
  -- 5.2.3.3.f, truncated representation, day only of current week, basic format: -W-D
  (try $ do skipHyphen
	    skipW
	    skipHyphen
	    d <- parseWeekDay
	    return $ ISODate ImplicitYear $ WeekAndDay ImplicitWeek (DayOfWeek d))
  <|>
  -- 5.2.3.3.g, truncated representation, day only of any week, basic format: ---D
  (try $ do skipHyphen
	    skipHyphen
	    skipHyphen
	    d <- parseWeekDay
	    return $ ISODate ImplicitYear $ WeekAndDay AnyWeek (DayOfWeek d))


-- ----------------------------------------------------------------------
-- extended formats  
parseDateInternal True =
  -- 5.2.1.1, complete representation, extended format CCYY-MM-DD
  (try $ do ccyy <- parseFourDigits
	    skipHyphen
	    mm <- parseTwoDigits
	    skipHyphen
	    dd <- parseTwoDigits
	    return $ ISODate (Year ccyy) $ MonthDay (Month mm) (DayOfMonth dd))
  <|>
  -- 5.2.1.3.a, truncated representation, extended format: YY-MM-DD
  (try $ do yy <- parseTwoDigits
	    skipHyphen
	    mm <- parseTwoDigits
	    skipHyphen
	    dd <- parseTwoDigits
	    return $ ISODate (ImplicitCentury yy) $ MonthDay (Month mm) (DayOfMonth dd))
  <|>
  -- 5.2.1.3.b, truncated representation, specific year and month in current century, extended format: -YY-MM
  (try $ do skipHyphen
	    yy <- parseTwoDigits
	    skipHyphen
	    mm <- parseTwoDigits
	    return $ ISODate (ImplicitCentury yy) $ MonthDay (Month mm) NoDayOfMonth)
  <|>
  -- 5.2.1.3.d, truncated representation, specific day of a month, extended format: --MM-DD
  (try $ do skipHyphen
	    skipHyphen
	    mm <- parseTwoDigits
	    skipHyphen
	    dd <- parseTwoDigits
	    return $ ISODate ImplicitYear $ MonthDay (Month mm) (DayOfMonth dd))
  <|>
  -- 5.2.2 Ordinal date
  -- 5.2.2.1, complete representation, extended format: CCYY-DDD
  (try $ do ccyy <- parseFourDigits
	    skipHyphen
	    ddd <- parseOrdinalDay
	    return $ ISODate (Year ccyy) $ DayOfYear ddd)
  <|>
  -- 5.2.2.2.a, truncated representation, specific year and day in current century, extended format: YY-DDD
  (try $ do yy <- parseTwoDigits
	    skipHyphen
	    ddd <- parseOrdinalDay
	    return $ ISODate (ImplicitCentury yy) $ DayOfYear ddd)
  <|>
  -- 5.2.3 date by calendar week and day number
  -- 5.2.3.1, complete representation, extended format: CCYY-Www-D
  (try $ do ccyy <- parseFourDigits
	    skipHyphen
	    skipW
	    ww <- parseTwoDigits
	    checkWeeks ww
	    skipHyphen
	    d <- parseWeekDay
	    return $ ISODate (Year ccyy) $ WeekAndDay (Week ww) (DayOfWeek d))
  <|>
  -- 5.2.3.2, reduced prec representation, extended format: CCYY-Www
  (try $ do ccyy <- parseFourDigits
	    skipHyphen
	    skipW
	    ww <- parseTwoDigits
	    checkWeeks ww
	    return $ ISODate (Year ccyy) $ WeekAndDay (Week ww) NoDayOfWeek)
  <|>
  -- 5.2.3.3.a, truncated representation, current century, extended format: YY-Www-D
  (try $ do yy <- parseTwoDigits
	    skipHyphen
	    skipW
	    ww <- parseTwoDigits
	    checkWeeks ww
	    skipHyphen
	    d <- parseWeekDay
	    return $ ISODate (ImplicitCentury yy) $ WeekAndDay (Week ww) (DayOfWeek d))
  <|>
  -- 5.2.3.3.b, truncated representation, current century, year and week only, extended format: YY-Www
  (try $ do yy <- parseTwoDigits
	    skipHyphen
	    skipW
	    ww <- parseTwoDigits
	    checkWeeks ww
	    return $ ISODate (ImplicitCentury yy) $ WeekAndDay (Week ww) NoDayOfWeek)
  <|>
  -- 5.2.3.3.c, truncated representation, current decade, week, and day, extended format: -Y-Www-D
  (try $ do skipHyphen
	    y <- parseOneDigit
	    skipHyphen
	    skipW
	    ww <- parseTwoDigits
	    checkWeeks ww
	    skipHyphen
	    d <- parseWeekDay
	    return $ ISODate (ImplicitDecade y) $ WeekAndDay (Week ww) (DayOfWeek d))
  <|>
  -- !!! CHECK THIS
  -- 5.2.3.3.d, truncated representation, current year, week, and day, extended format: -Www-D
  (try $ do skipHyphen
	    skipW
	    ww <- parseTwoDigits
	    checkWeeks ww
	    skipHyphen
	    d <- parseWeekDay
	    return $ ISODate ImplicitYear $ WeekAndDay (Week ww) (DayOfWeek d))

-- |time parsers
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 =
  -- 5.3.1.1, local time, basic format: hhmmss
  (try $ do hh <- parseTwoDigits
	    mm <- parseTwoDigits
	    ss <- parseTwoDigits
	    checkHours hh
	    checkMinutes mm
	    checkSeconds ss
	    return $ ISOTime (Hour hh) (Minute mm) (Second ss) LocalTime)
  <|>
  -- 5.3.1.2, local time, reduced precision, basic format: hhmm ; hh
  (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)
  <|>
  -- 5.3.1.4.a, local time, truncated, basic format: -mmss
  (try $ do skipHyphen
	    mm <- parseTwoDigits
	    ss <- parseTwoDigits
	    checkMinutes mm
	    checkSeconds ss
	    return $ ISOTime ImplicitHour (Minute mm) (Second ss) LocalTime)
  <|>
  -- 5.3.1.4.b, local time, truncated, basic format: -mm
  (try $ do skipHyphen
	    mm <- parseTwoDigits
	    checkMinutes mm
	    return $ ISOTime ImplicitHour (Minute mm) NoSecond LocalTime)
  <|>
  -- 5.3.1.4.c, local time, truncated, basic format: --ss
  (try $ do skipHyphen
	    skipHyphen
	    ss <- parseTwoDigits
	    checkSeconds ss
	    return $ ISOTime ImplicitHour ImplicitMinute (Second ss) LocalTime)
  

parseLocalTimeInternal True =
  -- 5.3.1.1, local time, extended format: hh:mm:ss
  (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)
  <|>
  -- 5.3.1.2, local time, reduced precision, extended format: hh:mm
  (try $ do hh <- parseTwoDigits
	    skipColon
	    mm <- parseTwoDigits
	    checkHours hh
	    checkMinutes mm
	    return $ ISOTime (Hour hh) (Minute mm) NoSecond LocalTime)
  <|>
  -- 5.3.1.4.a, local time, truncated, extended format: -mm:ss
  (try $ do skipHyphen
	    mm <- parseTwoDigits
	    skipColon
	    ss <- parseTwoDigits
	    checkMinutes mm
	    checkSeconds ss
	    return $ ISOTime ImplicitHour (Minute mm) (Second ss) LocalTime)

-- make ISOTime, ISODate, ISODateAndTime instances of Read
instance Read ISOTime where
  readsPrec i = parserToRead parseTime

instance Read ISODate where
  readsPrec i = parserToRead parseDate

instance Read ISODateAndTime where
  readsPrec i = parserToRead parseDateAndTime
-- auxiliary parsers

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)