Instances.hs

{-# LANGUAGE Safe #-}

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

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

import Control.Applicative ((<|>))
import Data.Char
import Data.Fixed
import Data.List (elemIndex, find)
import Data.Ratio
import Data.Time.Calendar.CalendarDiffDays
import Data.Time.Calendar.Days
import Data.Time.Calendar.Gregorian
import Data.Time.Calendar.Month
import Data.Time.Calendar.OrdinalDate
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