{-# 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
