Base.hs

---------------------------------------------------------------
-- Copyright (c) 2013, Enzo Haussecker. All rights reserved. --
---------------------------------------------------------------

{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE MultiWayIf                 #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# OPTIONS -Wall                       #-}
{-# OPTIONS -fno-warn-name-shadowing    #-}

module Data.Time.Exts.Base (

  -- * Classes
       Date(..)
     , Zone(..)
     , DateZone(..)
     , DateTime(..)
     , DateTimeZone(..)
     , DateTimeMath(..)

  -- * Structs
     , DateStruct(..)
     , DateZoneStruct(..)
     , DateTimeStruct(..)
     , DateTimeZoneStruct(..)

  -- * Components
     , Year(..)
     , Month(..)
     , Day(..)
     , DayOfWeek(..)
     , Hour(..)
     , Minute(..)
     , Second(..)
     , Millis(..)
     , Micros(..)
     , Nanos(..)
     , Picos(..)

  -- * Pretty
     , Pretty(..)
     , prettyMonth
     , prettyDay
     , prettyHour

  -- * Fractions
     , properFracMillis
     , properFracMicros
     , properFracNanos
     , properFracPicos

  -- * Durations
     , epochToDate
     , epochToYear
     , yearToMonth
     , dateToTime

  -- * Utilities
     , isLeapYear

     ) where

import Control.Arrow (first)
import Data.Aeson (FromJSON, ToJSON)
import Data.Int (Int32, Int64)
import Data.Time.Exts.Zone (TimeZone)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Text.Printf (PrintfArg)
import System.Random (Random(..))

class Date d where
   toDateStruct   :: d -> DateStruct
   fromDateStruct :: DateStruct -> d

class Zone z where
   toZone :: z -> TimeZone -> z

class DateZone dz where
   toDateZoneStruct   :: dz -> DateZoneStruct
   fromDateZoneStruct :: DateZoneStruct -> dz

class DateTime dt where
   toDateTimeStruct   :: dt -> DateTimeStruct
   fromDateTimeStruct :: DateTimeStruct -> dt

class DateTimeZone dtz where
   toDateTimeZoneStruct   :: dtz -> DateTimeZoneStruct
   fromDateTimeZoneStruct :: DateTimeZoneStruct -> dtz

class DateTimeMath a b where
   plus :: a -> b -> a

-- | Show a timestamp in a more human-readable format than the default 'Show' instance.
class Pretty a where
   pretty :: a -> String

-- | A struct with date components.
data DateStruct = DateStruct {
     _d_year :: {-# UNPACK #-} !Year      -- ^ year
   , _d_mon  :: {-# UNPACK #-} !Month     -- ^ month
   , _d_mday :: {-# UNPACK #-} !Day       -- ^ day of month
   , _d_wday ::                !DayOfWeek -- ^ day of week
   } deriving (Eq,Generic,Ord,Show,Typeable)

-- | A struct with date and zone components.
data DateZoneStruct = DateZoneStruct {
     _dz_year :: {-# UNPACK #-} !Year      -- ^ year
   , _dz_mon  :: {-# UNPACK #-} !Month     -- ^ month
   , _dz_mday :: {-# UNPACK #-} !Day       -- ^ day of month
   , _dz_wday ::                !DayOfWeek -- ^ day of week
   , _dz_zone ::                !TimeZone  -- ^ time zone
   } deriving (Eq,Generic,Ord,Show,Typeable)

-- | A struct with date and time components.
data DateTimeStruct = DateTimeStruct {
     _dt_year :: {-# UNPACK #-} !Year      -- ^ year
   , _dt_mon  :: {-# UNPACK #-} !Month     -- ^ month
   , _dt_mday :: {-# UNPACK #-} !Day       -- ^ day of month
   , _dt_wday ::                !DayOfWeek -- ^ day of week
   , _dt_hour :: {-# UNPACK #-} !Hour      -- ^ hour
   , _dt_min  :: {-# UNPACK #-} !Minute    -- ^ minute
   , _dt_sec  :: {-# UNPACK #-} !Double    -- ^ second
   } deriving (Eq,Generic,Ord,Show,Typeable)

-- | A struct with date, time and zone components.
data DateTimeZoneStruct = DateTimeZoneStruct {
    _dtz_year :: {-# UNPACK #-} !Year      -- ^ year
  , _dtz_mon  :: {-# UNPACK #-} !Month     -- ^ month
  , _dtz_mday :: {-# UNPACK #-} !Day       -- ^ day of month
  , _dtz_wday ::                !DayOfWeek -- ^ day of week
  , _dtz_hour :: {-# UNPACK #-} !Hour      -- ^ hour
  , _dtz_min  :: {-# UNPACK #-} !Minute    -- ^ minute
  , _dtz_sec  :: {-# UNPACK #-} !Double    -- ^ second
  , _dtz_zone ::                !TimeZone  -- ^ time zone
  } deriving (Eq,Generic,Ord,Show,Typeable)

-- | Year.
newtype Year = Year {getYear :: Int32}
    deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON)

-- | Month.
newtype Month = Month {getMonth :: Int32}
    deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON)

-- | Day.
newtype Day = Day {getDay :: Int32}
    deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON)

-- | Hour.
newtype Hour = Hour {getHour :: Int32}
    deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON)

-- | Minute.
newtype Minute = Minute {getMinute :: Int32}
    deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON)

-- | Second.
newtype Second = Second {getSecond :: Int32}
    deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON)

-- | Millisecond.
newtype Millis = Millis {getMillis :: Int32}
    deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON)

-- | Microsecond.
newtype Micros = Micros {getMicros :: Int32}
    deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON)

-- | Nanosecond.
newtype Nanos = Nanos {getNanos :: Int32}
    deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON)

-- | Picosecond.
newtype Picos = Picos {getPicos :: Int64}
    deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON)

-- | Day of the week.
data DayOfWeek =
     Sunday
   | Monday
   | Tuesday
   | Wednesday
   | Thursday
   | Friday
   | Saturday
   deriving (Eq,Enum,Generic,Ord,Show,Typeable)

instance FromJSON DateStruct
instance FromJSON DateZoneStruct
instance FromJSON DateTimeStruct
instance FromJSON DateTimeZoneStruct
instance FromJSON DayOfWeek

instance Random DayOfWeek where
   random        = first toEnum . randomR (0, 6)
   randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b)

instance Show Year   where show Year   {getYear  } = "Year "   ++ parens getYear
instance Show Month  where show Month  {getMonth } = "Month "  ++ parens getMonth
instance Show Day    where show Day    {getDay   } = "Day "    ++ parens getDay
instance Show Hour   where show Hour   {getHour  } = "Hour "   ++ parens getHour
instance Show Minute where show Minute {getMinute} = "Minute " ++ parens getMinute
instance Show Second where show Second {getSecond} = "Second " ++ parens getSecond
instance Show Millis where show Millis {getMillis} = "Millis " ++ parens getMillis
instance Show Micros where show Micros {getMicros} = "Micros " ++ parens getMicros
instance Show Nanos  where show Nanos  {getNanos } = "Nanos "  ++ parens getNanos
instance Show Picos  where show Picos  {getPicos } = "Picos "  ++ parens getPicos

instance ToJSON DateStruct
instance ToJSON DateZoneStruct
instance ToJSON DateTimeStruct
instance ToJSON DateTimeZoneStruct
instance ToJSON DayOfWeek

-- | Show the given numeric value as a string.
parens :: Num a => Ord a => Show a => a -> String
parens x = if x < 0 then '(' : show x ++ ")" else show x

-- | Show the given month as a string. 
prettyMonth :: Month -> String
prettyMonth = \ case
  01 -> "January"
  02 -> "February"
  03 -> "March"
  04 -> "April"
  05 -> "May"
  06 -> "June"
  07 -> "July"
  08 -> "August"
  09 -> "September"
  10 -> "October"
  11 -> "November"
  12 -> "December"
  _  -> error "prettyMonth: unknown month"

-- | Show the given day of the month as a string.
prettyDay :: Day -> String
prettyDay Day{getDay} =
  if getDay <= 0 || 32 <= getDay
  then error "prettyDay: unknown day"
  else case getDay `mod` 10 of
        1 | getDay /= 11 -> str ++ "st"
        2 | getDay /= 12 -> str ++ "nd"
        3 | getDay /= 13 -> str ++ "rd"
        _                -> str ++ "th"
        where str = show getDay

-- | Return the given hour in AM-PM format. 
prettyHour :: Hour -> (Hour, String)
prettyHour hour =
  if | hour <  00 -> error "prettyHour: unknown hour"
     | hour == 00 -> (12, "AM")
     | hour <= 11 -> (hour, "AM")
     | hour == 12 -> (hour, "PM")
     | hour <= 23 -> (hour - 12, "PM")
     | otherwise  -> error "prettyHour: unknown hour"

-- | Decompose a floating point number into second and millisecond components.
properFracMillis :: Floating a => RealFrac a => a -> (Second, Millis)
properFracMillis millis = if rem == 1000 then (sec + 1, 0) else result
  where result@(sec, rem) = fmap (round . (*) 1000) $ properFraction millis

-- | Decompose a floating point number into second and microsecond components.
properFracMicros :: Floating a => RealFrac a => a -> (Second, Micros)
properFracMicros micros = if rem == 1000000 then (sec + 1, 0) else result
  where result@(sec, rem) = fmap (round . (*) 1000000) $ properFraction micros

-- | Decompose a floating point number into second and nanosecond components.
properFracNanos :: Floating a => RealFrac a => a -> (Second, Nanos)
properFracNanos nanos = if rem == 1000000000 then (sec + 1, 0) else result
  where result@(sec, rem) = fmap (round . (*) 1000000000) $ properFraction nanos

-- | Decompose a floating point number into second and picosecond components.
properFracPicos :: Floating a => RealFrac a => a -> (Second, Picos)
properFracPicos picos = if rem == 1000000000000 then (sec + 1, 0) else result
  where result@(sec, rem) = fmap (round . (*) 1000000000000) $ properFraction picos

-- | Calculate the number of days that have
--   elapsed between Unix epoch and the given date.
epochToDate :: Year -> Month -> Day -> Day
epochToDate year mon mday =
  epochToYear year + yearToMonth mon leap + mday - 1
  where leap = isLeapYear year

-- | Calculate the number of days that have
--   elapsed between Unix epoch and the given year.
epochToYear :: Year -> Day
epochToYear Year{getYear} =
  Day ((getYear - 1970)   *   365 + (getYear - 1969) `div` 004 -
       (getYear - 1901) `div` 100 + (getYear - 1601) `div` 400)

-- | Calculate the number of days that have 
--   elapsed between January 1st and the given month.
yearToMonth :: Month -> Bool -> Day
yearToMonth mon leap =
  if leap
  then
    case mon of
      01 -> 000; 02 -> 031; 03 -> 060; 04 -> 091
      05 -> 121; 06 -> 152; 07 -> 182; 08 -> 213
      09 -> 244; 10 -> 274; 11 -> 305; 12 -> 335
      __ -> error "yearToMonth: month not supported"
  else
    case mon of
      01 -> 000; 02 -> 031; 03 -> 059; 04 -> 090
      05 -> 120; 06 -> 151; 07 -> 181; 08 -> 212
      09 -> 243; 10 -> 273; 11 -> 304; 12 -> 334
      __ -> error "yearToMonth: month not supported"

-- | Calculate the number of seconds that have
--   elapsed between midnight and the given time.
dateToTime :: Hour -> Minute -> Second -> Second
dateToTime Hour{getHour} Minute{getMinute} sec =
  Second ((getHour * 3600) + (getMinute * 60)) + sec

-- | Check if the given year is a leap year.
isLeapYear :: Year -> Bool
isLeapYear year = year `mod` 400 == 0 || (not (year `mod` 100 == 0) && year `mod` 4 == 0)