--------------------------------------------------------------- -- Copyright (c) 2014, Enzo Haussecker. All rights reserved. -- --------------------------------------------------------------- {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS -Wall #-} -- | Basic definitions, including type classes, datatypes and functions. module Data.Time.Exts.Base ( -- ** Classes Date(..) , DateTime(..) , DateZone(..) , DateTimeZone(..) , DateTimeMath(..) , Duration(..) , Zone(..) -- ** Structs , DateStruct(..) , DateTimeStruct(..) , DateZoneStruct(..) , DateTimeZoneStruct(..) -- ** Components , Year(..) , Month(..) , Day(..) , DayOfWeek(..) , Hour(..) , Minute(..) , Second(..) , Millis(..) , Micros(..) , Nanos(..) , Picos(..) -- ** Fractions , properFracMillis , properFracMicros , properFracNanos , properFracPicos -- ** Durations , epochToDate , epochToTime -- ** Utilities , isLeapYear , showPeriod , showSuffix ) where import Control.Arrow (first) import Data.Aeson (FromJSON, ToJSON) import Data.Int (Int32, Int64) import Data.Time.Exts.Zone (TimeZone) import Data.Typeable (Typeable) import GHC.Generics (Generic) import Text.Printf (PrintfArg) import System.Random (Random(..)) class Date d where -- | Compose a timestamp from date components. fromDateStruct :: DateStruct -> d -- | Decompose a timestamp into date components. toDateStruct :: d -> DateStruct class Date dt => DateTime dt where -- | Compose a timestamp from date and time components. fromDateTimeStruct :: DateTimeStruct -> dt -- | Decompose a timestamp into date and time components. toDateTimeStruct :: dt -> DateTimeStruct class DateZone dz where -- | Compose a timestamp from date and time zone components. fromDateZoneStruct :: DateZoneStruct -> dz -- | Decompose a timestamp into date and time zone components. toDateZoneStruct :: dz -> DateZoneStruct class DateZone dtz => DateTimeZone dtz where -- | Compose a timestamp from date, time and time zone components. fromDateTimeZoneStruct :: DateTimeZoneStruct -> dtz -- | Decompose a timestamp into date, time and time zone components. toDateTimeZoneStruct :: dtz -> DateTimeZoneStruct class Duration x c where -- | Compute the date or time component duration between two timestamps. duration :: x -> x -> c class DateTimeMath x c where -- | Add a timestamp with a date or time component. plus :: x -> c -> x class Zone x where -- | Change the time zone of a timestamp. rezone :: x -> TimeZone -> x -- | A struct with date components. data DateStruct = DateStruct { _d_year :: {-# UNPACK #-} !Year , _d_mon :: !Month , _d_mday :: {-# UNPACK #-} !Day , _d_wday :: !DayOfWeek } deriving (Eq,Generic,Ord,Show,Typeable) -- | A struct with date and time components. data DateTimeStruct = DateTimeStruct { _dt_year :: {-# UNPACK #-} !Year , _dt_mon :: !Month , _dt_mday :: {-# UNPACK #-} !Day , _dt_wday :: !DayOfWeek , _dt_hour :: {-# UNPACK #-} !Hour , _dt_min :: {-# UNPACK #-} !Minute , _dt_sec :: {-# UNPACK #-} !Double } deriving (Eq,Generic,Ord,Show,Typeable) -- | A struct with date and time zone components. data DateZoneStruct = DateZoneStruct { _dz_year :: {-# UNPACK #-} !Year , _dz_mon :: !Month , _dz_mday :: {-# UNPACK #-} !Day , _dz_wday :: !DayOfWeek , _dz_zone :: !TimeZone } deriving (Eq,Generic,Ord,Show,Typeable) -- | A struct with date, time and time zone components. data DateTimeZoneStruct = DateTimeZoneStruct { _dtz_year :: {-# UNPACK #-} !Year , _dtz_mon :: !Month , _dtz_mday :: {-# UNPACK #-} !Day , _dtz_wday :: !DayOfWeek , _dtz_hour :: {-# UNPACK #-} !Hour , _dtz_min :: {-# UNPACK #-} !Minute , _dtz_sec :: {-# UNPACK #-} !Double , _dtz_zone :: !TimeZone } deriving (Eq,Generic,Ord,Show,Typeable) -- | Year. newtype Year = Year {getYear :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) -- | Month. data Month = January | February | March | April | May | June | July | August | September | October | November | December deriving (Eq,Enum,Generic,Ord,Show,Typeable) -- | Day. newtype Day = Day {getDay :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) -- | Day of week. data DayOfWeek = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday deriving (Eq,Enum,Generic,Ord,Show,Typeable) -- | Hour. newtype Hour = Hour {getHour :: Int64} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) -- | Minute. newtype Minute = Minute {getMinute :: Int64} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) -- | Second. newtype Second = Second {getSecond :: Int64} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) -- | Millisecond. newtype Millis = Millis {getMillis :: Int64} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) -- | Microsecond. newtype Micros = Micros {getMicros :: Int64} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) -- | Nanosecond. newtype Nanos = Nanos {getNanos :: Int64} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) -- | Picosecond. newtype Picos = Picos {getPicos :: Int64} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) instance FromJSON DateStruct instance FromJSON DateTimeStruct instance FromJSON DateZoneStruct instance FromJSON DateTimeZoneStruct instance FromJSON DayOfWeek instance FromJSON Month instance Random Month where random = first toEnum . randomR (0, 11) randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) instance Random DayOfWeek where random = first toEnum . randomR (0, 6) randomR (a,b) = first toEnum . randomR (fromEnum a, fromEnum b) instance Show Year where show Year {getYear } = show getYear instance Show Day where show Day {getDay } = show getDay instance Show Hour where show Hour {getHour } = show getHour instance Show Minute where show Minute {getMinute} = show getMinute instance Show Second where show Second {getSecond} = show getSecond instance Show Millis where show Millis {getMillis} = show getMillis instance Show Micros where show Micros {getMicros} = show getMicros instance Show Nanos where show Nanos {getNanos } = show getNanos instance Show Picos where show Picos {getPicos } = show getPicos instance ToJSON DateStruct instance ToJSON DateTimeStruct instance ToJSON DateZoneStruct instance ToJSON DateTimeZoneStruct instance ToJSON DayOfWeek instance ToJSON Month -- | Decompose a floating point number into second and millisecond components. properFracMillis :: Floating a => RealFrac a => a -> (Second, Millis) properFracMillis millis = if res == 1000 then (sec + 1, 0) else result where result@(sec, res) = fmap (round . (*) 1000) $ properFraction millis -- | Decompose a floating point number into second and microsecond components. properFracMicros :: Floating a => RealFrac a => a -> (Second, Micros) properFracMicros micros = if res == 1000000 then (sec + 1, 0) else result where result@(sec, res) = fmap (round . (*) 1000000) $ properFraction micros -- | Decompose a floating point number into second and nanosecond components. properFracNanos :: Floating a => RealFrac a => a -> (Second, Nanos) properFracNanos nanos = if res == 1000000000 then (sec + 1, 0) else result where result@(sec, res) = fmap (round . (*) 1000000000) $ properFraction nanos -- | Decompose a floating point number into second and picosecond components. properFracPicos :: Floating a => RealFrac a => a -> (Second, Picos) properFracPicos picos = if res == 1000000000000 then (sec + 1, 0) else result where result@(sec, res) = fmap (round . (*) 1000000000000) $ properFraction picos -- | Calculate the number of days that have -- elapsed between Unix epoch and the given date. epochToDate :: Year -> Month -> Day -> Day epochToDate year month day = epochToYear year + yearToMonth month leap + day - 1 where leap = isLeapYear year -- | Calculate the number of days that have -- elapsed between Unix epoch and the given year. epochToYear :: Year -> Day epochToYear (Year year) = Day $ (year - 1970) * 365 + (year - 1969) `div` 004 - (year - 1901) `div` 100 + (year - 1601) `div` 400 -- | Calculate the number of days that have -- elapsed between January 1st and the given month. yearToMonth :: Month -> Bool -> Day yearToMonth month leap = if leap then case month of January -> 000; February -> 031; March -> 060; April -> 091 May -> 121; June -> 152; July -> 182; August -> 213 September -> 244; October -> 274; November -> 305; December -> 335 else case month of January -> 000; February -> 031; March -> 059; April -> 090 May -> 120; June -> 151; July -> 181; August -> 212 September -> 243; October -> 273; November -> 304; December -> 334 -- | Calculate the number of seconds (excluding leap seconds) -- that have elapsed between Unix epoch and the given time. epochToTime :: Year -> Month -> Day -> Hour -> Minute -> Second -> Second epochToTime year month day (Hour hour) (Minute minute) (Second second) = Second $ (days * 86400) + (hour * 3600) + (minute * 60) + second where days = fromIntegral $ epochToDate year month day -- | Check if the given year is a leap year. isLeapYear :: Year -> Bool isLeapYear year = year `mod` 400 == 0 || (year `mod` 100 /= 0 && year `mod` 4 == 0) -- | Show the pariod (ante or post meridiem) of the given hour. showPeriod :: Hour -> String showPeriod hour = if hour < 12 then "AM" else "PM" -- | Show the suffix of the given day of the month. showSuffix :: Day -> String showSuffix (Day day) = if day < 1 || 31 < day then error $ "showSuffix: unknown day of month" else case day `mod` 10 of 1 | day /= 11 -> "st" 2 | day /= 12 -> "nd" 3 | day /= 13 -> "rd" _ -> "th"