lib/Hcompta/Date.hs

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