lib/Hcompta/Date.hs

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