{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

#include "thyme.h"

module Data.Thyme.LocalTime where

import Prelude hiding ((.))
import Control.Applicative
import Control.Arrow
import Control.Category hiding (id)
import Control.DeepSeq
import Control.Lens
import Control.Monad
import Data.AffineSpace
import Data.Bits
import Data.Data
import Data.Int
import Data.Thyme.Internal.Micro
import Data.Thyme.Calendar
import Data.Thyme.Calendar.Internal
import Data.Thyme.Clock
import Data.Thyme.Clock.Internal
import Data.Thyme.Format.Internal
import qualified Data.Time as T
#if __GLASGOW_HASKELL__ == 704
import qualified Data.Vector.Generic
import qualified Data.Vector.Generic.Mutable
#endif
import Data.Vector.Unboxed.Deriving
import Data.VectorSpace
import GHC.Generics (Generic)
import System.Random
import Test.QuickCheck hiding ((.&.))

type Minutes = Int
type Hours = Int

------------------------------------------------------------------------
-- * Time zones

data TimeZone = TimeZone
    { timeZoneMinutes :: {-# UNPACK #-}!Minutes
    , timeZoneSummerOnly :: !Bool
    , timeZoneName :: String
    } deriving (INSTANCES_USUAL)

instance NFData TimeZone

#if SHOW_INTERNAL
deriving instance Show TimeZone
#else
instance Show TimeZone where
    show tz@TimeZone {..} = if null timeZoneName
        then timeZoneOffsetString tz else timeZoneName
#endif

instance Bounded TimeZone where
    minBound = TimeZone (-12 * 60) minBound "AAAA"
    maxBound = TimeZone (13 * 60) maxBound "ZZZZ"

instance Random TimeZone where
    randomR (l, u) g0 = (TimeZone minutes summer name, g3) where
        (minutes, g1) = randomR (timeZoneMinutes l, timeZoneMinutes u) g0
        (summer, g2) = randomR (timeZoneSummerOnly l, timeZoneSummerOnly u) g1
        -- slightly dubious interpretation of ‘range’
        (name, g3) = foldr randChar ([], g2) . take 4 $ zip
            (timeZoneName l ++ "AAAA") (timeZoneName u ++ "ZZZZ")
        randChar nR (ns, g) = (: ns) `first` randomR nR g
    random = randomR (minBound, maxBound)

instance Arbitrary TimeZone where
    arbitrary = choose (minBound, maxBound)
    shrink tz@TimeZone {..}
        = [ tz {timeZoneSummerOnly = s} | s <- shrink timeZoneSummerOnly ]
        ++ [ tz {timeZoneMinutes = m} | m <- shrink timeZoneMinutes ]
        ++ [ tz {timeZoneName = n} | n <- shrink timeZoneName ]

instance CoArbitrary TimeZone where
    coarbitrary (TimeZone m s n)
        = coarbitrary m . coarbitrary s . coarbitrary n

-- | Text representing the offset of this timezone, e.g. \"-0800\" or
-- \"+0400\" (like %z in 'formatTime')
{-# INLINEABLE timeZoneOffsetString #-}
timeZoneOffsetString :: TimeZone -> String
timeZoneOffsetString TimeZone {..} = sign : (shows02 h . shows02 m) "" where
    (h, m) = divMod offset 60
    (sign, offset) = if timeZoneMinutes < 0
        then ('-', negate timeZoneMinutes) else ('+', timeZoneMinutes)

-- | Create a nameless non-summer timezone for this number of minutes
minutesToTimeZone :: Minutes -> TimeZone
minutesToTimeZone m = TimeZone m False ""

-- | Create a nameless non-summer timezone for this number of hours
hoursToTimeZone :: Hours -> TimeZone
hoursToTimeZone i = minutesToTimeZone (60 * i)

utc :: TimeZone
utc = TimeZone 0 False "UTC"

{-# INLINEABLE getTimeZone #-}
getTimeZone :: UTCTime -> IO TimeZone
getTimeZone t = thyme `fmap` T.getTimeZone (T.UTCTime day $ toSeconds dt) where
    day = T.ModifiedJulianDay (toInteger mjd)
    UTCTime (ModifiedJulianDay mjd) dt = t ^. utcTime
    thyme T.TimeZone {..} = TimeZone {..}

{-# INLINE getCurrentTimeZone #-}
getCurrentTimeZone :: IO TimeZone
getCurrentTimeZone = getCurrentTime >>= getTimeZone

------------------------------------------------------------------------
-- * Time of day

type Hour = Int
type Minute = Int
data TimeOfDay = TimeOfDay
    { todHour :: {-# UNPACK #-}!Hour
    , todMin :: {-# UNPACK #-}!Minute
    , todSec :: {-# UNPACK #-}!DiffTime
    } deriving (INSTANCES_USUAL)

derivingUnbox "TimeOfDay" [t| TimeOfDay -> Int64 |]
    [| \ TimeOfDay {..} -> fromIntegral (todHour .|. shiftL todMin 8)
        .|. shiftL (todSec ^. microseconds) 16 |]
    [| \ n -> TimeOfDay (fromIntegral $ n .&. 0xff)
        (fromIntegral $ shiftR n 8 .&. 0xff) (microseconds # shiftR n 16) |]

instance NFData TimeOfDay

#if SHOW_INTERNAL
deriving instance Show TimeOfDay
#else
instance Show TimeOfDay where
    showsPrec _ (TimeOfDay h m (DiffTime s))
            = shows02 h . (:) ':' . shows02 m . (:) ':'
            . shows02 (fromIntegral si) . frac where
        (si, Micro su) = microQuotRem s (Micro 1000000)
        frac = if su == 0 then id else (:) '.' . fills06 su . drops0 su
#endif

instance Bounded TimeOfDay where
    minBound = TimeOfDay 0 0 zeroV
    maxBound = TimeOfDay 23 59 (microseconds # 60999999)

instance Random TimeOfDay where
    randomR = randomIsoR timeOfDay
    random = first (^. timeOfDay) . random

instance Arbitrary TimeOfDay where
    arbitrary = do
        h <- choose (0, 23)
        m <- choose (0, 59)
        let DiffTime ml = minuteLength h m
        TimeOfDay h m . DiffTime <$> choose (zeroV, pred ml)
    shrink tod = view timeOfDay . (^+^) noon
            <$> shrink (timeOfDay # tod ^-^ noon) where
        noon = timeOfDay # midday -- shrink towards midday

instance CoArbitrary TimeOfDay where
    coarbitrary (TimeOfDay h m s)
        = coarbitrary h . coarbitrary m . coarbitrary s

{-# INLINE minuteLength #-}
minuteLength :: Hour -> Minute -> DiffTime
minuteLength h m = fromSeconds' $ if h == 23 && m == 59 then 61 else 60

-- | Hour zero
midnight :: TimeOfDay
midnight = TimeOfDay 0 0 zeroV

-- | Hour twelve
midday :: TimeOfDay
midday = TimeOfDay 12 0 zeroV

{-# INLINE makeTimeOfDayValid #-}
makeTimeOfDayValid :: Hour -> Minute -> DiffTime -> Maybe TimeOfDay
makeTimeOfDayValid h m s = TimeOfDay h m s
    <$ guard (0 <= h && h <= 23 && 0 <= m && m <= 59)
    <* guard (zeroV <= s && s < minuteLength h m)

{-# INLINE timeOfDay #-}
timeOfDay :: Iso' DiffTime TimeOfDay
timeOfDay = iso fromDiff toDiff where

    {-# INLINEABLE fromDiff #-}
    fromDiff :: DiffTime -> TimeOfDay
    fromDiff (DiffTime t) = TimeOfDay
            (fromIntegral h) (fromIntegral m) (DiffTime s) where
        (h, ms) = microQuotRem t (Micro 3600000000)
        (m, s) = microQuotRem ms (Micro 60000000)

    {-# INLINEABLE toDiff #-}
    toDiff :: TimeOfDay -> DiffTime
    toDiff (TimeOfDay h m s) = s
        ^+^ fromIntegral m *^ DiffTime (Micro 60000000)
        ^+^ fromIntegral h *^ DiffTime (Micro 3600000000)

-- | Add some minutes to a 'TimeOfDay'; result comes with a day adjustment.
{-# INLINE addMinutes #-}
addMinutes :: Minutes -> TimeOfDay -> (Days, TimeOfDay)
addMinutes dm (TimeOfDay h m s) = (dd, TimeOfDay h' m' s) where
    (dd, h') = divMod (h + dh) 24
    (dh, m') = divMod (m + dm) 60

{-# INLINE dayFraction #-}
dayFraction :: Iso' TimeOfDay Rational
dayFraction = from timeOfDay . iso toRatio fromRatio where

    {-# INLINEABLE toRatio #-}
    toRatio :: DiffTime -> Rational
    toRatio t = toSeconds t / toSeconds posixDayLength

    {-# INLINEABLE fromRatio #-}
    fromRatio :: Rational -> DiffTime
    fromRatio ((*^ posixDayLength) -> NominalDiffTime r) = DiffTime r

------------------------------------------------------------------------
-- * Local Time

data LocalTime = LocalTime
    { localDay :: {-# UNPACK #-}!Day
    , localTimeOfDay :: {-only 3 words…-} {-# UNPACK #-}!TimeOfDay
    } deriving (INSTANCES_USUAL)

derivingUnbox "LocalTime" [t| LocalTime -> (Day, TimeOfDay) |]
    [| \ LocalTime {..} -> (localDay, localTimeOfDay) |]
    [| \ (localDay, localTimeOfDay) -> LocalTime {..} |]

instance NFData LocalTime

#if SHOW_INTERNAL
deriving instance Show LocalTime
#else
instance Show LocalTime where
    showsPrec p (LocalTime d t) = showsPrec p d . (:) ' ' . showsPrec p t
#endif

instance Bounded LocalTime where
    minBound = minBound ^. utcLocalTime maxBound
    maxBound = maxBound ^. utcLocalTime minBound

instance Random LocalTime where
    randomR = randomIsoR (utcLocalTime utc)
    random = randomR (minBound, maxBound)

instance Arbitrary LocalTime where
    arbitrary = choose (minBound, maxBound)
    shrink lt@LocalTime {..}
        = [ lt {localDay = d} | d <- shrink localDay ]
        ++ [ lt {localTimeOfDay = d} | d <- shrink localTimeOfDay ]

instance CoArbitrary LocalTime where
    coarbitrary (LocalTime d t) = coarbitrary d . coarbitrary t

{-# INLINE utcLocalTime #-}
utcLocalTime :: TimeZone -> Iso' UTCTime LocalTime
utcLocalTime TimeZone {..} = utcTime . iso localise globalise where

    {-# INLINEABLE localise #-}
    localise :: UTCView -> LocalTime
    localise (UTCTime day dt) = LocalTime (day .+^ dd) tod where
        (dd, tod) = addMinutes timeZoneMinutes (dt ^. timeOfDay)

    {-# INLINEABLE globalise #-}
    globalise :: LocalTime -> UTCView
    globalise (LocalTime day tod) = UTCTime (day .+^ dd)
            (timeOfDay # utcToD) where
        (dd, utcToD) = addMinutes (negate timeZoneMinutes) tod

{-# INLINE ut1LocalTime #-}
ut1LocalTime :: Rational -> Iso' UniversalTime LocalTime
ut1LocalTime long = iso localise globalise where
    NominalDiffTime posixDay@(Micro usDay) = posixDayLength

    {-# INLINEABLE localise #-}
    localise :: UniversalTime -> LocalTime
    localise (UniversalRep (NominalDiffTime t)) = LocalTime
            (ModifiedJulianDay $ fromIntegral day)
            (DiffTime dt ^. timeOfDay) where
        (day, dt) = microDivMod (t ^+^ (long / 360) *^ posixDay) posixDay

    {-# INLINEABLE globalise #-}
    globalise :: LocalTime -> UniversalTime
    globalise (LocalTime day tod) = UniversalRep . NominalDiffTime $
            Micro (mjd * usDay) ^+^ dt ^-^ (long / 360) *^ posixDay where
        ModifiedJulianDay (fromIntegral -> mjd) = day
        DiffTime dt = timeOfDay # tod

------------------------------------------------------------------------
-- * Zoned Time

data ZonedTime = ZonedTime
    { zonedTimeToLocalTime :: {-only 4 words…-} {-# UNPACK #-}!LocalTime
    , zonedTimeZone :: !TimeZone
    } deriving (INSTANCES_USUAL)

instance NFData ZonedTime where
    rnf ZonedTime {..} = rnf zonedTimeZone

instance Bounded ZonedTime where
    minBound = ZonedTime minBound maxBound
    maxBound = ZonedTime maxBound minBound

instance Random ZonedTime where
    randomR (l, u) g0 = (view zonedTime . (,) tz)
            `first` randomR (l', u') g1 where
        (tz, g1) = random g0 -- ignore TimeZone from l and u
        l' = snd $ zonedTime # l
        u' = snd $ zonedTime # u
    random = randomR (minBound, maxBound)

instance Arbitrary ZonedTime where
    arbitrary = choose (minBound, maxBound)
    shrink zt@ZonedTime {..}
        = [ zt {zonedTimeToLocalTime = lt} | lt <- shrink zonedTimeToLocalTime ]
        ++ [ zt {zonedTimeZone = tz} | tz <- shrink zonedTimeZone ]

instance CoArbitrary ZonedTime where
    coarbitrary (ZonedTime lt tz) = coarbitrary lt . coarbitrary tz

{-# INLINE zonedTime #-}
zonedTime :: Iso' (TimeZone, UTCTime) ZonedTime
zonedTime = iso toZoned fromZoned where

    {-# INLINE toZoned #-}
    toZoned :: (TimeZone, UTCTime) -> ZonedTime
    toZoned (tz, time) = ZonedTime (time ^. utcLocalTime tz) tz

    {-# INLINE fromZoned #-}
    fromZoned :: ZonedTime -> (TimeZone, UTCTime)
    fromZoned (ZonedTime lt tz) = (tz, utcLocalTime tz # lt)

#if SHOW_INTERNAL
deriving instance Show ZonedTime
instance Show UTCTime where
    showsPrec p = showsPrec p . view utcTime
#else
instance Show ZonedTime where
    showsPrec p (ZonedTime lt tz) = showsPrec p lt . (:) ' ' . showsPrec p tz
instance Show UTCTime where
    showsPrec p = showsPrec p . view zonedTime . (,) utc
#endif

{-# INLINE getZonedTime #-}
getZonedTime :: IO ZonedTime
getZonedTime = utcToLocalZonedTime =<< getCurrentTime

{-# INLINEABLE utcToLocalZonedTime #-}
utcToLocalZonedTime :: UTCTime -> IO ZonedTime
utcToLocalZonedTime time = do
    tz <- getTimeZone time
    return $ (tz, time) ^. zonedTime

-- * Lenses

LENS(TimeZone,timeZoneMinutes,Minutes)
LENS(TimeZone,timeZoneSummerOnly,Bool)
LENS(TimeZone,timeZoneName,String)

LENS(TimeOfDay,todHour,Hour)
LENS(TimeOfDay,todMin,Minute)
LENS(TimeOfDay,todSec,DiffTime)

LENS(LocalTime,localDay,Day)
LENS(LocalTime,localTimeOfDay,TimeOfDay)

LENS(ZonedTime,zonedTimeToLocalTime,LocalTime)
LENS(ZonedTime,zonedTimeZone,TimeZone)