{-# LANGUAGE TypeFamilies #-}
{-# 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)
import           Data.Proxy (Proxy(..))

-- * Class 'Date'
class Date d where
	type Date_Year   d
	type Date_Month  d
	type Date_DoM    d
	type Date_Hour   d
	type Date_Minute d
	type Date_Second d
	
	date_epoch :: d
	date_now   :: IO d
	date_gregorian :: d -> (Date_Year d, Date_Month d, Date_DoM d)
	date_year   :: d -> Date_Year d
	date_month  :: d -> Date_Month d
	date_dom    :: d -> Date_DoM d
	date_tod    :: d -> (Date_Hour d, Date_Minute d, Date_Second d)
	date_hour   :: d -> Date_Hour d
	date_minute :: d -> Date_Minute d
	date_second :: d -> Date_Second d
	date_utc    :: d -> Time.UTCTime
	date_from
	 :: Date_Year d
	 -> Date_Month d
	 -> Date_DoM d
	 -> Date_Hour d
	 -> Date_Minute d
	 -> Date_Second d
	 -> Maybe d
	
	date_year   = (\(x, _, _) -> x) . date_gregorian
	date_month  = (\(_, x, _) -> x) . date_gregorian
	date_dom    = (\(_, _, x) -> x) . date_gregorian
	date_hour   = (\(x, _, _) -> x) . date_tod
	date_minute = (\(_, x, _) -> x) . date_tod
	date_second = (\(_, _, x) -> x) . date_tod

_Date :: Proxy Date
_Date = Proxy

instance Date Time.UTCTime where
	type Date_Year   Time.UTCTime = Integer
	type Date_Month  Time.UTCTime = Int
	type Date_DoM    Time.UTCTime = Int
	type Date_Hour   Time.UTCTime = Int
	type Date_Minute Time.UTCTime = Int
	type Date_Second Time.UTCTime = Data.Fixed.Pico
	date_epoch     = Time.posixSecondsToUTCTime 0
	date_now       = Time.getCurrentTime
	date_gregorian = Time.toGregorian . Time.utctDay
	date_tod d =
		case Time.timeToTimeOfDay $ Time.utctDayTime d of
		 Time.TimeOfDay h m s -> (h, m, s)
	-- date_day = Time.utctDay
	date_utc = id
	date_from 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

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

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)