lib/Hcompta/Date.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2 module Hcompta.Date where
   3
   4 import           Control.Monad (Monad(..))
   5 import qualified Data.Fixed
   6 import           Data.Function (($), (.), id)
   7 import           Data.Int (Int)
   8 import           Data.Maybe (Maybe(..))
   9 import qualified Data.Time.Calendar    as Time
  10 import qualified Data.Time.Clock       as Time
  11 import qualified Data.Time.Clock.POSIX as Time (posixSecondsToUTCTime)
  12 import qualified Data.Time.Format      as Time ()
  13 import qualified Data.Time.LocalTime   as Time
  14 import           Prelude (Integer, Num(..))
  15 import           System.IO (IO)
  16
  17 -- * Type 'Date'
  18
  19 type Date   = Time.UTCTime
  20 type Year   = Integer
  21 type Month  = Int
  22 type Day    = Time.Day
  23 type DoM    = Int
  24 type Hour   = Int
  25 type Minute = Int
  26 type Second = Data.Fixed.Pico
  27
  28 date_epoch :: Date
  29 date_epoch = Time.posixSecondsToUTCTime 0
  30
  31 date_now :: IO Date
  32 date_now = Time.getCurrentTime
  33
  34 date :: Year -> Month -> DoM -> Hour -> Minute -> Second -> Maybe Date
  35 date y m d h mn s = do
  36         gday <- Time.fromGregorianValid y m d
  37         hod <- Time.makeTimeOfDayValid h mn s
  38         return $
  39                 Time.UTCTime gday $
  40                         Time.timeOfDayToTime hod
  41
  42 -- ** Components
  43
  44 date_gregorian :: Date -> (Year, Month, DoM)
  45 date_gregorian = Time.toGregorian . Time.utctDay
  46
  47 date_year :: Date -> Year
  48 date_year = (\(x, _, _) -> x) . date_gregorian
  49
  50 date_month :: Date -> Month
  51 date_month = (\(_, x, _) -> x) . date_gregorian
  52
  53 date_day :: Date -> Day
  54 date_day = Time.utctDay
  55
  56 date_dom :: Date -> DoM
  57 date_dom = (\(_, _, x) -> x) . date_gregorian
  58
  59 date_tod :: Date -> Time.TimeOfDay
  60 date_tod = Time.timeToTimeOfDay . Time.utctDayTime
  61
  62 date_hour :: Date -> Hour
  63 date_hour = (\(Time.TimeOfDay x _ _) -> x) . date_tod
  64
  65 date_minute :: Date -> Minute
  66 date_minute = (\(Time.TimeOfDay _ x _) -> x) . date_tod
  67
  68 date_second :: Date -> Second
  69 date_second = (\(Time.TimeOfDay _ _ x) -> x) . date_tod
  70
  71 date_next_year_start :: Date -> Date
  72 date_next_year_start d =
  73         date_epoch{ Time.utctDay =
  74                 Time.addGregorianYearsClip
  75                  (date_year d + 1 - 1970)
  76                  (Time.utctDay d)
  77          }
  78
  79 date_utc :: Date -> Time.UTCTime
  80 date_utc = id
  81
  82 date_bench :: IO a -> IO (a, Time.NominalDiffTime)
  83 date_bench m = do
  84         t0 <- date_now
  85         r  <- m
  86         t1 <- date_now
  87         return (r, Time.diffUTCTime t1 t0)