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

{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# OPTIONS -Wall                       #-}
{-# OPTIONS -fno-warn-name-shadowing    #-}

#include "MachDeps.h"

module Data.Time.Exts.Unix (

       Unix
     , UnixDate(..)
     , UnixDateTime(..)
     , UnixDateTimeMillis(..)
     , UnixDateTimeMicros(..)
     , UnixDateTimeNanos(..)
     , UnixDateTimePicos(..)

     , createUnixDate
     , createUnixDateTime
     , createUnixDateTimeMillis
     , createUnixDateTimeMicros
     , createUnixDateTimeNanos
     , createUnixDateTimePicos

     , getCurrentUnixDate
     , getCurrentUnixDateTime
     , getCurrentUnixDateTimeMillis
     , getCurrentUnixDateTimeMicros
     , getCurrentUnixDateTimeNanos
     , getCurrentUnixDateTimePicos

     ) where

import Control.Arrow ((***), first)
import Control.DeepSeq (NFData)
import Data.Aeson (FromJSON, ToJSON)
import Data.Convertible (Convertible(..), convert)
import Data.Int (Int16, Int32, Int64)
import Data.Label (mkLabels, modify)
import Data.Time.Exts.Base
import Data.Typeable (Typeable)
import Foreign.C.Types (CInt(..))
import Foreign.Marshal.Utils (with)
import Foreign.Ptr (Ptr, castPtr, nullPtr, plusPtr)
import Foreign.Storable (Storable(..))
import GHC.Generics (Generic)
import System.Random (Random(..))
import Text.Printf (printf)

class Unix x

newtype UnixDate = UnixDate Int32
     deriving (Eq,FromJSON,Generic,Integral,NFData,Num,Ord,Random,Real,Storable,ToJSON,Typeable)

newtype UnixDateTime = UnixDateTime Int64
     deriving (Eq,FromJSON,Generic,Integral,NFData,Num,Ord,Random,Real,Storable,ToJSON,Typeable)

data UnixDateTimeMillis = UnixDateTimeMillis {
    _uni_mil_base :: {-# UNPACK #-} !Int64 -- ^ seconds since Unix epoch (excluding leap seconds)
  , _uni_mil_mill :: {-# UNPACK #-} !Int16 -- ^ millisecinds
  }  deriving (Eq,Generic,Ord,Typeable)

data UnixDateTimeMicros = UnixDateTimeMicros {
    _uni_mic_base :: {-# UNPACK #-} !Int64 -- ^ seconds since Unix epoch (excluding leap seconds)
  , _uni_mic_micr :: {-# UNPACK #-} !Int32 -- ^ microsecinds
  }  deriving (Eq,Generic,Ord,Typeable)

data UnixDateTimeNanos = UnixDateTimeNanos {
    _uni_nan_base :: {-# UNPACK #-} !Int64 -- ^ seconds since Unix epoch (excluding leap seconds)
  , _uni_nan_nano :: {-# UNPACK #-} !Int32 -- ^ nanosecinds
  }  deriving (Eq,Generic,Ord,Typeable)

data UnixDateTimePicos = UnixDateTimePicos {
    _uni_pic_base :: {-# UNPACK #-} !Int64 -- ^ seconds since Unix epoch (excluding leap seconds)
  , _uni_pic_pico :: {-# UNPACK #-} !Int64 -- ^ picosecinds
  }  deriving (Eq,Generic,Ord,Typeable)

data TimeOfDay = TimeOfDay {
     tod_base :: Int64
  ,  tod_mic  :: Int64
  }

instance Enum UnixDate where
    succ = flip plus $ Day 1
    pred = flip plus . Day $ - 1
    toEnum n | minBound <= day && day <= maxBound = day
             | otherwise = error "toEnum: out of range"
               where day = fromIntegral n
    fromEnum             = fromIntegral

instance Enum UnixDateTime where
    succ = flip plus $ Second 1
    pred = flip plus . Second $ - 1
    toEnum n | minBound <= sec && sec <= maxBound = sec
             | otherwise = error "toEnum: out of range"
               where sec = fromIntegral n
#if WORD_SIZE_IN_BITS == 64
    fromEnum             = fromIntegral
#endif

mkLabels [''UnixDateTimeMicros
         ,''UnixDateTimeMillis
         ,''UnixDateTimeNanos
         ,''UnixDateTimePicos
         ]

instance Bounded UnixDate where
    minBound = 0000000
    maxBound = 2932896

instance Bounded UnixDateTime where
    minBound = 000000000000
    maxBound = 253402300799

instance Bounded UnixDateTimeMillis where
    minBound = UnixDateTimeMillis 000000000000 000
    maxBound = UnixDateTimeMillis 253402300799 999

instance Bounded UnixDateTimeMicros where
    minBound = UnixDateTimeMicros 000000000000 000000
    maxBound = UnixDateTimeMicros 253402300799 999999

instance Bounded UnixDateTimeNanos where
    minBound = UnixDateTimeNanos 000000000000 000000000
    maxBound = UnixDateTimeNanos 253402300799 999999999

instance Bounded UnixDateTimePicos where
    minBound = UnixDateTimePicos 000000000000 000000000000
    maxBound = UnixDateTimePicos 253402300799 999999999999

instance Convertible UnixDateTime UnixDate where
    safeConvert = Right . fromIntegral . flip div 86400

instance Convertible UnixDateTimeMillis UnixDate where
    safeConvert = Right . fromIntegral . flip div 86400 . _uni_mil_base

instance Convertible UnixDateTimeMicros UnixDate where
    safeConvert = Right . fromIntegral . flip div 86400 . _uni_mic_base

instance Convertible UnixDateTimeNanos UnixDate where
    safeConvert = Right . fromIntegral . flip div 86400 . _uni_nan_base

instance Convertible UnixDateTimePicos UnixDate where
    safeConvert = Right . fromIntegral . flip div 86400 . _uni_pic_base

instance Date UnixDate where
    toDateStruct = decompUnixDate
    fromDateStruct DateStruct{..} =
      createUnixDate _d_year _d_mon _d_mday

instance DateTime UnixDateTime where
    toDateTimeStruct = decompUnixDateTime
    fromDateTimeStruct DateTimeStruct{..} =
      createUnixDateTime _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec
      where sec = round _dt_sec :: Second

instance DateTime UnixDateTimeMillis where
    toDateTimeStruct = decompUnixDateTimeMillis
    fromDateTimeStruct DateTimeStruct{..} =
      createUnixDateTimeMillis _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec mil
      where (sec, mil) = properFracMillis _dt_sec

instance DateTime UnixDateTimeMicros where
    toDateTimeStruct = decompUnixDateTimeMicros
    fromDateTimeStruct DateTimeStruct{..} =
      createUnixDateTimeMicros _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec mic
      where (sec, mic) = properFracMicros _dt_sec

instance DateTime UnixDateTimeNanos where
    toDateTimeStruct = decompUnixDateTimeNanos
    fromDateTimeStruct DateTimeStruct{..} =
      createUnixDateTimeNanos _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec nan
      where (sec, nan) = properFracNanos _dt_sec

instance DateTime UnixDateTimePicos where
    toDateTimeStruct = decompUnixDateTimePicos
    fromDateTimeStruct DateTimeStruct{..} =
      createUnixDateTimePicos _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec pic
      where (sec, pic) = properFracPicos _dt_sec

instance DateTimeMath UnixDate Day where
    timestamp `plus` days =
      if minBound <= date && date <= maxBound
      then date else error "plus: out of range"
      where date = timestamp + fromIntegral days

instance DateTimeMath UnixDateTime Day where
    timestamp `plus` days =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = timestamp + fromIntegral days * 86400

instance DateTimeMath UnixDateTimeMillis Day where
    timestamp `plus` days =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = modify uni_mil_base (+ fromIntegral days * 86400) timestamp

instance DateTimeMath UnixDateTimeMicros Day where
    timestamp `plus` days =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = modify uni_mic_base (+ fromIntegral days * 86400) timestamp

instance DateTimeMath UnixDateTimeNanos Day where
    timestamp `plus` days =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = modify uni_nan_base (+ fromIntegral days * 86400) timestamp

instance DateTimeMath UnixDateTimePicos Day where
    timestamp `plus` days =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = modify uni_pic_base (+ fromIntegral days * 86400) timestamp

instance DateTimeMath UnixDateTime Hour where
    timestamp `plus` hour =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = timestamp + fromIntegral hour * 3600

instance DateTimeMath UnixDateTimeMillis Hour where
    timestamp `plus` hour =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = modify uni_mil_base (+ fromIntegral hour * 3600) timestamp

instance DateTimeMath UnixDateTimeMicros Hour where
    timestamp `plus` hour =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = modify uni_mic_base (+ fromIntegral hour * 3600) timestamp

instance DateTimeMath UnixDateTimeNanos Hour where
    timestamp `plus` hour =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = modify uni_nan_base (+ fromIntegral hour * 3600) timestamp

instance DateTimeMath UnixDateTimePicos Hour where
    timestamp `plus` hour =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = modify uni_pic_base (+ fromIntegral hour * 3600) timestamp

instance DateTimeMath UnixDateTime Minute where
    timestamp `plus` mins =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = timestamp + fromIntegral mins * 60

instance DateTimeMath UnixDateTimeMillis Minute where
    timestamp `plus` mins =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = modify uni_mil_base (+ fromIntegral mins * 60) timestamp

instance DateTimeMath UnixDateTimeMicros Minute where
    timestamp `plus` mins =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = modify uni_mic_base (+ fromIntegral mins * 60) timestamp

instance DateTimeMath UnixDateTimeNanos Minute where
    timestamp `plus` mins =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = modify uni_nan_base (+ fromIntegral mins * 60) timestamp

instance DateTimeMath UnixDateTimePicos Minute where
    timestamp `plus` mins =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = modify uni_pic_base (+ fromIntegral mins * 60) timestamp

instance DateTimeMath UnixDateTime Second where
    timestamp `plus` secs =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = timestamp + fromIntegral secs

instance DateTimeMath UnixDateTimeMillis Second where
    timestamp `plus` secs =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = modify uni_mil_base (+ fromIntegral secs) timestamp

instance DateTimeMath UnixDateTimeMicros Second where
    timestamp `plus` secs =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = modify uni_mic_base (+ fromIntegral secs) timestamp

instance DateTimeMath UnixDateTimeNanos Second where
    timestamp `plus` secs =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = modify uni_nan_base (+ fromIntegral secs) timestamp

instance DateTimeMath UnixDateTimePicos Second where
    timestamp `plus` secs =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where time = modify uni_pic_base (+ fromIntegral secs) timestamp

instance DateTimeMath UnixDateTimeMillis Millis where
    UnixDateTimeMillis{..} `plus` mils =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where msum = fromIntegral _uni_mil_mill + fromIntegral mils
            base = _uni_mil_base + msum `div` 1000
            time = UnixDateTimeMillis base . fromIntegral $ msum `mod` 1000

instance DateTimeMath UnixDateTimeMicros Millis where
    UnixDateTimeMicros{..} `plus` mils =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where msum = fromIntegral _uni_mic_micr + fromIntegral mils * 1000
            base = _uni_mic_base + msum `div` 1000000
            time = UnixDateTimeMicros base . fromIntegral $ msum `mod` 1000000

instance DateTimeMath UnixDateTimeNanos Millis where
    UnixDateTimeNanos{..} `plus` mils =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where msum = fromIntegral _uni_nan_nano + fromIntegral mils * 1000000
            base = _uni_nan_base + msum `div` 1000000000
            time = UnixDateTimeNanos base . fromIntegral $ msum `mod` 1000000000

instance DateTimeMath UnixDateTimePicos Millis where
    UnixDateTimePicos{..} `plus` mils =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where psum = fromIntegral _uni_pic_pico + fromIntegral mils * 1000000000
            base = _uni_pic_base + psum `div` 1000000000000
            time = UnixDateTimePicos base . fromIntegral $ psum `mod` 1000000000000

instance DateTimeMath UnixDateTimeMicros Micros where
    UnixDateTimeMicros{..} `plus` mics =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where msum = fromIntegral _uni_mic_micr + fromIntegral mics
            base = _uni_mic_base + msum `div` 1000000
            time = UnixDateTimeMicros base . fromIntegral $ msum `mod` 1000000

instance DateTimeMath UnixDateTimeNanos Micros where
    UnixDateTimeNanos{..} `plus` mics =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where msum = fromIntegral _uni_nan_nano + fromIntegral mics * 1000
            base = _uni_nan_base + msum `div` 1000000000
            time = UnixDateTimeNanos base . fromIntegral $ msum `mod` 1000000000

instance DateTimeMath UnixDateTimePicos Micros where
    UnixDateTimePicos{..} `plus` mics =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where psum = fromIntegral _uni_pic_pico + fromIntegral mics * 1000000
            base = _uni_pic_base + psum `div` 1000000000000
            time = UnixDateTimePicos base . fromIntegral $ psum `mod` 1000000000000

instance DateTimeMath UnixDateTimeNanos Nanos where
    UnixDateTimeNanos{..} `plus` nans =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where msum = fromIntegral _uni_nan_nano + fromIntegral nans
            base = _uni_nan_base + msum `div` 1000000000
            time = UnixDateTimeNanos base . fromIntegral $ msum `mod` 1000000000

instance DateTimeMath UnixDateTimePicos Nanos where
    UnixDateTimePicos{..} `plus` nans =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where psum = fromIntegral _uni_pic_pico + fromIntegral nans * 1000
            base = _uni_pic_base + psum `div` 1000000000000
            time = UnixDateTimePicos base . fromIntegral $ psum `mod` 1000000000000

instance DateTimeMath UnixDateTimePicos Picos where
    UnixDateTimePicos{..} `plus` pics =
      if minBound <= time && time <= maxBound
      then time else error "plus: out of range"
      where psum = fromIntegral _uni_pic_pico + fromIntegral pics
            base = _uni_pic_base + psum `div` 1000000000000
            time = UnixDateTimePicos base . fromIntegral $ psum `mod` 1000000000000

instance FromJSON UnixDateTimeMillis
instance FromJSON UnixDateTimeMicros
instance FromJSON UnixDateTimeNanos
instance FromJSON UnixDateTimePicos

instance NFData UnixDateTimeMillis
instance NFData UnixDateTimeMicros
instance NFData UnixDateTimeNanos
instance NFData UnixDateTimePicos

instance Pretty UnixDate           where pretty = prettyUnixDate
instance Pretty UnixDateTime       where pretty = prettyUnixDateTime
instance Pretty UnixDateTimeMillis where pretty = prettyUnixDateTime
instance Pretty UnixDateTimeMicros where pretty = prettyUnixDateTime
instance Pretty UnixDateTimeNanos  where pretty = prettyUnixDateTime
instance Pretty UnixDateTimePicos  where pretty = prettyUnixDateTime

instance Random UnixDateTimeMillis where
   random         = first (uncurry UnixDateTimeMillis . (***) fromInteger fromInteger . flip divMod 1000) . randomR (0, 253402300799999)
   randomR (a, b) = first (uncurry UnixDateTimeMillis . (***) fromInteger fromInteger . flip divMod 1000) . randomR (minval, maxval)
     where minval = toInteger (_uni_mil_mill a) + toInteger (_uni_mil_base a) * 1000
           maxval = toInteger (_uni_mil_mill b) + toInteger (_uni_mil_base b) * 1000

instance Random UnixDateTimeMicros where
   random         = first (uncurry UnixDateTimeMicros . (***) fromInteger fromInteger . flip divMod 1000000) . randomR (0, 253402300799999999)
   randomR (a, b) = first (uncurry UnixDateTimeMicros . (***) fromInteger fromInteger . flip divMod 1000000) . randomR (minval, maxval)
     where minval = toInteger (_uni_mic_micr a) + toInteger (_uni_mic_base a) * 1000000
           maxval = toInteger (_uni_mic_micr b) + toInteger (_uni_mic_base b) * 1000000

instance Random UnixDateTimeNanos where
   random         = first (uncurry UnixDateTimeNanos . (***) fromInteger fromInteger . flip divMod 1000000000) . randomR (0, 253402300799999999999)
   randomR (a, b) = first (uncurry UnixDateTimeNanos . (***) fromInteger fromInteger . flip divMod 1000000000) . randomR (minval, maxval)
     where minval = toInteger (_uni_nan_nano a) + toInteger (_uni_nan_base a) * 1000000000
           maxval = toInteger (_uni_nan_nano b) + toInteger (_uni_nan_base b) * 1000000000

instance Random UnixDateTimePicos where
   random         = first (uncurry UnixDateTimePicos . (***) fromInteger fromInteger . flip divMod 1000000000000) . randomR (0, 253402300799999999999999)
   randomR (a, b) = first (uncurry UnixDateTimePicos . (***) fromInteger fromInteger . flip divMod 1000000000000) . randomR (minval, maxval)
     where minval = toInteger (_uni_pic_pico a) + toInteger (_uni_pic_base a) * 1000000000000
           maxval = toInteger (_uni_pic_pico b) + toInteger (_uni_pic_base b) * 1000000000000

instance Show UnixDate where
    show date = printf "%04d-%02d-%02d" _d_year _d_mon _d_mday
      where DateStruct{..} = toDateStruct date

instance Show UnixDateTime where
    show time = printf "%04d-%02d-%02d %02d:%02d:%02d" _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec
      where DateTimeStruct{..} = toDateTimeStruct time
            sec = round _dt_sec :: Second

instance Show UnixDateTimeMillis where
    show time = printf "%04d-%02d-%02d %02d:%02d:%02d.%03d" _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec mil
      where DateTimeStruct{..} = toDateTimeStruct time
            (sec, mil) = properFracMillis _dt_sec

instance Show UnixDateTimeMicros where
    show time = printf "%04d-%02d-%02d %02d:%02d:%02d.%06d" _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec mic
      where DateTimeStruct{..} = toDateTimeStruct time
            (sec, mic) = properFracMicros _dt_sec

instance Show UnixDateTimeNanos where
    show time = printf "%04d-%02d-%02d %02d:%02d:%02d.%09d" _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec nan
      where DateTimeStruct{..} = toDateTimeStruct time
            (sec, nan) = properFracNanos _dt_sec

instance Show UnixDateTimePicos where
    show time = printf "%04d-%02d-%02d %02d:%02d:%02d.%012d" _dt_year _dt_mon _dt_mday _dt_hour _dt_min sec pic
      where DateTimeStruct{..} = toDateTimeStruct time
            (sec, pic) = properFracPicos _dt_sec

instance Storable UnixDateTimeMillis where
    sizeOf  _ = 10
    alignment = sizeOf
    peekElemOff ptr  n = do
      let off = 10 * n
      base <- peek . plusPtr ptr $ off
      mil  <- peek . plusPtr ptr $ off + 8
      return $! UnixDateTimeMillis base mil
    pokeElemOff ptr  n UnixDateTimeMillis{..} = do
      let off = 10 * n
      poke (plusPtr ptr $ off    ) _uni_mil_base
      poke (plusPtr ptr $ off + 8) _uni_mil_mill

instance Storable UnixDateTimeMicros where
    sizeOf  _ = 12
    alignment = sizeOf
    peekElemOff ptr  n = do
      let off = 12 * n
      base <- peek . plusPtr ptr $ off
      mic  <- peek . plusPtr ptr $ off + 8
      return $! UnixDateTimeMicros base mic
    pokeElemOff ptr  n UnixDateTimeMicros{..} = do
      let off = 12 * n
      poke (plusPtr ptr $ off    ) _uni_mic_base
      poke (plusPtr ptr $ off + 8) _uni_mic_micr

instance Storable UnixDateTimeNanos where
    sizeOf  _ = 12
    alignment = sizeOf
    peekElemOff ptr  n = do
      let off = 12 * n
      base <- peek . plusPtr ptr $ off
      nan  <- peek . plusPtr ptr $ off + 8
      return $! UnixDateTimeNanos base nan
    pokeElemOff ptr  n UnixDateTimeNanos{..} = do
      let off = 12 * n
      poke (plusPtr ptr $ off    ) _uni_nan_base
      poke (plusPtr ptr $ off + 8) _uni_nan_nano

instance Storable UnixDateTimePicos where
    sizeOf  _ = 16
    alignment = sizeOf
    peekElemOff ptr  n = do
      let off = 16 * n
      base <- peek . plusPtr ptr $ off
      pic  <- peek . plusPtr ptr $ off + 8
      return $! UnixDateTimePicos base pic
    pokeElemOff ptr  n UnixDateTimePicos{..} = do
      let off = 16 * n
      poke (plusPtr ptr $ off    ) _uni_pic_base
      poke (plusPtr ptr $ off + 8) _uni_pic_pico

instance Storable TimeOfDay where
   sizeOf  _ = 16
   alignment = sizeOf
   peekElemOff ptr  n = do
     let off = 16 * n
     base <- peek . plusPtr ptr $ off
     mic  <- peek . plusPtr ptr $ off + 8
     return $! TimeOfDay base mic
   pokeElemOff ptr  n TimeOfDay{..} = do
     let off = 16 * n
     poke (plusPtr ptr $ off    ) tod_base
     poke (plusPtr ptr $ off + 8) tod_mic

instance ToJSON UnixDateTimeMillis
instance ToJSON UnixDateTimeMicros
instance ToJSON UnixDateTimeNanos
instance ToJSON UnixDateTimePicos

instance Unix UnixDate
instance Unix UnixDateTime
instance Unix UnixDateTimeMillis
instance Unix UnixDateTimeMicros
instance Unix UnixDateTimeNanos
instance Unix UnixDateTimePicos

foreign import ccall "gettimeofday"
   getTimeOfDay :: Ptr TimeOfDay -> Ptr () -> IO CInt

-- | Creates a Unix date.
createUnixDate :: Year -> Month -> Day -> UnixDate
createUnixDate year month day =
   if minBound <= date && date <= maxBound then date
   else error "createUnixDate: date not supported"
   where date = fromIntegral $ epochToDate year month day

-- | Creates a Unix date and time.
createUnixDateTime :: Year -> Month -> Day -> Hour -> Minute -> Second -> UnixDateTime
createUnixDateTime year month day hour minute second =
   if minBound <= time && time <= maxBound then time
   else error "createUnixDateTime: time not supported"
   where days = epochToDate year month day
         secs = dateToTime hour minute second
         time = fromIntegral days * 86400 + fromIntegral secs

-- | Creates a Unix date and time with millisecond granularity.
createUnixDateTimeMillis :: Year -> Month -> Day -> Hour -> Minute -> Second -> Millis -> UnixDateTimeMillis
createUnixDateTimeMillis year month day hour minute second millisecond =
   if minBound <= time && time <= maxBound then time
   else error "createUnixDateTimeMillis: time not supported"
   where mils = fromIntegral $ millisecond `mod` 1000
         adds = fromIntegral $ millisecond `div` 1000
         days = fromIntegral $ epochToDate year month day
         secs = fromIntegral $ dateToTime hour minute second
         base = days * 86400 + secs + adds
         time = UnixDateTimeMillis base mils

-- | Creates a Unix date and time with microsecond granularity.
createUnixDateTimeMicros :: Year -> Month -> Day -> Hour -> Minute -> Second -> Micros -> UnixDateTimeMicros
createUnixDateTimeMicros year month day hour minute second microsecond =
   if minBound <= time && time <= maxBound then time
   else error "createUnixDateTimeMicros: time not supported"
   where mics = fromIntegral $ microsecond `mod` 1000000
         adds = fromIntegral $ microsecond `div` 1000000
         days = fromIntegral $ epochToDate year month day
         secs = fromIntegral $ dateToTime hour minute second
         base = days * 86400 + secs + adds
         time = UnixDateTimeMicros base mics

-- | Creates a Unix date and time with nanosecond granularity.
createUnixDateTimeNanos :: Year -> Month -> Day -> Hour -> Minute -> Second -> Nanos -> UnixDateTimeNanos
createUnixDateTimeNanos year month day hour minute second nanosecond =
   if minBound <= time && time <= maxBound then time
   else error "createUnixDateTimeNanos: time not supported"
   where nans = fromIntegral $ nanosecond `mod` 1000000000
         adds = fromIntegral $ nanosecond `div` 1000000000
         days = fromIntegral $ epochToDate year month day
         secs = fromIntegral $ dateToTime hour minute second
         base = days * 86400 + secs + adds
         time = UnixDateTimeNanos base nans

-- | Creates a Unix date and time with picosecond granularity.
createUnixDateTimePicos :: Year -> Month -> Day -> Hour -> Minute -> Second -> Picos -> UnixDateTimePicos
createUnixDateTimePicos year month day hour minute second picosecond =
   if minBound <= time && time <= maxBound then time
   else error "createUnixDateTimePicos: time not supported"
   where pics = fromIntegral $ picosecond `mod` 1000000000000
         adds = fromIntegral $ picosecond `div` 1000000000000
         days = fromIntegral $ epochToDate year month day
         secs = fromIntegral $ dateToTime hour minute second
         base = days * 86400 + secs + adds
         time = UnixDateTimePicos base pics

-- | Decomposes a Unix date into a human-readable format.
decompUnixDate :: UnixDate -> DateStruct
decompUnixDate date =
   go 1970 $ fromIntegral date
   where go :: Year -> Day -> DateStruct
         go !year !days =
            if days >= size
            then go (year + 1) (days - size)
            else DateStruct year month mday wday
            where wday = dayOfWeek date
                  leap = isLeapYear year
                  size = if leap then 366 else 365
                  (,) month mday = decompYearToDate days leap

-- | Decomposes the number of days since January 1st into month and day components.
decompYearToDate :: Day -> Bool -> (Month, Day)
decompYearToDate days leap =
   if leap
   then if days >= 182
        then if days >= 274
             then if days >= 335
                  then (12, days - 334)
                  else if days >= 305
                       then (11, days - 304)
                       else (10, days - 273)
             else if days >= 244
                  then (09, days - 243)
                  else if days >= 213
                       then (08, days - 212)
                       else (07, days - 181)
        else if days >= 091
             then if days >= 152
                  then (06, days - 151)
                  else if days >= 121
                       then (05, days - 120)
                       else (04, days - 090)
             else if days >= 060
                  then (03, days - 059)
                  else if days >= 031
                       then (02, days - 030)
                       else (01, days + 001)
   else if days >= 181
        then if days >= 273
             then if days >= 334
                  then (12, days - 333)
                  else if days >= 304
                       then (11, days - 303)
                       else (10, days - 272)
             else if days >= 243
                  then (09, days - 242)
                  else if days >= 212
                       then (08, days - 211)
                       else (07, days - 180)
        else if days >= 090
             then if days >= 151
                  then (06, days - 150)
                  else if days >= 120
                       then (05, days - 119)
                       else (04, days - 089)
             else if days >= 059
                  then (03, days - 058)
                  else if days >= 031
                       then (02, days - 030)
                       else (01, days + 001)

-- | Computes the day of the week.
dayOfWeek :: UnixDate -> DayOfWeek
dayOfWeek date =
   case date `mod` 7 of
      0 -> Thursday
      1 -> Friday
      2 -> Saturday
      3 -> Sunday
      4 -> Monday
      5 -> Tuesday
      _ -> Wednesday

-- | Decomposes a Unix date and time into a human-readable format.
decompUnixDateTime :: UnixDateTime -> DateTimeStruct
decompUnixDateTime time =
   DateTimeStruct _d_year _d_mon _d_mday _d_wday hour min sec
   where DateStruct{..} = decompUnixDate date
         date = fromIntegral $ time `div` 86400
         mod1 = fromIntegral $ time `mod` 86400
         hour = fromIntegral $ mod1 `div` 03600
         mod2 =                mod1 `mod` 03600
         min  =                mod2 `div` 00060
         sec  = fromIntegral $ mod2 `mod` 00060

-- | Decomposes a Unix date and time with millisecond granularity into a human-readable format.
decompUnixDateTimeMillis :: UnixDateTimeMillis -> DateTimeStruct
decompUnixDateTimeMillis UnixDateTimeMillis{..} =
   DateTimeStruct _d_year _d_mon _d_mday _d_wday hour min $ sec + frac
   where DateStruct{..} = decompUnixDate date
         date = fromIntegral $ time `div` 86400
         mod1 = fromIntegral $ time `mod` 86400
         hour = fromIntegral $ mod1 `div` 03600
         mod2 =                mod1 `mod` 03600
         min  =                mod2 `div` 00060
         sec  = fromIntegral $ mod2 `mod` 00060
         time =               _uni_mil_base
         frac = fromIntegral  _uni_mil_mill / 1000

-- | Decomposes a Unix date and time with microsecond granularity into a human-readable format.
decompUnixDateTimeMicros :: UnixDateTimeMicros -> DateTimeStruct
decompUnixDateTimeMicros UnixDateTimeMicros{..} =
   DateTimeStruct _d_year _d_mon _d_mday _d_wday hour min $ sec + frac
   where DateStruct{..} = decompUnixDate date
         date = fromIntegral $ time `div` 86400
         mod1 = fromIntegral $ time `mod` 86400
         hour = fromIntegral $ mod1 `div` 03600
         mod2 =                mod1 `mod` 03600
         min  =                mod2 `div` 00060
         sec  = fromIntegral $ mod2 `mod` 00060
         time =               _uni_mic_base
         frac = fromIntegral  _uni_mic_micr / 1000000

-- | Decomposes a Unix date and time with nanosecond granularity into a human-readable format.
decompUnixDateTimeNanos :: UnixDateTimeNanos -> DateTimeStruct
decompUnixDateTimeNanos UnixDateTimeNanos{..} =
   DateTimeStruct _d_year _d_mon _d_mday _d_wday hour min $ sec + frac
   where DateStruct{..} = decompUnixDate date
         date = fromIntegral $ base `div` 86400
         mod1 = fromIntegral $ base `mod` 86400
         hour = fromIntegral $ mod1 `div` 03600
         mod2 =                mod1 `mod` 03600
         min  =                mod2 `div` 00060
         sec  = fromIntegral $ mod2 `mod` 00060
         base =               _uni_nan_base
         frac = fromIntegral  _uni_nan_nano / 1000000000

-- | Decomposes a Unix date and time with picosecond granularity into a human-readable format.
decompUnixDateTimePicos :: UnixDateTimePicos -> DateTimeStruct
decompUnixDateTimePicos UnixDateTimePicos{..} =
   DateTimeStruct _d_year _d_mon _d_mday _d_wday hour min $ sec + frac
   where DateStruct{..} = decompUnixDate date
         date = fromIntegral $ base `div` 86400
         mod1 = fromIntegral $ base `mod` 86400
         hour = fromIntegral $ mod1 `div` 03600
         mod2 =                mod1 `mod` 03600
         min  =                mod2 `div` 00060
         sec  = fromIntegral $ mod2 `mod` 00060
         base =               _uni_pic_base
         frac = fromIntegral  _uni_pic_pico / 1000000000000

-- | Gets the current Unix date from the system clock.
getCurrentUnixDate :: IO UnixDate
getCurrentUnixDate = getCurrentUnixDateTime >>= return . convert

-- | Gets the current Unix date and time from the system clock.
getCurrentUnixDateTime :: IO UnixDateTime
getCurrentUnixDateTime =
   with (TimeOfDay 0 0) $ \ ptr ->
   getTimeOfDay ptr nullPtr >>= getResult ptr
   where getResult ptr 0 = peek $ castPtr ptr
         getResult _   _ = error "getCurrentUnixDateTime: unknown"

-- | Gets the current Unix date and time with millisecond granularity from the system clock.
getCurrentUnixDateTimeMillis :: IO UnixDateTimeMillis
getCurrentUnixDateTimeMillis =
   with (TimeOfDay 0 0) $ \ ptr ->
   getTimeOfDay ptr nullPtr >>= getResult ptr
   where getResult ptr 0 = peek ptr >>= \ TimeOfDay{..} ->
           return $! UnixDateTimeMillis tod_base . fromIntegral $ tod_mic `div` 1000
         getResult _   _ = error "getCurrentUnixDateTimeMillis: unknown"

-- | Gets the current Unix date and time with microsecond granularity from the system clock.
getCurrentUnixDateTimeMicros :: IO UnixDateTimeMicros
getCurrentUnixDateTimeMicros =
   with (TimeOfDay 0 0) $ \ ptr ->
   getTimeOfDay ptr nullPtr >>= getResult ptr
   where getResult ptr 0 = peek ptr >>= \ TimeOfDay{..} ->
           return $! UnixDateTimeMicros tod_base $ fromIntegral tod_mic
         getResult _   _ = error "getCurrentUnixDateTimeMicros: unknown"

-- | Gets the current Unix date and time with nanosecond granularity from the system clock.
getCurrentUnixDateTimeNanos :: IO UnixDateTimeNanos
getCurrentUnixDateTimeNanos =
   with (TimeOfDay 0 0) $ \ ptr ->
   getTimeOfDay ptr nullPtr >>= getResult ptr
   where getResult ptr 0 = peek ptr >>= \ TimeOfDay{..} ->
           return $! UnixDateTimeNanos tod_base $ fromIntegral tod_mic * 1000
         getResult _   _ = error "getCurrentUnixDateTimeNanos: unknown"

-- | Gets the current Unix date and time with picosecond granularity from the system clock.
getCurrentUnixDateTimePicos :: IO UnixDateTimePicos
getCurrentUnixDateTimePicos =
   with (TimeOfDay 0 0) $ \ ptr ->
   getTimeOfDay ptr nullPtr >>= getResult ptr
   where getResult ptr 0 = peek ptr >>= \ TimeOfDay{..} ->
           return $! UnixDateTimePicos tod_base $ fromIntegral tod_mic * 1000000
         getResult _   _ = error "getCurrentUnixDateTimePicos: unknown"

-- | Shows a Unix date as a string.
prettyUnixDate :: UnixDate -> String
prettyUnixDate date =
   printf "%s, %s %s, %04d" wday mon mday _d_year
   where DateStruct{..} = toDateStruct date
         wday = show _d_wday
         mon  = prettyMonth _d_mon
         mday = prettyDay _d_mday

-- | Shows a Unix date and time as a string.
prettyUnixDateTime :: DateTime dt => dt -> String
prettyUnixDateTime time =
   printf str hour _dt_min ampm wday mon mday _dt_year
   where DateTimeStruct{..} = toDateTimeStruct time
         str  = "%d:%02d %s, %s, %s %s, %04d"
         wday = show _dt_wday
         mon  = prettyMonth _dt_mon
         mday = prettyDay _dt_mday
         (hour, ampm) = prettyHour _dt_hour