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

-- import qualified Data.Fixed -- NOTE: not useful before base >=4.7
import           Data.Function (($))
import           Data.Interval (Interval)
import qualified Data.Interval as Interval
import qualified Data.List
import           Data.Maybe (Maybe(..), fromJust)
import qualified Data.Time.Calendar    as Time
import qualified Data.Time.Clock       as Time
import qualified Data.Time.Format      as Time ()
import qualified Data.Time.LocalTime   as Time
import           Prelude (Integral(..), Num(..))

import           Hcompta.Date hiding (year, month, dom, hour, minute, second)
import qualified Hcompta.Date as Date


-- *  Gregorian

year :: Year -> Interval Date
year y =
	let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
	let hy = Time.addGregorianYearsClip 1 ly in
	fromJust $ (Interval.<=..<)
	 nil{Time.utctDay=ly}
	 nil{Time.utctDay=hy}

month :: Year -> Month -> Interval Date
month y m =
	let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
	let lm = Time.addGregorianMonthsClip (toInteger m - 1) ly in
	let hm = Time.addGregorianMonthsClip 1 lm in
	fromJust $ (Interval.<=..<)
	 nil{Time.utctDay=lm}
	 nil{Time.utctDay=hm}

dom :: Year -> Month -> DoM -> Interval Date
dom y m d =
	let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
	let lm = Time.addGregorianMonthsClip (toInteger m - 1) ly in
	let ld = Time.addDays (toInteger d - 1) lm in
	let hd = Time.addDays 1 ld in
	fromJust $ (Interval.<=..<)
	 nil{Time.utctDay=ld}
	 nil{Time.utctDay=hd}

hour :: Year -> Month -> DoM -> Hour -> Interval Date
hour y m d h =
	let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
	let lm = Time.addGregorianMonthsClip (toInteger m - 1) ly in
	let ld = nil{Time.utctDay=Time.addDays (toInteger d - 1) lm} in
	let lh = Time.addUTCTime (fromInteger $ toInteger (h * 3600)) ld in
	let hh = Time.addUTCTime 3600 lh in
	fromJust $ (Interval.<=..<) lh hh

minute :: Year -> Month -> DoM -> Hour -> Minute -> Interval Date
minute y m d h n =
	let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
	let lm = Time.addGregorianMonthsClip (toInteger m - 1) ly in
	let ld = nil{Time.utctDay=Time.addDays (toInteger d - 1) lm} in
	let lh = Time.addUTCTime (fromInteger $ toInteger (h * 3600)) ld in
	let ln = Time.addUTCTime (fromInteger $ toInteger (n * 60)) lh in
	let hn = Time.addUTCTime 60 ln in
	fromJust $ (Interval.<=..<) ln hn

{- NOTE: Data.Fixed.MkFixed requires base >=4.7
second :: Year -> Month -> DoM -> Hour -> Minute -> Second -> Interval Date
second y m d h n (Data.Fixed.MkFixed s) =
	let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
	let lm = Time.addGregorianMonthsClip (toInteger m - 1) ly in
	let ld = nil{Time.utctDay=Time.addDays (toInteger d - 1) lm} in
	let lh = Time.addUTCTime (fromInteger $ toInteger (h * 3600)) ld in
	let ln = Time.addUTCTime (fromInteger $ toInteger (n * 60)) lh in
	let ls = Time.addUTCTime (fromInteger $ s) ln in
	let hs = Time.addUTCTime 1 ls in
	fromJust $ (Interval.<=..<) ls hs
-}

-- * Slice

slice :: (Date -> Interval Date) -> Interval Date -> [Interval Date]
slice slicer i =
	Data.List.unfoldr
	 (\last_slice -> case Interval.intersection i last_slice of
		 Nothing -> Nothing
		 Just n  -> Just (n, slicer (Interval.limit $ Interval.high last_slice))
		) $
	slicer (Interval.limit $ Interval.low i)

year_slice :: Date -> Interval Date
year_slice d =
	let (y, _, _) = Date.gregorian d in
	year y

month_slice :: Date -> Interval Date
month_slice d =
	let (y, m, _) = Date.gregorian d in
	month y m

dom_slice :: Date -> Interval Date
dom_slice d =
	let (y, m, o) = Date.gregorian d in
	dom y m o

hour_slice :: Date -> Interval Date
hour_slice d =
	let (y, m, o) = Date.gregorian d in
	let Time.TimeOfDay h _ _ = tod d in
	hour y m o h

minute_slice :: Date -> Interval Date
minute_slice d =
	let (y, m, o) = Date.gregorian d in
	let Time.TimeOfDay h n _ = tod d in
	minute y m o h n

{-
second_slice :: Date -> Interval Date
second_slice d =
	let (y, m, o) = Date.gregorian d in
	let Time.TimeOfDay h n s = tod d in
	second y m o h n s
-}