lib/Hcompta/Date.hs

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