Instances.hs

{-# OPTIONS -fno-warn-orphans #-}
module Data.Time.Format.Parse.Instances() where

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

data DayComponent = Century Integer -- century of all years
                  | CenturyYear Integer -- 0-99, last two digits of both real years and week years
                  | YearMonth Int -- 1-12
                  | MonthDay Int -- 1-31
                  | YearDay Int -- 1-366
                  | WeekDay Int -- 1-7 (mon-sun)
                  | YearWeek WeekType Int -- 1-53 or 0-53

data WeekType = ISOWeek | SundayWeek | MondayWeek

instance ParseTime Day where
    substituteTimeSpecifier _ = timeSubstituteTimeSpecifier
    parseTimeSpecifier _ = timeParseTimeSpecifier
    buildTime l = let

        -- 'Nothing' indicates a parse failure,
        -- while 'Just []' means no information
        f :: Char -> String -> Maybe [DayComponent]
        f 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 [Century a]
            -- %f century (all but the last two digits of the year), 00 - 99
            'f' -> do
                a <- ra
                return [Century a]
            -- %Y: year
            'Y' -> do
                a <- ra
                return [Century (a `div` 100), CenturyYear (a `mod` 100)]
            -- %G: year for Week Date format
            'G' -> do
                a <- ra
                return [Century (a `div` 100), CenturyYear (a `mod` 100)]
            -- %y: last two digits of year, 00 - 99
            'y' -> do
                a <- ra
                return [CenturyYear a]
            -- %g: last two digits of year for Week Date format, 00 - 99
            'g' -> do
                a <- ra
                return [CenturyYear a]
            -- %B: month name, long form (fst from months locale), January - December
            'B' -> do
                a <- oneBasedListIndex $ fmap fst $ months l
                return [YearMonth a]
            -- %b: month name, short form (snd from months locale), Jan - Dec
            'b' -> do
                a <- oneBasedListIndex $ fmap snd $ months l
                return [YearMonth a]
            -- %m: month of year, leading 0 as needed, 01 - 12
            'm' -> do
                raw <- ra
                a <- clipValid 1 12 raw
                return [YearMonth a]
            -- %d: day of month, leading 0 as needed, 01 - 31
            'd' -> do
                raw <- ra
                a <- clipValid 1 31 raw
                return [MonthDay a]
            -- %e: day of month, leading space as needed, 1 - 31
            'e' -> do
                raw <- ra
                a <- clipValid 1 31 raw
                return [MonthDay a]
            -- %V: week for Week Date format, 01 - 53
            'V' -> do
                raw <- ra
                a <- clipValid 1 53 raw
                return [YearWeek 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 [YearWeek 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 [YearWeek MondayWeek a]
            -- %u: day for Week Date format, 1 - 7
            'u' -> do
                raw <- ra
                a <- clipValid 1 7 raw
                return [WeekDay 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 [WeekDay 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 [WeekDay 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 [WeekDay a]
            -- %j: day of year for Ordinal Date format, 001 - 366
            'j' -> do
                raw <- ra
                a <- clipValid 1 366 raw
                return [YearDay a]
            -- unrecognised, pass on to other parsers
            _   -> return []

        buildDay :: [DayComponent] -> Maybe Day
        buildDay cs = let
            safeLast x xs = last (x:xs)
            y = let
                d = safeLast 70 [x | CenturyYear x <- cs]
                c = safeLast (if d >= 69 then 19 else 20) [x | Century x <- cs]
                in 100 * c + d
            rest (YearMonth m:_) = let
                d = safeLast 1 [x | MonthDay x <- cs]
                in fromGregorianValid y m d
            rest (YearDay d:_) = fromOrdinalDateValid y d
            rest (YearWeek wt w:_) = let
                d = safeLast 4 [x | WeekDay 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 [YearMonth 1]

            in rest cs

        in \pairs -> do
            components <- for pairs $ \(c,x) -> f c x
            buildDay $ concat components

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
                    a <- ra
                    return $ TimeOfDay h m (mkPico (floor s) a)
                'Q' -> if null x then Just t else do
                    ps <- readMaybe $ take 12 $ rpad 12 '0' $ drop 1 x
                    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