lib/Hcompta/Date/Interval.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2 module Hcompta.Date.Interval where
   3
   4 -- import qualified Data.Fixed -- NOTE: not useful before base >=4.7
   5 import qualified Data.List
   6 import           Data.Maybe (Maybe(..), fromJust)
   7 import qualified Data.Time.Calendar    as Time
   8 import qualified Data.Time.Clock       as Time
   9 import qualified Data.Time.Format      as Time ()
  10 import qualified Data.Time.LocalTime   as Time
  11 import           Prelude ( ($)
  12                          , Integral(..)
  13                          , Num(..)
  14                          )
  15
  16 import           Hcompta.Date hiding (year, month, dom, hour, minute, second)
  17 import qualified Hcompta.Date as Date
  18 import           Hcompta.Lib.Interval (Interval)
  19 import qualified Hcompta.Lib.Interval as Interval
  20
  21
  22 -- *  Gregorian
  23
  24 year :: Year -> Interval Date
  25 year y =
  26         let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
  27         let hy = Time.addGregorianYearsClip 1 ly in
  28         fromJust $ (Interval.<=..<)
  29          nil{Time.utctDay=ly}
  30          nil{Time.utctDay=hy}
  31
  32 month :: Year -> Month -> Interval Date
  33 month y m =
  34         let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
  35         let lm = Time.addGregorianMonthsClip (toInteger m - 1) ly in
  36         let hm = Time.addGregorianMonthsClip 1 lm in
  37         fromJust $ (Interval.<=..<)
  38          nil{Time.utctDay=lm}
  39          nil{Time.utctDay=hm}
  40
  41 dom :: Year -> Month -> DoM -> Interval Date
  42 dom y m d =
  43         let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
  44         let lm = Time.addGregorianMonthsClip (toInteger m - 1) ly in
  45         let ld = Time.addDays (toInteger d - 1) lm in
  46         let hd = Time.addDays 1 ld in
  47         fromJust $ (Interval.<=..<)
  48          nil{Time.utctDay=ld}
  49          nil{Time.utctDay=hd}
  50
  51 hour :: Year -> Month -> DoM -> Hour -> Interval Date
  52 hour y m d h =
  53         let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
  54         let lm = Time.addGregorianMonthsClip (toInteger m - 1) ly in
  55         let ld = nil{Time.utctDay=Time.addDays (toInteger d - 1) lm} in
  56         let lh = Time.addUTCTime (fromInteger $ toInteger (h * 3600)) ld in
  57         let hh = Time.addUTCTime 3600 lh in
  58         fromJust $ (Interval.<=..<) lh hh
  59
  60 minute :: Year -> Month -> DoM -> Hour -> Minute -> Interval Date
  61 minute y m d h n =
  62         let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
  63         let lm = Time.addGregorianMonthsClip (toInteger m - 1) ly in
  64         let ld = nil{Time.utctDay=Time.addDays (toInteger d - 1) lm} in
  65         let lh = Time.addUTCTime (fromInteger $ toInteger (h * 3600)) ld in
  66         let ln = Time.addUTCTime (fromInteger $ toInteger (n * 60)) lh in
  67         let hn = Time.addUTCTime 60 ln in
  68         fromJust $ (Interval.<=..<) ln hn
  69
  70 {- NOTE: Data.Fixed.MkFixed requires base >=4.7
  71 second :: Year -> Month -> DoM -> Hour -> Minute -> Second -> Interval Date
  72 second y m d h n (Data.Fixed.MkFixed s) =
  73         let ly = Time.addGregorianYearsClip (y - 1970) (day nil) in
  74         let lm = Time.addGregorianMonthsClip (toInteger m - 1) ly in
  75         let ld = nil{Time.utctDay=Time.addDays (toInteger d - 1) lm} in
  76         let lh = Time.addUTCTime (fromInteger $ toInteger (h * 3600)) ld in
  77         let ln = Time.addUTCTime (fromInteger $ toInteger (n * 60)) lh in
  78         let ls = Time.addUTCTime (fromInteger $ s) ln in
  79         let hs = Time.addUTCTime 1 ls in
  80         fromJust $ (Interval.<=..<) ls hs
  81 -}
  82
  83 -- * Slice
  84
  85 slice :: (Date -> Interval Date) -> Interval Date -> [Interval Date]
  86 slice slicer i =
  87         Data.List.unfoldr
  88          (\last_slice -> case Interval.intersection i last_slice of
  89                  Nothing -> Nothing
  90                  Just n  -> Just (n, slicer (Interval.limit $ Interval.high last_slice))
  91                 ) $
  92         slicer (Interval.limit $ Interval.low i)
  93
  94 year_slice :: Date -> Interval Date
  95 year_slice d =
  96         let (y, _, _) = Date.gregorian d in
  97         year y
  98
  99 month_slice :: Date -> Interval Date
 100 month_slice d =
 101         let (y, m, _) = Date.gregorian d in
 102         month y m
 103
 104 dom_slice :: Date -> Interval Date
 105 dom_slice d =
 106         let (y, m, o) = Date.gregorian d in
 107         dom y m o
 108
 109 hour_slice :: Date -> Interval Date
 110 hour_slice d =
 111         let (y, m, o) = Date.gregorian d in
 112         let Time.TimeOfDay h _ _ = tod d in
 113         hour y m o h
 114
 115 minute_slice :: Date -> Interval Date
 116 minute_slice d =
 117         let (y, m, o) = Date.gregorian d in
 118         let Time.TimeOfDay h n _ = tod d in
 119         minute y m o h n
 120
 121 {-
 122 second_slice :: Date -> Interval Date
 123 second_slice d =
 124         let (y, m, o) = Date.gregorian d in
 125         let Time.TimeOfDay h n s = tod d in
 126         second y m o h n s
 127 -}