{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE NumericUnderscores         #-}

{- |
Module      : Time.Types
License     : BSD-style
Copyright   : (c) 2014 Vincent Hanquez <vincent@snarc.org>

Time-related types.

In principle, some units could hold infinite values. In practice, 'Int64' for
seconds (about @+/- 9e18@) and 'Int' for years is sufficient.
-}

module Time.Types
  ( -- * Time units
    NanoSeconds (..)
  , Seconds (..)
  , Minutes (..)
  , Hours (..)
    -- * Calendar enumerations
  , Month (..)
  , WeekDay (..)
    -- * Points in time
    -- ** Precise amounts of seconds
  , fromRationalSecondsP
    -- ** Elapsed time since the Unix epoch
  , Elapsed (..)
  , ElapsedP (..)
  , mkElapsedP
  , fromRationalElapsedP
    -- ** Date, time, and date and time
  , Date (..)
  , TimeOfDay (..)
  , DateTime (..)
    -- ** Local time and timezone-related
  , TimezoneOffset (..)
  , timezoneOffsetToSeconds
  , timezone_UTC
    -- * Conversion of periods of time
  , TimeInterval (..)
  ) where

import           Control.DeepSeq ( NFData (..) )
import           Data.Char ( digitToInt, isDigit )
import           Data.Data ( Data )
import           Data.Int ( Int64 )
import           Data.Ratio ( (%) )
import           Text.Read
                   ( Read (..), ReadPrec, get, pfail, readListPrecDefault )
import           Time.Utils ( pad2 )

-- | Type class promising functionality for:
--
-- * converting a value of the type in question to a number of seconds; and
--
-- * converting a t'Seconds' value to a pair of a value of the type in question
--   and a remaining number of seconds.
class TimeInterval i where
  -- | For the given value, yield a corresponding number of seconds (non-leap or
  -- all).
  toSeconds   :: i -> Seconds

  -- | For the given number of seconds (non-leap or all), yield a pair of the
  -- corresponding value of the type in queston and a remaining number of
  -- seconds.
  fromSeconds :: Seconds -> (i, Seconds)

-- | Type representing numbers of nanoseconds.
newtype NanoSeconds = NanoSeconds Int64
  deriving (Data, Eq, NFData, Num, Ord, Read)

-- | Show the number of nanoseconds followed by @ns@. (Note: the 'Read' instance
-- is derived.)
instance Show NanoSeconds where
  show (NanoSeconds v) = shows v "ns"

instance TimeInterval NanoSeconds where
  toSeconds (NanoSeconds ns) = Seconds (ns `div` 1_000_000_000)
  fromSeconds (Seconds s) = (NanoSeconds (s * 1_000_000_000), 0)

-- | Type representing numbers of seconds (non-leap or all).
newtype Seconds = Seconds Int64
  deriving (Data, Eq, Enum, Integral, NFData, Num, Ord, Read, Real)

-- | Show the number of seconds followed by @s@. (Note: the 'Read' instance
-- is derived.)
instance Show Seconds where
  show (Seconds s) = shows s "s"

instance TimeInterval Seconds where
  toSeconds   = id
  fromSeconds s = (s, 0)

-- | Given a precise amount of seconds yield a corresponding pair of
-- t'Seconds' and t'NanoSeconds' values.
--
-- If the precise amount of seconds is negative the number of nanoseconds will
-- not be positive. This can be contrasted with a normalised t'ElapsedP' value.
fromRationalSecondsP :: Rational -> (Seconds, NanoSeconds)
fromRationalSecondsP s =
  let (sWhole, sFrac) = properFraction s
      ns = truncate $ sFrac * 1_000_000_000
  in  (Seconds sWhole, NanoSeconds ns)

-- | Type representing numbers of minutes.
newtype Minutes = Minutes Int64
  deriving (Data, Eq, Enum, Integral, NFData, Num, Ord, Read, Real)

-- | Show the number of minutes followed by @m@. (Note: the 'Read' instance is
-- derived.)
instance Show Minutes where
  show (Minutes s) = shows s "m"

instance TimeInterval Minutes where
  toSeconds (Minutes m)   = Seconds (m * 60)
  fromSeconds (Seconds s) = (Minutes m, Seconds s')
   where
    (m, s') = s `divMod` 60

-- | Type representing numbers of hours.
newtype Hours = Hours Int64
  deriving (Data, Eq, Enum, Integral, NFData, Num, Ord, Read, Real)

-- | Show the number of hours followed by @h@. (Note: the 'Read' instance is
-- derived.)
instance Show Hours where
  show (Hours s) = shows s "h"

instance TimeInterval Hours where
  toSeconds (Hours h)     = Seconds (h * 3600)
  fromSeconds (Seconds s) = (Hours h, Seconds s')
   where
    (h, s') = s `divMod` 3600

-- | Type representing numbers of non-leap seconds elapsed since the Unix epoch
-- (1970-01-01 00:00:00 UTC).
--
-- Points in time before the Unix epoch are represented by a negative number of
-- seconds.
newtype Elapsed = Elapsed Seconds
  deriving (Data, Eq, NFData, Num, Ord, Read)

-- | Show the number of seconds followed by @s@. (Note: the 'Read' instance
-- is derived.)
instance Show Elapsed where
  show (Elapsed s) = show s

-- | Type representing numbers of non-leap seconds and nanoseconds elapsed since
-- the Unix epoch (1970-01-01 00:00:00 UTC).
data ElapsedP = ElapsedP
  {-# UNPACK #-} !Elapsed
  {-# UNPACK #-} !NanoSeconds
  -- ^ A normalised t'ElapsedP' value has a nanoseconds field that is
  -- non-negative and fewer than 1,000,000,000 nanoseconds (being 1 second).
  deriving (Data, Eq, Ord, Read)

-- | Show the number of seconds followed by @s@, @.@, and the number of
-- nanoseconds followed by @ns@. (Note: the 'Read' instance is derived.)
instance Show ElapsedP where
  show (ElapsedP e ns) = shows e ('.' : show ns)

instance NFData ElapsedP where
  rnf e = e `seq` ()

instance Num ElapsedP where
  (+) = addElapsedP

  (-) = subElapsedP

  (ElapsedP e1 ns1) * (ElapsedP e2 ns2) = ElapsedP (e1*e2) (ns1*ns2)

  negate (ElapsedP e ns) = ElapsedP (negate e) ns

  abs (ElapsedP e ns)    = ElapsedP (abs e) ns

  signum (ElapsedP e ns) = ElapsedP (signum e) ns

  fromInteger i          = ElapsedP (Elapsed (fromIntegral i)) 0

-- | A constructor of an t'ElapsedP' value.
--
-- The t'ElapsedP' value will be normalised. That is, the nanoseconds field will
-- be non-negative and fewer than 1,000,000,000 nanoseconds (being 1 second).
mkElapsedP :: Seconds -> NanoSeconds -> ElapsedP
mkElapsedP (Seconds notNormalizedS) (NanoSeconds notNormalizedNS) =
  let (s, ns) = notNormalizedNS `divMod` 1_000_000_000
  in  ElapsedP (Elapsed $ Seconds $ notNormalizedS + s) (NanoSeconds ns)

-- | Given a precise amount of non-leap seconds elapsed since the Unix epoch,
-- yield the corresponding t'ElapsedP' value.
--
-- The t'ElapsedP' value will be normalised. That is, the nanoseconds field will
-- be non-negative and fewer than 1,000,000,000 nanoseconds (being 1 second).
fromRationalElapsedP :: Rational -> ElapsedP
fromRationalElapsedP = uncurry mkElapsedP . fromRationalSecondsP

addElapsedP :: ElapsedP -> ElapsedP -> ElapsedP
addElapsedP (ElapsedP e1 (NanoSeconds ns1)) (ElapsedP e2 (NanoSeconds ns2)) =
  let notNormalizedNS = ns1 + ns2
      (retainedNS, ns) = notNormalizedNS `divMod` 1_000_000_000
  in  ElapsedP (e1 + e2 + Elapsed (Seconds retainedNS)) (NanoSeconds ns)

subElapsedP :: ElapsedP -> ElapsedP -> ElapsedP
subElapsedP (ElapsedP e1 (NanoSeconds ns1)) (ElapsedP e2 (NanoSeconds ns2)) =
  let notNormalizedNS = ns1 - ns2
      notNormalizedS  = e1 - e2
  in  if notNormalizedNS < 0
        then
          ElapsedP
            (notNormalizedS - oneSecond)
            (NanoSeconds (1_000_000_000 + notNormalizedNS))
        else
          ElapsedP notNormalizedS (NanoSeconds notNormalizedNS)
 where
  oneSecond :: Elapsed
  oneSecond = Elapsed $ Seconds 1

instance Real ElapsedP where
  toRational (ElapsedP (Elapsed (Seconds s)) (NanoSeconds 0)) =
    fromIntegral s

  toRational (ElapsedP (Elapsed (Seconds s)) (NanoSeconds ns)) =
    fromIntegral s + (fromIntegral ns % 1_000_000_000)

-- | Type representing months of the Julian or Gregorian year.
data Month =
    January
  | February
  | March
  | April
  | May
  | June
  | July
  | August
  | September
  | October
  | November
  | December
  deriving (Bounded, Data, Eq, Enum, Ord, Read, Show)

-- | Type representing days of the week. The enumeration starts on Sunday.
data WeekDay =
    Sunday
  | Monday
  | Tuesday
  | Wednesday
  | Thursday
  | Friday
  | Saturday
  deriving (Bounded, Data, Eq, Enum, Ord, Read, Show)

-- | Type representing offsets in minutes against UTC to obtain local time from
-- UTC. A positive number represents a location east of where UTC is local time
-- and a negative number represents a location west of where UTC is local time.
--
-- LocalTime t (-300) -- t represents a time at UTC-5
--
-- LocalTime t (+480) -- t represents a time at UTC+8
--
-- Should be between @(-12 * 60)@ and @(+14 * 60)@.
--
-- For example, in timezone AEDT (Australian Eastern Daylight Time) (UTC+11),
-- local time is 15:47. Consequently, UTC time is 04:47 and the timezone offset
-- is v'TimezoneOffset' @660@ (in minutes).
newtype TimezoneOffset = TimezoneOffset
  { timezoneOffsetToMinutes :: Int -- ^ The number of minutes.
  }
  deriving (Data, Eq, NFData, Ord)

-- | For the given timezone offset, yield the corresponding number of seconds.
timezoneOffsetToSeconds :: TimezoneOffset -> Seconds
timezoneOffsetToSeconds (TimezoneOffset ofs) = Seconds (fromIntegral ofs * 60)

-- | Show the time zone offset in the format @±HHMM@.
instance Show TimezoneOffset where
  show (TimezoneOffset tz) =
    concat [if tz < 0 then "-" else "+", pad2 tzH, pad2 tzM]
   where
    (tzH, tzM) = abs tz `divMod` 60

-- | Read a time zone offset. Accepts the format @±HHMM@ and valid values
-- between @-1200@ and @+1400@.
instance Read TimezoneOffset where
  readPrec = get >>= \case
    '+' -> parseOffset 1
    '-' -> parseOffset (-1)
    _   -> pfail
   where
    parseOffset :: Int -> ReadPrec TimezoneOffset
    parseOffset sign = do
      d1 <- getDigit
      d2 <- getDigit
      d3 <- getDigit
      d4 <- getDigit
      let hours = d1 * 10 + d2
          mins  = d3 * 10 + d4
          offset = sign * (hours * 60 + mins)
      if mins > 59 || offset > 14 * 60 || offset < -(12 * 60)
        then
          pfail
        else
          pure $ TimezoneOffset offset

    getDigit = do
      c <- get
      if isDigit c
        then
          pure (digitToInt c)
        else
          pfail

  readListPrec = readListPrecDefault

-- | The UTC timezone.
--
-- > timezoneOffsetToMinutes timezone_UTC == 0 -- True
timezone_UTC :: TimezoneOffset
timezone_UTC = TimezoneOffset 0

-- | Type representing dates in the proleptic Gregorian calendar (the common
-- calendar).
data Date = Date
  { dateYear  :: {-# UNPACK #-} !Int
    -- ^ Year of the Common Era.
  , dateMonth :: !Month
    -- ^ Month of the year.
  , dateDay   :: {-# UNPACK #-} !Int
    -- ^ Day of the month, between 1 to 31.
  }
  deriving (Data, Eq, Ord, Read, Show)

instance NFData Date where
  rnf (Date y m d) = y `seq` m `seq` d `seq` ()

-- | Type representing times as hour, minutes, seconds and nanoseconds.
data TimeOfDay = TimeOfDay
  { todHour :: {-# UNPACK #-} !Hours
    -- ^ Hours, between 0 and 23.
  , todMin  :: {-# UNPACK #-} !Minutes
    -- ^ Minutes, between 0 and 59.
  , todSec  :: {-# UNPACK #-} !Seconds
    -- ^ Seconds, between 0 and 59. A leap second is represented by 60.
  , todNSec :: {-# UNPACK #-} !NanoSeconds
    -- ^ Nanoseconds, between 0 and 999,999,999.
  }
  deriving (Data, Eq, Ord, Read, Show)

instance NFData TimeOfDay where
  rnf (TimeOfDay h m s ns) = h `seq` m `seq` s `seq` ns `seq` ()

-- | Type representing date and time.
data DateTime = DateTime
  { dtDate :: Date
  , dtTime :: TimeOfDay
  }
  deriving (Data, Eq, Ord, Read, Show)

instance NFData DateTime where
  rnf (DateTime d t) = rnf d `seq` rnf t
