lib/Data/Time/Format/Parse/Instances.hs

    {-# LANGUAGE Safe #-}
    {-# OPTIONS -fno-warn-orphans #-}

    module Data.Time.Format.Parse.Instances
        (
        ) where

    #if MIN_VERSION_base(4,13,0)
    import Control.Applicative ((<|>))
    #else
    import Control.Applicative ((<$>), (<*>), (<|>))
    #endif
    import Data.Char
    import Data.Fixed
    import Data.List (elemIndex,find)
    import Data.Ratio
    import Data.Time.Calendar.Types
    import Data.Time.Calendar.CalendarDiffDays
    import Data.Time.Calendar.Days
    import Data.Time.Calendar.Gregorian
    import Data.Time.Calendar.OrdinalDate
    import Data.Time.Calendar.Month
    import Data.Time.Calendar.Private (clipValid)
    import Data.Time.Calendar.WeekDate
    import Data.Time.Clock.Internal.DiffTime
    import Data.Time.Clock.Internal.NominalDiffTime
    import Data.Time.Clock.Internal.UTCTime
    import Data.Time.Clock.Internal.UniversalTime
    import Data.Time.Clock.POSIX
    import Data.Time.Format.Locale
    import Data.Time.Format.Parse.Class
    import Data.Time.LocalTime.Internal.CalendarDiffTime
    import Data.Time.LocalTime.Internal.LocalTime
    import Data.Time.LocalTime.Internal.TimeOfDay
    import Data.Time.LocalTime.Internal.TimeZone
    import Data.Time.LocalTime.Internal.ZonedTime
    import Data.Traversable
    import Text.Read (readMaybe)

    data DayComponent
        = DCCentury Integer -- century of all years
        | DCCenturyYear Integer -- 0-99, last two digits of both real years and week years
        | DCYearMonth MonthOfYear -- 1-12
        | DCMonthDay DayOfMonth -- 1-31
        | DCYearDay DayOfYear -- 1-366
        | DCWeekDay Int -- 1-7 (mon-sun)
        | DCYearWeek WeekType
                   WeekOfYear -- 1-53 or 0-53

    data WeekType
        = ISOWeek
        | SundayWeek
        | MondayWeek

    makeDayComponent :: TimeLocale -> Char -> String -> Maybe [DayComponent]
    makeDayComponent l c x = let
        ra :: (Read a) => Maybe a
        ra = readMaybe x
        zeroBasedListIndex :: [String] -> Maybe Int
        zeroBasedListIndex ss = elemIndex (map toUpper x) $ fmap (map toUpper) ss
        oneBasedListIndex :: [String] -> Maybe Int
        oneBasedListIndex ss = do
            index <- zeroBasedListIndex ss
            return $ 1 + index
        in case c of
        -- %C: century (all but the last two digits of the year), 00 - 99
                'C' -> do
                    a <- ra
                    return [DCCentury a]
        -- %f century (all but the last two digits of the year), 00 - 99
                'f' -> do
                    a <- ra
                    return [DCCentury a]
        -- %Y: year
                'Y' -> do
                    a <- ra
                    return [DCCentury (a `div` 100), DCCenturyYear (a `mod` 100)]
        -- %G: year for Week Date format
                'G' -> do
                    a <- ra
                    return [DCCentury (a `div` 100), DCCenturyYear (a `mod` 100)]
        -- %y: last two digits of year, 00 - 99
                'y' -> do
                    a <- ra
                    return [DCCenturyYear a]
        -- %g: last two digits of year for Week Date format, 00 - 99
                'g' -> do
                    a <- ra
                    return [DCCenturyYear a]
        -- %B: month name, long form (fst from months locale), January - December
                'B' -> do
                    a <- oneBasedListIndex $ fmap fst $ months l
                    return [DCYearMonth a]
        -- %b: month name, short form (snd from months locale), Jan - Dec
                'b' -> do
                    a <- oneBasedListIndex $ fmap snd $ months l
                    return [DCYearMonth a]
        -- %m: month of year, leading 0 as needed, 01 - 12
                'm' -> do
                    raw <- ra
                    a <- clipValid 1 12 raw
                    return [DCYearMonth a]
        -- %d: day of month, leading 0 as needed, 01 - 31
                'd' -> do
                    raw <- ra
                    a <- clipValid 1 31 raw
                    return [DCMonthDay a]
        -- %e: day of month, leading space as needed, 1 - 31
                'e' -> do
                    raw <- ra
                    a <- clipValid 1 31 raw
                    return [DCMonthDay a]
        -- %V: week for Week Date format, 01 - 53
                'V' -> do
                    raw <- ra
                    a <- clipValid 1 53 raw
                    return [DCYearWeek ISOWeek a]
        -- %U: week number of year, where weeks start on Sunday (as sundayStartWeek), 00 - 53
                'U' -> do
                    raw <- ra
                    a <- clipValid 0 53 raw
                    return [DCYearWeek SundayWeek a]
        -- %W: week number of year, where weeks start on Monday (as mondayStartWeek), 00 - 53
                'W' -> do
                    raw <- ra
                    a <- clipValid 0 53 raw
                    return [DCYearWeek MondayWeek a]
        -- %u: day for Week Date format, 1 - 7
                'u' -> do
                    raw <- ra
                    a <- clipValid 1 7 raw
                    return [DCWeekDay a]
        -- %a: day of week, short form (snd from wDays locale), Sun - Sat
                'a' -> do
                    a' <- zeroBasedListIndex $ fmap snd $ wDays l
                    let
                        a =
                            if a' == 0
                                then 7
                                else a'
                    return [DCWeekDay a]
        -- %A: day of week, long form (fst from wDays locale), Sunday - Saturday
                'A' -> do
                    a' <- zeroBasedListIndex $ fmap fst $ wDays l
                    let
                        a =
                            if a' == 0
                                then 7
                                else a'
                    return [DCWeekDay a]
        -- %w: day of week number, 0 (= Sunday) - 6 (= Saturday)
                'w' -> do
                    raw <- ra
                    a' <- clipValid 0 6 raw
                    let
                        a =
                            if a' == 0
                                then 7
                                else a'
                    return [DCWeekDay a]
        -- %j: day of year for Ordinal Date format, 001 - 366
                'j' -> do
                    raw <- ra
                    a <- clipValid 1 366 raw
                    return [DCYearDay a]
        -- unrecognised, pass on to other parsers
                _ -> return []

    makeDayComponents :: TimeLocale -> [(Char,String)] -> Maybe [DayComponent]
    makeDayComponents l pairs =  do
        components <- for pairs $ \(c, x) -> makeDayComponent l c x
        return $ concat components

    safeLast :: a -> [a] -> a
    safeLast x xs = last (x : xs)

    instance ParseTime Day where
        substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
        parseTimeSpecifier _ = timeParseTimeSpecifier
        buildTime l pairs = do
            cs <- makeDayComponents l pairs
            -- 'Nothing' indicates a parse failure,
            -- while 'Just []' means no information
            let
                y = let
                    d = safeLast 70 [x | DCCenturyYear x <- cs]
                    c =
                        safeLast
                            (if d >= 69
                                 then 19
                                 else 20)
                            [x | DCCentury x <- cs]
                    in 100 * c + d
                rest (DCYearMonth m:_) = let
                    d = safeLast 1 [x | DCMonthDay x <- cs]
                    in fromGregorianValid y m d
                rest (DCYearDay d:_) = fromOrdinalDateValid y d
                rest (DCYearWeek wt w:_) = let
                    d = safeLast 4 [x | DCWeekDay x <- cs]
                    in case wt of
                           ISOWeek -> fromWeekDateValid y w d
                           SundayWeek -> fromSundayStartWeekValid y w (d `mod` 7)
                           MondayWeek -> fromMondayStartWeekValid y w d
                rest (_:xs) = rest xs
                rest [] = rest [DCYearMonth 1]
            rest cs

    instance ParseTime Month where
        substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
        parseTimeSpecifier _ = timeParseTimeSpecifier
        buildTime l pairs = do
            cs <- makeDayComponents l pairs
            -- 'Nothing' indicates a parse failure,
            -- while 'Just []' means no information
            let
                y = let
                    d = safeLast 70 [x | DCCenturyYear x <- cs]
                    c =
                        safeLast
                            (if d >= 69
                                 then 19
                                 else 20)
                            [x | DCCentury x <- cs]
                    in 100 * c + d
                rest (DCYearMonth m:_) = fromYearMonthValid y m
                rest (_:xs) = rest xs
                rest [] = fromYearMonthValid y 1
            rest cs

    mfoldl :: (Monad m) => (a -> b -> m a) -> m a -> [b] -> m a
    mfoldl f = let
        mf ma b = do
            a <- ma
            f a b
        in foldl mf

    instance ParseTime TimeOfDay where
        substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
        parseTimeSpecifier _ = timeParseTimeSpecifier
        buildTime l = let
            f t@(TimeOfDay h m s) (c, x) = let
                ra :: (Read a) => Maybe a
                ra = readMaybe x
                getAmPm = let
                    upx = map toUpper x
                    (amStr, pmStr) = amPm l
                    in if upx == amStr
                           then Just $ TimeOfDay (h `mod` 12) m s
                           else if upx == pmStr
                                    then Just $
                                         TimeOfDay
                                             (if h < 12
                                                  then h + 12
                                                  else h)
                                             m
                                             s
                                    else Nothing
                in case c of
                       'P' -> getAmPm
                       'p' -> getAmPm
                       'H' -> do
                           raw <- ra
                           a <- clipValid 0 23 raw
                           return $ TimeOfDay a m s
                       'I' -> do
                           raw <- ra
                           a <- clipValid 1 12 raw
                           return $ TimeOfDay a m s
                       'k' -> do
                           raw <- ra
                           a <- clipValid 0 23 raw
                           return $ TimeOfDay a m s
                       'l' -> do
                           raw <- ra
                           a <- clipValid 1 12 raw
                           return $ TimeOfDay a m s
                       'M' -> do
                           raw <- ra
                           a <- clipValid 0 59 raw
                           return $ TimeOfDay h a s
                       'S' -> do
                           raw <- ra
                           a <- clipValid 0 60 raw
                           return $ TimeOfDay h m (fromInteger a)
                       'q' -> do
                           ps <- (readMaybe $ take 12 $ rpad 12 '0' x) <|> return 0
                           return $ TimeOfDay h m (mkPico (floor s) ps)
                       'Q' ->
                           if null x
                               then Just t
                               else do
                                   ps <- (readMaybe $ take 12 $ rpad 12 '0' x) <|> return 0
                                   return $ TimeOfDay h m (mkPico (floor s) ps)
                       _ -> Just t
            in mfoldl f (Just midnight)

    rpad :: Int -> a -> [a] -> [a]
    rpad n c xs = xs ++ replicate (n - length xs) c

    mkPico :: Integer -> Integer -> Pico
    mkPico i f = fromInteger i + fromRational (f % 1000000000000)

    instance ParseTime LocalTime where
        substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
        parseTimeSpecifier _ = timeParseTimeSpecifier
        buildTime l xs = LocalTime <$> (buildTime l xs) <*> (buildTime l xs)

    enumDiff :: (Enum a) => a -> a -> Int
    enumDiff a b = (fromEnum a) - (fromEnum b)

    getMilZoneHours :: Char -> Maybe Int
    getMilZoneHours c
        | c < 'A' = Nothing
    getMilZoneHours c
        | c <= 'I' = Just $ 1 + enumDiff c 'A'
    getMilZoneHours 'J' = Nothing
    getMilZoneHours c
        | c <= 'M' = Just $ 10 + enumDiff c 'K'
    getMilZoneHours c
        | c <= 'Y' = Just $ (enumDiff 'N' c) - 1
    getMilZoneHours 'Z' = Just 0
    getMilZoneHours _ = Nothing

    getMilZone :: Char -> Maybe TimeZone
    getMilZone c = let
        yc = toUpper c
        in do
               hours <- getMilZoneHours yc
               return $ TimeZone (hours * 60) False [yc]

    getKnownTimeZone :: TimeLocale -> String -> Maybe TimeZone
    getKnownTimeZone locale x = find (\tz -> map toUpper x == timeZoneName tz) (knownTimeZones locale)

    instance ParseTime TimeZone where
        substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
        parseTimeSpecifier _ = timeParseTimeSpecifier
        buildTime l = let
            f :: Char -> String -> TimeZone -> Maybe TimeZone
            f 'z' str (TimeZone _ dst name)
                | Just offset <- readTzOffset str = Just $ TimeZone offset dst name
            f 'z' _ _ = Nothing
            f 'Z' str _
                | Just offset <- readTzOffset str = Just $ TimeZone offset False ""
            f 'Z' str _
                | Just zone <- getKnownTimeZone l str = Just zone
            f 'Z' "UTC" _ = Just utc
            f 'Z' [c] _
                | Just zone <- getMilZone c = Just zone
            f 'Z' _ _ = Nothing
            f _ _ tz = Just tz
            in foldl (\mt (c, s) -> mt >>= f c s) (Just $ minutesToTimeZone 0)

    readTzOffset :: String -> Maybe Int
    readTzOffset str = let
        getSign '+' = Just 1
        getSign '-' = Just (-1)
        getSign _ = Nothing
        calc s h1 h2 m1 m2 = do
            sign <- getSign s
            h <- readMaybe [h1, h2]
            m <- readMaybe [m1, m2]
            return $ sign * (60 * h + m)
        in case str of
               (s:h1:h2:':':m1:m2:[]) -> calc s h1 h2 m1 m2
               (s:h1:h2:m1:m2:[]) -> calc s h1 h2 m1 m2
               _ -> Nothing

    instance ParseTime ZonedTime where
        substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
        parseTimeSpecifier _ = timeParseTimeSpecifier
        buildTime l xs = let
            f (ZonedTime (LocalTime _ tod) z) ('s', x) = do
                a <- readMaybe x
                let
                    s = fromInteger a
                    (_, ps) = properFraction (todSec tod) :: (Integer, Pico)
                    s' = s + fromRational (toRational ps)
                return $ utcToZonedTime z (posixSecondsToUTCTime s')
            f t _ = Just t
            in mfoldl f (ZonedTime <$> (buildTime l xs) <*> (buildTime l xs)) xs

    instance ParseTime UTCTime where
        substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
        parseTimeSpecifier _ = timeParseTimeSpecifier
        buildTime l xs = zonedTimeToUTC <$> buildTime l xs

    instance ParseTime UniversalTime where
        substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
        parseTimeSpecifier _ = timeParseTimeSpecifier
        buildTime l xs = localTimeToUT1 0 <$> buildTime l xs

    buildTimeMonths :: [(Char, String)] -> Maybe Integer
    buildTimeMonths xs = do
        tt <-
            for xs $ \(c, s) ->
                case c of
                    'y' -> fmap ((*) 12) $ readMaybe s
                    'b' -> readMaybe s
                    'B' -> readMaybe s
                    _ -> return 0
        return $ sum tt

    buildTimeDays :: [(Char, String)] -> Maybe Integer
    buildTimeDays xs = do
        tt <-
            for xs $ \(c, s) ->
                case c of
                    'w' -> fmap ((*) 7) $ readMaybe s
                    'd' -> readMaybe s
                    'D' -> readMaybe s
                    _ -> return 0
        return $ sum tt

    buildTimeSeconds :: [(Char, String)] -> Maybe Pico
    buildTimeSeconds xs = do
        tt <-
            for xs $ \(c, s) -> let
                readInt :: Integer -> Maybe Pico
                readInt t = do
                    i <- readMaybe s
                    return $ fromInteger $ i * t
                in case c of
                       'h' -> readInt 3600
                       'H' -> readInt 3600
                       'm' -> readInt 60
                       'M' -> readInt 60
                       's' -> readMaybe s
                       'S' -> readMaybe s
                       _ -> return 0
        return $ sum tt

    instance ParseTime NominalDiffTime where
        parseTimeSpecifier _ = durationParseTimeSpecifier
        buildTime _ xs = do
            dd <- buildTimeDays xs
            tt <- buildTimeSeconds xs
            return $ (fromInteger dd * 86400) + realToFrac tt

    instance ParseTime DiffTime where
        parseTimeSpecifier _ = durationParseTimeSpecifier
        buildTime _ xs = do
            dd <- buildTimeDays xs
            tt <- buildTimeSeconds xs
            return $ (fromInteger dd * 86400) + realToFrac tt

    instance ParseTime CalendarDiffDays where
        parseTimeSpecifier _ = durationParseTimeSpecifier
        buildTime _ xs = do
            mm <- buildTimeMonths xs
            dd <- buildTimeDays xs
            return $ CalendarDiffDays mm dd

    instance ParseTime CalendarDiffTime where
        parseTimeSpecifier _ = durationParseTimeSpecifier
        buildTime locale xs = do
            mm <- buildTimeMonths xs
            tt <- buildTime locale xs
            return $ CalendarDiffTime mm tt