lib/Hcompta/Date.hs

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