ISO8601.hs

{-# LANGUAGE Safe #-}

module Data.Time.Format.ISO8601
    (
        -- * Format
      Format
    , formatShowM
    , formatShow
    , formatReadP
    , formatParseM
        -- * Common formats
    , ISO8601(..)
    , iso8601Show
    , iso8601ParseM
        -- * All formats
    , FormatExtension(..)
    , formatReadPExtension
    , parseFormatExtension
    , calendarFormat
    , yearMonthFormat
    , yearFormat
    , centuryFormat
    , expandedCalendarFormat
    , expandedYearMonthFormat
    , expandedYearFormat
    , expandedCenturyFormat
    , ordinalDateFormat
    , expandedOrdinalDateFormat
    , weekDateFormat
    , yearWeekFormat
    , expandedWeekDateFormat
    , expandedYearWeekFormat
    , timeOfDayFormat
    , hourMinuteFormat
    , hourFormat
    , withTimeDesignator
    , withUTCDesignator
    , timeOffsetFormat
    , timeOfDayAndOffsetFormat
    , localTimeFormat
    , zonedTimeFormat
    , utcTimeFormat
    , dayAndTimeFormat
    , timeAndOffsetFormat
    , durationDaysFormat
    , durationTimeFormat
    , alternativeDurationDaysFormat
    , alternativeDurationTimeFormat
    , intervalFormat
    , recurringIntervalFormat
    ) where

import Control.Monad.Fail
import Data.Fixed
import Data.Format
import Data.Ratio
import Data.Time
import Data.Time.Calendar.OrdinalDate
import Data.Time.Calendar.Private
import Data.Time.Calendar.WeekDate
import Prelude hiding (fail)
import Text.ParserCombinators.ReadP

data FormatExtension
    = 
    -- | ISO 8601:2004(E) sec. 2.3.4. Use hyphens and colons.
      ExtendedFormat
    -- | ISO 8601:2004(E) sec. 2.3.3. Omit hyphens and colons. "The basic format should be avoided in plain text."
    | BasicFormat

-- | Read a value in either extended or basic format
formatReadPExtension :: (FormatExtension -> Format t) -> ReadP t
formatReadPExtension ff = formatReadP (ff ExtendedFormat) +++ formatReadP (ff BasicFormat)

-- | Parse a value in either extended or basic format
parseFormatExtension :: (MonadFail m) => (FormatExtension -> Format t) -> String -> m t
parseFormatExtension ff = parseReader $ formatReadPExtension ff

sepFormat :: String -> Format a -> Format b -> Format (a, b)
sepFormat sep fa fb = (fa <** literalFormat sep) <**> fb

dashFormat :: Format a -> Format b -> Format (a, b)
dashFormat = sepFormat "-"

colnFormat :: Format a -> Format b -> Format (a, b)
colnFormat = sepFormat ":"

extDashFormat :: FormatExtension -> Format a -> Format b -> Format (a, b)
extDashFormat ExtendedFormat = dashFormat
extDashFormat BasicFormat = (<**>)

extColonFormat :: FormatExtension -> Format a -> Format b -> Format (a, b)
extColonFormat ExtendedFormat = colnFormat
extColonFormat BasicFormat = (<**>)

expandedYearFormat' :: Int -> Format Integer
expandedYearFormat' n = integerFormat PosNegSign (Just n)

yearFormat' :: Format Integer
yearFormat' = integerFormat NegSign (Just 4)

monthFormat :: Format Int
monthFormat = integerFormat NoSign (Just 2)

dayOfMonthFormat :: Format Int
dayOfMonthFormat = integerFormat NoSign (Just 2)

dayOfYearFormat :: Format Int
dayOfYearFormat = integerFormat NoSign (Just 3)

weekOfYearFormat :: Format Int
weekOfYearFormat = literalFormat "W" **> integerFormat NoSign (Just 2)

dayOfWeekFormat :: Format Int
dayOfWeekFormat = integerFormat NoSign (Just 1)

hourFormat' :: Format Int
hourFormat' = integerFormat NoSign (Just 2)

data E14

instance HasResolution E14 where
    resolution _ = 100000000000000

data E16

instance HasResolution E16 where
    resolution _ = 10000000000000000

hourDecimalFormat :: Format (Fixed E16) -- need four extra decimal places for hours
hourDecimalFormat = decimalFormat NoSign (Just 2)

minuteFormat :: Format Int
minuteFormat = integerFormat NoSign (Just 2)

minuteDecimalFormat :: Format (Fixed E14) -- need two extra decimal places for minutes
minuteDecimalFormat = decimalFormat NoSign (Just 2)

secondFormat :: Format Pico
secondFormat = decimalFormat NoSign (Just 2)

mapGregorian :: Format (Integer, (Int, Int)) -> Format Day
mapGregorian =
    mapMFormat (\(y, (m, d)) -> fromGregorianValid y m d) (\day -> (\(y, m, d) -> Just (y, (m, d))) $ toGregorian day)

mapOrdinalDate :: Format (Integer, Int) -> Format Day
mapOrdinalDate = mapMFormat (\(y, d) -> fromOrdinalDateValid y d) (Just . toOrdinalDate)

mapWeekDate :: Format (Integer, (Int, Int)) -> Format Day
mapWeekDate =
    mapMFormat (\(y, (w, d)) -> fromWeekDateValid y w d) (\day -> (\(y, w, d) -> Just (y, (w, d))) $ toWeekDate day)

mapTimeOfDay :: Format (Int, (Int, Pico)) -> Format TimeOfDay
mapTimeOfDay = mapMFormat (\(h, (m, s)) -> makeTimeOfDayValid h m s) (\(TimeOfDay h m s) -> Just (h, (m, s)))

-- | ISO 8601:2004(E) sec. 4.1.2.2
calendarFormat :: FormatExtension -> Format Day
calendarFormat fe = mapGregorian $ extDashFormat fe yearFormat $ extDashFormat fe monthFormat dayOfMonthFormat

-- | ISO 8601:2004(E) sec. 4.1.2.3(a)
yearMonthFormat :: Format (Integer, Int)
yearMonthFormat = yearFormat <**> literalFormat "-" **> monthFormat

-- | ISO 8601:2004(E) sec. 4.1.2.3(b)
yearFormat :: Format Integer
yearFormat = yearFormat'

-- | ISO 8601:2004(E) sec. 4.1.2.3(c)
centuryFormat :: Format Integer
centuryFormat = integerFormat NegSign (Just 2)

-- | ISO 8601:2004(E) sec. 4.1.2.4(a)
expandedCalendarFormat :: Int -> FormatExtension -> Format Day
expandedCalendarFormat n fe =
    mapGregorian $ extDashFormat fe (expandedYearFormat n) $ extDashFormat fe monthFormat dayOfMonthFormat

-- | ISO 8601:2004(E) sec. 4.1.2.4(b)
expandedYearMonthFormat :: Int -> Format (Integer, Int)
expandedYearMonthFormat n = dashFormat (expandedYearFormat n) monthFormat

-- | ISO 8601:2004(E) sec. 4.1.2.4(c)
expandedYearFormat :: Int -> Format Integer
expandedYearFormat = expandedYearFormat'

-- | ISO 8601:2004(E) sec. 4.1.2.4(d)
expandedCenturyFormat :: Int -> Format Integer
expandedCenturyFormat n = integerFormat PosNegSign (Just n)

-- | ISO 8601:2004(E) sec. 4.1.3.2
ordinalDateFormat :: FormatExtension -> Format Day
ordinalDateFormat fe = mapOrdinalDate $ extDashFormat fe yearFormat dayOfYearFormat

-- | ISO 8601:2004(E) sec. 4.1.3.3
expandedOrdinalDateFormat :: Int -> FormatExtension -> Format Day
expandedOrdinalDateFormat n fe = mapOrdinalDate $ extDashFormat fe (expandedYearFormat n) dayOfYearFormat

-- | ISO 8601:2004(E) sec. 4.1.4.2
weekDateFormat :: FormatExtension -> Format Day
weekDateFormat fe = mapWeekDate $ extDashFormat fe yearFormat $ extDashFormat fe weekOfYearFormat dayOfWeekFormat

-- | ISO 8601:2004(E) sec. 4.1.4.3
yearWeekFormat :: FormatExtension -> Format (Integer, Int)
yearWeekFormat fe = extDashFormat fe yearFormat weekOfYearFormat

-- | ISO 8601:2004(E) sec. 4.1.4.2
expandedWeekDateFormat :: Int -> FormatExtension -> Format Day
expandedWeekDateFormat n fe =
    mapWeekDate $ extDashFormat fe (expandedYearFormat n) $ extDashFormat fe weekOfYearFormat dayOfWeekFormat

-- | ISO 8601:2004(E) sec. 4.1.4.3
expandedYearWeekFormat :: Int -> FormatExtension -> Format (Integer, Int)
expandedYearWeekFormat n fe = extDashFormat fe (expandedYearFormat n) weekOfYearFormat

-- | ISO 8601:2004(E) sec. 4.2.2.2, 4.2.2.4(a)
timeOfDayFormat :: FormatExtension -> Format TimeOfDay
timeOfDayFormat fe = mapTimeOfDay $ extColonFormat fe hourFormat' $ extColonFormat fe minuteFormat secondFormat

-- workaround for the 'fromRational' in 'Fixed', which uses 'floor' instead of 'round'
fromRationalRound :: Rational -> NominalDiffTime
fromRationalRound r = fromRational $ round (r * 1000000000000) % 1000000000000

-- | ISO 8601:2004(E) sec. 4.2.2.3(a), 4.2.2.4(b)
hourMinuteFormat :: FormatExtension -> Format TimeOfDay
hourMinuteFormat fe = let
    toTOD (h, m) =
        case timeToDaysAndTimeOfDay $ fromRationalRound $ toRational $ (fromIntegral h) * 3600 + m * 60 of
            (0, tod) -> Just tod
            _ -> Nothing
    fromTOD tod = let
        mm = (realToFrac $ daysAndTimeOfDayToTime 0 tod) / 60
        in Just $ quotRemBy 60 mm
    in mapMFormat toTOD fromTOD $ extColonFormat fe hourFormat' $ minuteDecimalFormat

-- | ISO 8601:2004(E) sec. 4.2.2.3(b), 4.2.2.4(c)
hourFormat :: Format TimeOfDay
hourFormat = let
    toTOD h =
        case timeToDaysAndTimeOfDay $ fromRationalRound $ toRational $ h * 3600 of
            (0, tod) -> Just tod
            _ -> Nothing
    fromTOD tod = Just $ (realToFrac $ daysAndTimeOfDayToTime 0 tod) / 3600
    in mapMFormat toTOD fromTOD $ hourDecimalFormat

-- | ISO 8601:2004(E) sec. 4.2.2.5
withTimeDesignator :: Format t -> Format t
withTimeDesignator f = literalFormat "T" **> f

-- | ISO 8601:2004(E) sec. 4.2.4
withUTCDesignator :: Format t -> Format t
withUTCDesignator f = f <** literalFormat "Z"

-- | ISO 8601:2004(E) sec. 4.2.5.1
timeOffsetFormat :: FormatExtension -> Format TimeZone
timeOffsetFormat fe = let
    toTimeZone (sign, (h, m)) = minutesToTimeZone $ sign * (h * 60 + m)
    fromTimeZone tz = let
        mm = timeZoneMinutes tz
        hm = quotRem (abs mm) 60
        in (signum mm, hm)
    in isoMap toTimeZone fromTimeZone $
       mandatorySignFormat <**> extColonFormat fe (integerFormat NoSign (Just 2)) (integerFormat NoSign (Just 2))

-- | ISO 8601:2004(E) sec. 4.2.5.2
timeOfDayAndOffsetFormat :: FormatExtension -> Format (TimeOfDay, TimeZone)
timeOfDayAndOffsetFormat fe = timeOfDayFormat fe <**> timeOffsetFormat fe

-- | ISO 8601:2004(E) sec. 4.3.2
localTimeFormat :: Format Day -> Format TimeOfDay -> Format LocalTime
localTimeFormat fday ftod =
    isoMap (\(day, tod) -> LocalTime day tod) (\(LocalTime day tod) -> (day, tod)) $ fday <**> withTimeDesignator ftod

-- | ISO 8601:2004(E) sec. 4.3.2
zonedTimeFormat :: Format Day -> Format TimeOfDay -> FormatExtension -> Format ZonedTime
zonedTimeFormat fday ftod fe =
    isoMap (\(lt, tz) -> ZonedTime lt tz) (\(ZonedTime lt tz) -> (lt, tz)) $
    timeAndOffsetFormat (localTimeFormat fday ftod) fe

-- | ISO 8601:2004(E) sec. 4.3.2
utcTimeFormat :: Format Day -> Format TimeOfDay -> Format UTCTime
utcTimeFormat fday ftod =
    isoMap (localTimeToUTC utc) (utcToLocalTime utc) $ withUTCDesignator $ localTimeFormat fday ftod

-- | ISO 8601:2004(E) sec. 4.3.3
dayAndTimeFormat :: Format Day -> Format time -> Format (Day, time)
dayAndTimeFormat fday ft = fday <**> withTimeDesignator ft

-- | ISO 8601:2004(E) sec. 4.3.3
timeAndOffsetFormat :: Format t -> FormatExtension -> Format (t, TimeZone)
timeAndOffsetFormat ft fe = ft <**> timeOffsetFormat fe

intDesignator :: (Eq t, Show t, Read t, Num t) => Char -> Format t
intDesignator c = optionalFormat 0 $ integerFormat NoSign Nothing <** literalFormat [c]

decDesignator :: (Eq t, Show t, Read t, Num t) => Char -> Format t
decDesignator c = optionalFormat 0 $ decimalFormat NoSign Nothing <** literalFormat [c]

daysDesigs :: Format CalendarDiffDays
daysDesigs = let
    toCD (y, (m, (w, d))) = CalendarDiffDays (y * 12 + m) (w * 7 + d)
    fromCD (CalendarDiffDays mm d) = (quot mm 12, (rem mm 12, (0, d)))
    in isoMap toCD fromCD $ intDesignator 'Y' <**> intDesignator 'M' <**> intDesignator 'W' <**> intDesignator 'D'

-- | ISO 8601:2004(E) sec. 4.4.3.2
durationDaysFormat :: Format CalendarDiffDays
durationDaysFormat = (**>) (literalFormat "P") $ specialCaseShowFormat (mempty, "0D") $ daysDesigs

-- | ISO 8601:2004(E) sec. 4.4.3.2
durationTimeFormat :: Format CalendarDiffTime
durationTimeFormat = let
    toCT (cd, (h, (m, s))) =
        mappend (calendarTimeDays cd) (calendarTimeTime $ daysAndTimeOfDayToTime 0 $ TimeOfDay h m s)
    fromCT (CalendarDiffTime mm t) = let
        (d, TimeOfDay h m s) = timeToDaysAndTimeOfDay t
        in (CalendarDiffDays mm d, (h, (m, s)))
    in (**>) (literalFormat "P") $
       specialCaseShowFormat (mempty, "0D") $
       isoMap toCT fromCT $
       (<**>) daysDesigs $
       optionalFormat (0, (0, 0)) $
       literalFormat "T" **> intDesignator 'H' <**> intDesignator 'M' <**> decDesignator 'S'

-- | ISO 8601:2004(E) sec. 4.4.3.3
alternativeDurationDaysFormat :: FormatExtension -> Format CalendarDiffDays
alternativeDurationDaysFormat fe = let
    toCD (y, (m, d)) = CalendarDiffDays (y * 12 + m) d
    fromCD (CalendarDiffDays mm d) = (quot mm 12, (rem mm 12, d))
    in isoMap toCD fromCD $
       (**>) (literalFormat "P") $
       extDashFormat fe (clipFormat (0, 9999) $ integerFormat NegSign $ Just 4) $
       extDashFormat fe (clipFormat (0, 12) $ integerFormat NegSign $ Just 2) $
       (clipFormat (0, 30) $ integerFormat NegSign $ Just 2)

-- | ISO 8601:2004(E) sec. 4.4.3.3
alternativeDurationTimeFormat :: FormatExtension -> Format CalendarDiffTime
alternativeDurationTimeFormat fe = let
    toCT (cd, (h, (m, s))) =
        mappend (calendarTimeDays cd) (calendarTimeTime $ daysAndTimeOfDayToTime 0 $ TimeOfDay h m s)
    fromCT (CalendarDiffTime mm t) = let
        (d, TimeOfDay h m s) = timeToDaysAndTimeOfDay t
        in (CalendarDiffDays mm d, (h, (m, s)))
    in isoMap toCT fromCT $
       (<**>) (alternativeDurationDaysFormat fe) $
       withTimeDesignator $
       extColonFormat fe (clipFormat (0, 24) $ integerFormat NegSign (Just 2)) $
       extColonFormat fe (clipFormat (0, 60) $ integerFormat NegSign (Just 2)) $
       (clipFormat (0, 60) $ decimalFormat NegSign (Just 2))

-- | ISO 8601:2004(E) sec. 4.4.4.1
intervalFormat :: Format a -> Format b -> Format (a, b)
intervalFormat = sepFormat "/"

-- | ISO 8601:2004(E) sec. 4.5
recurringIntervalFormat :: Format a -> Format b -> Format (Int, a, b)
recurringIntervalFormat fa fb =
    isoMap (\(r, (a, b)) -> (r, a, b)) (\(r, a, b) -> (r, (a, b))) $
    sepFormat "/" (literalFormat "R" **> integerFormat NoSign Nothing) $ intervalFormat fa fb

class ISO8601 t where
    -- | The most commonly used ISO 8601 format for this type.
    iso8601Format :: Format t

-- | Show in the most commonly used ISO 8601 format.
iso8601Show :: ISO8601 t => t -> String
iso8601Show = formatShow iso8601Format

-- | Parse the most commonly used ISO 8601 format.
iso8601ParseM :: (MonadFail m, ISO8601 t) => String -> m t
iso8601ParseM = formatParseM iso8601Format

-- | @yyyy-mm-dd@ (ISO 8601:2004(E) sec. 4.1.2.2 extended format)
instance ISO8601 Day where
    iso8601Format = calendarFormat ExtendedFormat

-- | @hh:mm:ss[.sss]@ (ISO 8601:2004(E) sec. 4.2.2.2, 4.2.2.4(a) extended format)
instance ISO8601 TimeOfDay where
    iso8601Format = timeOfDayFormat ExtendedFormat

-- | @±hh:mm@ (ISO 8601:2004(E) sec. 4.2.5.1 extended format)
instance ISO8601 TimeZone where
    iso8601Format = timeOffsetFormat ExtendedFormat

-- | @yyyy-mm-ddThh:mm:ss[.sss]@ (ISO 8601:2004(E) sec. 4.3.2 extended format)
instance ISO8601 LocalTime where
    iso8601Format = localTimeFormat iso8601Format iso8601Format

-- | @yyyy-mm-ddThh:mm:ss[.sss]±hh:mm@ (ISO 8601:2004(E) sec. 4.3.2 extended format)
instance ISO8601 ZonedTime where
    iso8601Format = zonedTimeFormat iso8601Format iso8601Format ExtendedFormat

-- | @yyyy-mm-ddThh:mm:ss[.sss]Z@ (ISO 8601:2004(E) sec. 4.3.2 extended format)
instance ISO8601 UTCTime where
    iso8601Format = utcTimeFormat iso8601Format iso8601Format

-- | @PyYmMdD@ (ISO 8601:2004(E) sec. 4.4.3.2)
instance ISO8601 CalendarDiffDays where
    iso8601Format = durationDaysFormat

-- | @PyYmMdDThHmMs[.sss]S@ (ISO 8601:2004(E) sec. 4.4.3.2)
instance ISO8601 CalendarDiffTime where
    iso8601Format = durationTimeFormat