{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Data.Thyme.Format
    ( FormatTime (..)
    , formatTime
    , ParseTime (..)
    , parseTime
    ) where

import Prelude
import Control.Applicative
import Control.Lens
import Control.Monad.State.Strict hiding (get)
import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as P
import Data.Basis
import Data.Bits
import qualified Data.ByteString.Char8 as S
import Data.Char
import Data.Int
import Data.Micro
import Data.Thyme.Calendar
import Data.Thyme.Calendar.MonthDay
import Data.Thyme.Calendar.OrdinalDate
import Data.Thyme.Calendar.WeekDate
import Data.Thyme.Clock.POSIX
import Data.Thyme.Clock.Scale
import Data.Thyme.Clock.UTC
import Data.Thyme.Format.Internal
import Data.Thyme.LocalTime
import Data.Thyme.TH
import qualified Data.Time.Format as T
import Data.VectorSpace
import System.Locale

class FormatTime t where
    showsTime :: TimeLocale -> t -> (Char -> ShowS) -> (Char -> ShowS)

{-# INLINEABLE formatTime #-}
formatTime :: (FormatTime t) => TimeLocale -> String -> t -> String
formatTime l@TimeLocale {..} spec t = go spec "" where
    -- leave unrecognised codes as they are
    format = showsTime l t (\ c s -> '%' : c : s)
    go s = case s of
        '%' : c : rest -> case c of
            -- aggregate
            'c' -> go (dateTimeFmt ++ rest)
            'r' -> go (time12Fmt ++ rest)
            'X' -> go (timeFmt ++ rest)
            'x' -> go (dateFmt ++ rest)
            -- modifier (whatever)
            '-' -> go ('%' : rest)
            '_' -> go ('%' : rest)
            '0' -> go ('%' : rest)
            '^' -> go ('%' : rest)
            '#' -> go ('%' : rest)
            -- escape (why would anyone need %t and %n?)
            '%' -> (:) '%' . go rest
            -- default
            _ -> format c . go rest
        c : rest -> (:) c . go rest
        [] -> id

{-# INLINE showsYear #-}
showsYear :: Year -> ShowS
#if BUG_FOR_BUG
showsYear = shows
#else
-- ISO 8601 says 4 digits, even for first millennium.
showsYear = shows04
#endif

instance FormatTime TimeOfDay where
    {-# INLINEABLE showsTime #-}
    showsTime TimeLocale {..} (TimeOfDay h m (DiffTime s)) = \ def c -> case c of
        -- aggregate
        'R' -> shows02 h . (:) ':' . shows02 m
        'T' -> shows02 h . (:) ':' . shows02 m . (:) ':' . shows02 si
        -- AM/PM
        'P' -> (++) $ toLower <$> if h < 12 then fst amPm else snd amPm
        'p' -> (++) $ if h < 12 then fst amPm else snd amPm
        -- Hour
        'H' -> shows02 h
        'I' -> shows02 $ 1 + mod (h - 1) 12
        'k' -> shows_2 h
        'l' -> shows_2 $ 1 + mod (h - 1) 12
        -- Minute
        'M' -> shows02 m
        -- Second
        'S' -> shows02 si
        'q' -> fills06 su . shows su . (++) "000000"
        'Q' -> if su == 0 then id else (:) '.' . fills06 su . drops0 su
        -- default
        _ -> def c

        where
        (fromIntegral -> si, Micro su) = microQuotRem s (Micro 1000000)

        {-# INLINE fills06 #-}
        fills06 :: Int64 -> ShowS
        fills06 n
            | n < 10 = (++) "00000"
            | n < 100 = (++) "0000"
            | n < 1000 = (++) "000"
            | n < 10000 = (++) "00"
            | n < 100000 = (++) "0"
            | otherwise = id

        {-# INLINE drops0 #-}
        drops0 :: Int64 -> ShowS
        drops0 n = case divMod n 10 of
            (q, 0) -> drops0 q
            _ -> shows n

instance FormatTime YearMonthDay where
    {-# INLINEABLE showsTime #-}
    showsTime TimeLocale {..} (YearMonthDay y m d) = \ def c -> case c of
        -- aggregate
        'D' -> shows02 m . (:) '/' . shows02 d . (:) '/' . shows02 (mod y 100)
        'F' -> showsYear y . (:) '-' . shows02 m . (:) '-' . shows02 d
        -- Year
        'Y' -> showsYear y
        'y' -> shows02 (mod y 100)
        'C' -> shows02 (div y 100)
        -- Month
        'B' -> (++) . fst $ months !! (m - 1)
        'b' -> (++) . snd $ months !! (m - 1)
        'h' -> (++) . snd $ months !! (m - 1)
        'm' -> shows02 m
        -- DayOfMonth
        'd' -> shows02 d
        'e' -> shows_2 d
        -- default
        _ -> def c

instance FormatTime MonthDay where
    {-# INLINEABLE showsTime #-}
    showsTime TimeLocale {..} (MonthDay m d) = \ def c -> case c of
        -- Month
        'B' -> (++) . fst $ months !! (m - 1)
        'b' -> (++) . snd $ months !! (m - 1)
        'h' -> (++) . snd $ months !! (m - 1)
        'm' -> shows02 m
        -- DayOfMonth
        'd' -> shows02 d
        'e' -> shows_2 d
        -- default
        _ -> def c

instance FormatTime OrdinalDate where
    {-# INLINEABLE showsTime #-}
    showsTime TimeLocale {..} (OrdinalDate y d) = \ def c -> case c of
        -- Year
        'Y' -> showsYear y
        'y' -> shows02 (mod y 100)
        'C' -> shows02 (div y 100)
        -- DayOfYear
        'j' -> shows03 d
        -- default
        _ -> def c

instance FormatTime WeekDate where
    {-# INLINEABLE showsTime #-}
    showsTime TimeLocale {..} (WeekDate y w d) = \ def c -> case c of
        -- Year (WeekDate)
        'G' -> showsYear y
        'g' -> shows02 (mod y 100)
        'f' -> shows02 (div y 100)
        -- WeekOfYear
        'V' -> shows02 w
        -- DayOfWeek
        'u' -> shows d
        'A' -> (++) . fst $ wDays !! mod d 7
        'a' -> (++) . snd $ wDays !! mod d 7
        'w' -> shows (mod d 7)
        -- default
        _ -> def c

instance FormatTime LocalTime where
    {-# INLINEABLE showsTime #-}
    showsTime l (LocalTime day tod) = showsTime l day . showsTime l tod

instance FormatTime Day where
    {-# INLINEABLE showsTime #-}
    showsTime l d = showsTime l ordinal
            . showsTime l (view yearMonthDay ordinal)
            . showsTime l (view weekDate d) . other where
        ordinal = view ordinalDate d
        other :: (Char -> ShowS) -> (Char -> ShowS)
        other def c = case c of
            -- Non-standard WeekOfYear
            'U' -> shows02 . wdWeek $ sundayStartWeek d
            'W' -> shows02 . wdWeek $ mondayStartWeek d
            -- default
            _ -> def c

instance FormatTime TimeZone where
    {-# INLINEABLE showsTime #-}
    showsTime _ tz@(TimeZone _ _ name) = \ def c -> case c of
        'z' -> (++) (timeZoneOffsetString tz)
        'Z' -> (++) (if null name then timeZoneOffsetString tz else name)
        _ -> def c

instance FormatTime ZonedTime where
    {-# INLINEABLE showsTime #-}
    showsTime l (ZonedTime lt tz) = showsTime l lt . showsTime l tz

instance FormatTime UTCTime where
    {-# INLINEABLE showsTime #-}
    showsTime l t = \ def c -> case c of
        's' -> shows . fst $ qr s (Micro 1000000)
        _ -> showsTime l (view zonedTime (utc, t)) def c
      where
        NominalDiffTime s = view posixTime t
#if BUG_FOR_BUG
        qr = microDivMod -- rounds down
#else
        qr = microQuotRem -- rounds to 0
#endif

------------------------------------------------------------------------

data TimeFlag
    = PostMeridiem
    | HasCentury
    | IsPOSIXTime
    | IsGregorian
    | IsWeekDate
    deriving (Enum, Show)

data TimeParse = TimeParse
    { tpCentury :: {-# UNPACK #-}!Int
    , tpCenturyYear :: {-# UNPACK #-}!Int{-YearOfCentury-}
    , tpMonth :: {-# UNPACK #-}!Month
    , tpWeekOfYear :: {-# UNPACK #-}!WeekOfYear
    , tpDayOfMonth :: {-# UNPACK #-}!DayOfMonth
    , tpDayOfYear :: {-# UNPACK #-}!DayOfYear
    , tpDayOfWeek :: {-# UNPACK #-}!DayOfWeek
    , tpFlags :: {-# UNPACK #-}!Int{-BitSet TimeFlag-}
    , tpHour :: {-# UNPACK #-}!Hour
    , tpMinute :: {-# UNPACK #-}!Minute
    , tpSecond :: {-# UNPACK #-}!Int
    , tpSecFrac :: {-# UNPACK #-}!DiffTime
    , tpPOSIXTime :: {-# UNPACK #-}!POSIXTime
    , tpTimeZone :: {-# UNPACK #-}!TimeZone
    } deriving (Show)

thymeLenses ''TimeParse

{-# INLINE flag #-}
flag :: TimeFlag -> Simple Lens TimeParse Bool
flag (fromEnum -> f@(shiftL 1 -> m@(complement -> m'))) = _tpFlags . lens
    (`testBit` f) (\ n b -> if b then n .|. m else n .&. m')

{-# INLINE unixEpoch #-}
unixEpoch :: TimeParse
unixEpoch = TimeParse {..} where
    tpCentury = 19
    tpCenturyYear = 70
    tpMonth = 1
    tpWeekOfYear = 1
    tpDayOfYear = 1
    tpDayOfMonth = 1
    tpDayOfWeek = 4
    tpFlags = 0
    tpHour = 0
    tpMinute = 0
    tpSecond = 0
    tpSecFrac = zeroV
    tpPOSIXTime = zeroV
    tpTimeZone = utc

{-# INLINEABLE parseTime #-}
parseTime :: (ParseTime t) => TimeLocale -> String -> String -> Maybe t
parseTime l spec = either (const Nothing) Just . P.parseOnly (readsTime l spec) . S.pack

{-# INLINEABLE readsTime #-}
readsTime :: (ParseTime t) => TimeLocale -> String -> Parser t
readsTime l@TimeLocale {..} specString = buildTime
        <$> execStateT (go specString) unixEpoch where

    go :: String -> StateT TimeParse Parser ()
    go spec = case spec of
        '%' : cspec : rspec -> case cspec of
            -- aggregate
            'c' -> go (dateTimeFmt ++ rspec)
            'r' -> go (time12Fmt ++ rspec)
            'X' -> go (timeFmt ++ rspec)
            'x' -> go (dateFmt ++ rspec)
            'R' -> go ("%H:%M" ++ rspec)
            'T' -> go ("%H:%M:%S" ++ rspec)
            'D' -> go ("%m/%d/%y" ++ rspec)
            'F' -> go ("%Y-%m-%d" ++ rspec)
            -- AM/PM
            'P' -> dayHalf
            'p' -> dayHalf
            -- Hour
            'H' -> lift (dec0 2) >>= setHour24
            'I' -> lift (dec0 2) >>= setHour12
            'k' -> lift (dec_ 2) >>= setHour24
            'l' -> lift (dec_ 2) >>= setHour12
            -- Minute
            'M' -> lift (dec0 2) >>= assign _tpMinute >> go rspec
            -- Second
            'S' -> lift (dec0 2) >>= assign _tpSecond >> go rspec
            'q' -> lift micro >>= assign _tpSecFrac . DiffTime >> go rspec
            'Q' -> lift ((P.char '.' >> DiffTime <$> micro) <|> return zeroV)
                >>= assign _tpSecFrac >> go rspec

            -- Year
            -- FIXME: should full years / centuries be fixed width?
            'Y' -> lift (dec0 4) >>= setYear
            'y' -> lift (dec0 2) >>= assign _tpCenturyYear >> go rspec
            'C' -> lift (dec0 2) >>= assign _tpCentury
                >> flag HasCentury .= True >> go rspec
{-
            -- Month
            'B' -> indexOfCI (fst <$> months) (setMonth . succ)
            'b' -> indexOfCI (snd <$> months) (setMonth . succ)
            'h' -> indexOfCI (snd <$> months) (setMonth . succ)
-}
            'm' -> lift (dec0 2) >>= setMonth
            -- DayOfMonth
            'd' -> lift (dec0 2) >>= setDayOfMonth
            'e' -> lift (dec_ 2) >>= setDayOfMonth
            -- DayOfYear
            'j' -> lift (dec0 3) >>= assign _tpDayOfYear >> go rspec

            -- Year (WeekDate)
            'G' -> lift (dec0 4) >>= \ y -> flag IsWeekDate .= True >> setYear y
            'g' -> lift (dec0 2) >>= assign _tpCenturyYear
                >> flag IsWeekDate .= True >> go rspec
            'f' -> lift (dec0 2) >>= assign _tpCentury
                >> flag IsWeekDate .= True >> flag HasCentury .= True >> go rspec
            -- WeekOfYear
            'V' -> lift (dec0 2) >>= setWeekOfYear -- ISO 8601
            'U' -> lift (dec0 2) >>= setWeekOfYear -- Sunday start
            'W' -> lift (dec0 2) >>= setWeekOfYear -- Monday start
            -- DayOfWeek
            'u' -> lift (dec0 1) >>= setDayOfWeek -- ISO 8601
            'w' -> lift (dec0 1) >>= setDayOfWeek -- Sunday start
{-             'A' -> indexOfCI (fst <$> wDays) setDayOfWeek -}
{-             'a' -> indexOfCI (snd <$> wDays) setDayOfWeek -}

            -- TimeZone
            'z' -> timeZone "%z"
            'Z' -> timeZone "%Z"
            -- UTCTime
            's' -> lift (negative P.decimal) >>= \ s -> flag IsPOSIXTime .= True
                >> _tpPOSIXTime .= fromIntegral (s :: Int64) *^ basisValue ()
                >> go rspec

            -- modifier (whatever)
            '-' -> go ('%' : rspec)
            '_' -> go ('%' : rspec)
            '0' -> go ('%' : rspec)
            -- escape (why would anyone need %t and %n?)
            '%' -> lift (P.char '%') >> go rspec
            _ -> lift . fail $ "Unknown format character: " ++ show cspec

          where
            dayHalf = do
                pm <- lift $ False <$ P.stringCI (S.pack $ fst amPm)
                    <|> True <$ P.stringCI (S.pack $ snd amPm)
                flag PostMeridiem .= pm
                go rspec
            setHour12 h = do _tpHour .= h; go rspec
            setHour24 h = do _tpHour .= h; go rspec; flag PostMeridiem .= False
            setYear ((`divMod` 100) -> (c, y)) = flag HasCentury .= True
                >> _tpCentury .= c >> _tpCenturyYear .= y >> go rspec
            setMonth m = _tpMonth .= m >> go rspec
            setDayOfMonth d = _tpDayOfMonth .= d
                >> flag IsGregorian .= True >> go rspec
            setWeekOfYear w = _tpWeekOfYear .= w
                >> flag IsWeekDate .= True >> go rspec
            setDayOfWeek d = _tpDayOfWeek .= d
                >> flag IsWeekDate .= True >> go rspec
            -- "time" has a table of zones that we don't care to duplicate
            timeZone zspec = {-lift (readS_to_P $ T.readsTime l zspec)
                >>= assign _tpTimeZone >> -} go rspec

        c : rspec -> case isSpace c of
            True -> lift (P.takeWhile1 isSpace) >> go (dropWhile isSpace rspec)
            False -> lift (P.char c) >> go rspec
        "" -> lift P.skipSpace

class ParseTime t where
    buildTime :: TimeParse -> t

instance ParseTime TimeOfDay where
    {-# INLINE buildTime #-}
    buildTime tp@TimeParse {..} = TimeOfDay h tpMinute
            (fromIntegral tpSecond *^ basisValue () ^+^ tpSecFrac) where
        h = if tp ^. flag PostMeridiem && tpHour < 12
            then tpHour + 12 else tpHour

{-# INLINE tpYear #-}
tpYear :: TimeParse -> Year
tpYear tp@TimeParse {..} = tpCenturyYear + 100 * if tp ^. flag HasCentury
    then tpCentury else if tpCenturyYear < 70 then 20 else 19

instance ParseTime YearMonthDay where
    {-# INLINE buildTime #-}
    buildTime tp@TimeParse {..} = YearMonthDay (tpYear tp) tpMonth tpDayOfMonth

instance ParseTime MonthDay where
    {-# INLINE buildTime #-}
    buildTime TimeParse {..} = MonthDay tpMonth tpDayOfMonth

instance ParseTime OrdinalDate where
    {-# INLINE buildTime #-}
    buildTime tp@TimeParse {..} = OrdinalDate (tpYear tp) tpDayOfYear

instance ParseTime WeekDate where
    {-# INLINE buildTime #-}
    buildTime tp@TimeParse {..} = WeekDate (tpYear tp) tpWeekOfYear tpDayOfWeek

instance ParseTime LocalTime where
    {-# INLINE buildTime #-}
    buildTime = LocalTime <$> buildTime <*> buildTime

instance ParseTime Day where
    {-# INLINE buildTime #-}
    buildTime tp@TimeParse {..}
        | tp ^. flag IsGregorian = review gregorian (buildTime tp)
        | tp ^. flag IsWeekDate = review weekDate (buildTime tp)
        | otherwise = review ordinalDate (buildTime tp)

instance ParseTime TimeZone where
    {-# INLINE buildTime #-}
    buildTime = tpTimeZone

instance ParseTime ZonedTime where
    {-# INLINE buildTime #-}
    buildTime = ZonedTime <$> buildTime <*> buildTime

instance ParseTime UTCTime where
    {-# INLINE buildTime #-}
    buildTime tp@TimeParse {..} = if tp ^. flag IsPOSIXTime
        then review posixTime tpPOSIXTime
        else view (from zonedTime . _2) (buildTime tp)