lib/Hcompta/Date.hs

   1 module Hcompta.Date where
   2
   3 import Control.Monad (Monad(..))
   4 import Data.Function (($), (.), id)
   5 import Data.Int (Int)
   6 import Data.Maybe (Maybe(..))
   7 import Prelude (Integer, Num(..))
   8 import System.IO (IO)
   9 import qualified Data.Fixed
  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
  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         epoch :: d
  26         now   :: IO d
  27         gregorianOf :: d -> (Date_Year d, Date_Month d, Date_DoM d)
  28         yearOf   :: d -> Date_Year d
  29         monthOf  :: d -> Date_Month d
  30         domOf    :: d -> Date_DoM d
  31         todOf    :: d -> (Date_Hour d, Date_Minute d, Date_Second d)
  32         hourOf   :: d -> Date_Hour d
  33         minuteOf :: d -> Date_Minute d
  34         secondOf :: d -> Date_Second d
  35         utcOf    :: d -> Time.UTCTime
  36         dateOf
  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         yearOf   = (\(x, _, _) -> x) . gregorianOf
  46         monthOf  = (\(_, x, _) -> x) . gregorianOf
  47         domOf    = (\(_, _, x) -> x) . gregorianOf
  48         hourOf   = (\(x, _, _) -> x) . todOf
  49         minuteOf = (\(_, x, _) -> x) . todOf
  50         secondOf = (\(_, _, x) -> x) . todOf
  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         epoch     = Time.posixSecondsToUTCTime 0
  60         now       = Time.getCurrentTime
  61         gregorianOf = Time.toGregorian . Time.utctDay
  62         todOf d =
  63                 case Time.timeToTimeOfDay $ Time.utctDayTime d of
  64                  Time.TimeOfDay h m s -> (h, m, s)
  65         -- date_day = Time.utctDay
  66         utcOf = id
  67         dateOf 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         epoch{ Time.utctDay =
  77                 Time.addGregorianYearsClip
  78                  (yearOf 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 <- now
  85         r  <- m
  86         t1 <- now
  87         return (r, Time.diffUTCTime t1 t0)