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