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,

    -- * Other
    isoMakeTimeOfDayValid,
) 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 Text.ParserCombinators.ReadP
import Prelude hiding (fail)

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)

-- | Like 'makeTimeOfDayValid', but accepts @24 0 0@ per ISO 8601:2004(E) sec. 4.2.3
--
-- @since 1.12
isoMakeTimeOfDayValid :: Int -> Int -> Pico -> Maybe TimeOfDay
isoMakeTimeOfDayValid 24 0 0 = return (TimeOfDay 24 0 0)
isoMakeTimeOfDayValid h m s = makeTimeOfDayValid h m s

mapTimeOfDay :: Format (Int, (Int, Pico)) -> Format TimeOfDay
mapTimeOfDay = mapMFormat (\(h, (m, s)) -> isoMakeTimeOfDayValid 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
                (1, TimeOfDay 0 0 0) -> Just $ TimeOfDay 24 0 0
                _ -> 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
                (1, TimeOfDay 0 0 0) -> Just $ TimeOfDay 24 0 0
                _ -> 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