lib/Hcompta/Date.hs

   1 {-# LANGUAGE StandaloneDeriving #-}
   2 {-# LANGUAGE TypeSynonymInstances #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module Hcompta.Date where
   5
   6 import qualified Data.Fixed
   7 import qualified Data.Time.Calendar    as Time
   8 import qualified Data.Time.Clock       as Time
   9 import qualified Data.Time.Clock.POSIX as Time (posixSecondsToUTCTime)
  10 import qualified Data.Time.Format      as Time ()
  11 import qualified Data.Time.LocalTime   as Time
  12
  13 -- import qualified Hcompta.Lib.Interval.Sieve as Interval.Sieve
  14
  15 -- * Type 'Date'
  16
  17 type Date   = Time.UTCTime
  18 type Year   = Integer
  19 type Month  = Int
  20 type Day    = Time.Day
  21 type DoM    = Int
  22 type Hour   = Int
  23 type Minute = Int
  24 type Second = Data.Fixed.Pico
  25
  26 nil :: Date
  27 nil = Time.posixSecondsToUTCTime 0
  28
  29 now :: IO Date
  30 now = Time.getCurrentTime
  31
  32 date :: Year -> Month -> DoM -> Hour -> Minute -> Second -> Maybe Date
  33 date y m d h mn s = do
  34         gday <- Time.fromGregorianValid y m d
  35         hod <- Time.makeTimeOfDayValid h mn s
  36         return $
  37                 Time.UTCTime gday $
  38                         Time.timeOfDayToTime hod
  39
  40 -- ** Components
  41
  42 gregorian :: Date -> (Year, Month, DoM)
  43 gregorian = Time.toGregorian . Time.utctDay
  44
  45 year :: Date -> Year
  46 year = (\(x, _, _) -> x) . gregorian
  47
  48 month :: Date -> Month
  49 month = (\(_, x, _) -> x) . gregorian
  50
  51 day :: Date -> Day
  52 day = Time.utctDay
  53
  54 dom :: Date -> DoM
  55 dom = (\(_, _, x) -> x) . gregorian
  56
  57 tod :: Date -> Time.TimeOfDay
  58 tod = Time.timeToTimeOfDay . Time.utctDayTime
  59
  60 hour :: Date -> Hour
  61 hour = (\(Time.TimeOfDay x _ _) -> x) . tod
  62
  63 minute :: Date -> Minute
  64 minute = (\(Time.TimeOfDay _ x _) -> x) . tod
  65
  66 second :: Date -> Second
  67 second = (\(Time.TimeOfDay _ _ x) -> x) . tod
  68
  69 next_year_start :: Date -> Date
  70 next_year_start d =
  71         nil{ Time.utctDay =
  72                 Time.addGregorianYearsClip
  73                  (year d + 1 - 1970)
  74                  (Time.utctDay d)
  75          }
  76
  77 utc :: Date -> Time.UTCTime
  78 utc = id
  79
  80 bench :: IO a -> IO (a, Time.NominalDiffTime)
  81 bench m = do
  82         t0 <- now
  83         r  <- m
  84         t1 <- now
  85         return (r, Time.diffUTCTime t1 t0)
  86
  87 {-
  88 data Interval
  89  =   Interval_None
  90  |   Interval_Days Int
  91  |   Interval_Weeks Int
  92  |   Interval_Months Int
  93  |   Interval_Quarters Int
  94  |   Interval_Years Int
  95  |   Interval_DayOfMonth Int
  96  |   Interval_DayOfWeek Int
  97  -- Interval_WeekOfYear Int
  98  -- Interval_MonthOfYear Int
  99  -- Interval_QuarterOfYear Int
 100  deriving (Data, Eq, Ord, Read, Show, Typeable)
 101
 102
 103 type Smart
 104  = (String, String, String)
 105 data Which
 106  =   Which_Primary
 107  |   Which_Secondary
 108  deriving (Eq, Read, Show)
 109 -}