lib/Hcompta/Date.hs

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