{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.Date where

import           Control.Monad (Monad(..))
import qualified Data.Fixed
import           Data.Function (($), (.), id)
import           Data.Int (Int)
import           Data.Maybe (Maybe(..))
import qualified Data.Time.Calendar    as Time
import qualified Data.Time.Clock       as Time
import qualified Data.Time.Clock.POSIX as Time (posixSecondsToUTCTime)
import qualified Data.Time.Format      as Time ()
import qualified Data.Time.LocalTime   as Time
import           Prelude (Integer, Num(..))
import           System.IO (IO)

-- * Type 'Date'

type Date   = Time.UTCTime
type Year   = Integer
type Month  = Int
type Day    = Time.Day
type DoM    = Int
type Hour   = Int
type Minute = Int
type Second = Data.Fixed.Pico

date_epoch :: Date
date_epoch = Time.posixSecondsToUTCTime 0

date_now :: IO Date
date_now = Time.getCurrentTime

date :: Year -> Month -> DoM -> Hour -> Minute -> Second -> Maybe Date
date y m d h mn s = do
	gday <- Time.fromGregorianValid y m d
	hod <- Time.makeTimeOfDayValid h mn s
	return $
		Time.UTCTime gday $
			Time.timeOfDayToTime hod

-- ** Components

date_gregorian :: Date -> (Year, Month, DoM)
date_gregorian = Time.toGregorian . Time.utctDay

date_year :: Date -> Year
date_year = (\(x, _, _) -> x) . date_gregorian

date_month :: Date -> Month
date_month = (\(_, x, _) -> x) . date_gregorian

date_day :: Date -> Day
date_day = Time.utctDay

date_dom :: Date -> DoM
date_dom = (\(_, _, x) -> x) . date_gregorian

date_tod :: Date -> Time.TimeOfDay
date_tod = Time.timeToTimeOfDay . Time.utctDayTime

date_hour :: Date -> Hour
date_hour = (\(Time.TimeOfDay x _ _) -> x) . date_tod

date_minute :: Date -> Minute
date_minute = (\(Time.TimeOfDay _ x _) -> x) . date_tod

date_second :: Date -> Second
date_second = (\(Time.TimeOfDay _ _ x) -> x) . date_tod

date_next_year_start :: Date -> Date
date_next_year_start d =
	date_epoch{ Time.utctDay =
		Time.addGregorianYearsClip
		 (date_year d + 1 - 1970)
		 (Time.utctDay d)
	 }

date_utc :: Date -> Time.UTCTime
date_utc = id

date_bench :: IO a -> IO (a, Time.NominalDiffTime)
date_bench m = do
	t0 <- date_now
	r  <- m
	t1 <- date_now
	return (r, Time.diffUTCTime t1 t0)