--------------------------------------------------------------- -- Copyright (c) 2013, Enzo Haussecker. All rights reserved. -- --------------------------------------------------------------- {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS -Wall #-} {-# OPTIONS -fno-warn-name-shadowing #-} module Data.Time.Exts.Base ( Date(..) , Zone(..) , DateZone(..) , DateTime(..) , DateTimeZone(..) , DateTimeMath(..) , DateStruct(..) , DateZoneStruct(..) , DateTimeStruct(..) , DateTimeZoneStruct(..) , Year(..) , Month(..) , Day(..) , DayOfWeek(..) , Hour(..) , Minute(..) , Second(..) , Millis(..) , Micros(..) , Nanos(..) , Picos(..) , Pretty(..) , prettyMonth , prettyDay , prettyHour , properFracMillis , properFracMicros , properFracNanos , properFracPicos , epochToDate , epochToYear , yearToMonth , dateToTime , isLeapYear ) 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 toDateStruct :: d -> DateStruct fromDateStruct :: DateStruct -> d class Zone z where toZone :: z -> TimeZone -> z class DateZone dz where toDateZoneStruct :: dz -> DateZoneStruct fromDateZoneStruct :: DateZoneStruct -> dz class DateTime dt where toDateTimeStruct :: dt -> DateTimeStruct fromDateTimeStruct :: DateTimeStruct -> dt class DateTimeZone dtz where toDateTimeZoneStruct :: dtz -> DateTimeZoneStruct fromDateTimeZoneStruct :: DateTimeZoneStruct -> dtz class DateTimeMath a b where plus :: a -> b -> a class Pretty a where pretty :: a -> String data DateStruct = DateStruct { _d_year :: {-# UNPACK #-} !Year -- ^ year , _d_mon :: {-# UNPACK #-} !Month -- ^ month , _d_mday :: {-# UNPACK #-} !Day -- ^ day of month , _d_wday :: !DayOfWeek -- ^ day of week } deriving (Eq,Generic,Ord,Show,Typeable) data DateZoneStruct = DateZoneStruct { _dz_year :: {-# UNPACK #-} !Year -- ^ year , _dz_mon :: {-# UNPACK #-} !Month -- ^ month , _dz_mday :: {-# UNPACK #-} !Day -- ^ day of month , _dz_wday :: !DayOfWeek -- ^ day of week , _dz_zone :: !TimeZone -- ^ time zone } deriving (Eq,Generic,Ord,Show,Typeable) data DateTimeStruct = DateTimeStruct { _dt_year :: {-# UNPACK #-} !Year -- ^ year , _dt_mon :: {-# UNPACK #-} !Month -- ^ month , _dt_mday :: {-# UNPACK #-} !Day -- ^ day of month , _dt_wday :: !DayOfWeek -- ^ day of week , _dt_hour :: {-# UNPACK #-} !Hour -- ^ hour , _dt_min :: {-# UNPACK #-} !Minute -- ^ minute , _dt_sec :: {-# UNPACK #-} !Double -- ^ second } deriving (Eq,Generic,Ord,Show,Typeable) data DateTimeZoneStruct = DateTimeZoneStruct { _dtz_year :: {-# UNPACK #-} !Year -- ^ year , _dtz_mon :: {-# UNPACK #-} !Month -- ^ month , _dtz_mday :: {-# UNPACK #-} !Day -- ^ day of month , _dtz_wday :: !DayOfWeek -- ^ day of week , _dtz_hour :: {-# UNPACK #-} !Hour -- ^ hour , _dtz_min :: {-# UNPACK #-} !Minute -- ^ minute , _dtz_sec :: {-# UNPACK #-} !Double -- ^ second , _dtz_zone :: !TimeZone -- ^ time zone } deriving (Eq,Generic,Ord,Show,Typeable) newtype Year = Year {getYear :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) newtype Month = Month {getMonth :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) newtype Day = Day {getDay :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) newtype Hour = Hour {getHour :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) newtype Minute = Minute {getMinute :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) newtype Second = Second {getSecond :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) newtype Millis = Millis {getMillis :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) newtype Micros = Micros {getMicros :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) newtype Nanos = Nanos {getNanos :: Int32} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) newtype Picos = Picos {getPicos :: Int64} deriving (Bounded,Enum,Eq,FromJSON,Generic,Integral,Num,Ord,PrintfArg,Random,Real,ToJSON) data DayOfWeek = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday deriving (Eq,Enum,Generic,Ord,Show,Typeable) instance FromJSON DateStruct instance FromJSON DateZoneStruct instance FromJSON DateTimeStruct instance FromJSON DateTimeZoneStruct instance FromJSON DayOfWeek 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 } = "Year " ++ parens getYear instance Show Month where show Month {getMonth } = "Month " ++ parens getMonth instance Show Day where show Day {getDay } = "Day " ++ parens getDay instance Show Hour where show Hour {getHour } = "Hour " ++ parens getHour instance Show Minute where show Minute {getMinute} = "Minute " ++ parens getMinute instance Show Second where show Second {getSecond} = "Second " ++ parens getSecond instance Show Millis where show Millis {getMillis} = "Millis " ++ parens getMillis instance Show Micros where show Micros {getMicros} = "Micros " ++ parens getMicros instance Show Nanos where show Nanos {getNanos } = "Nanos " ++ parens getNanos instance Show Picos where show Picos {getPicos } = "Picos " ++ parens getPicos instance ToJSON DateStruct instance ToJSON DateZoneStruct instance ToJSON DateTimeStruct instance ToJSON DateTimeZoneStruct instance ToJSON DayOfWeek -- | Shows the given numeric value as a string. parens :: Num a => Ord a => Show a => a -> String parens x = if x < 0 then '(' : show x ++ ")" else show x -- | Shows the given month as a string. prettyMonth :: Month -> String prettyMonth = \ case 01 -> "January" 02 -> "February" 03 -> "March" 04 -> "April" 05 -> "May" 06 -> "June" 07 -> "July" 08 -> "August" 09 -> "September" 10 -> "October" 11 -> "November" 12 -> "December" _ -> error "prettyMonth: unknown month" -- | Shows the given day of the month as a string. prettyDay :: Day -> String prettyDay Day{getDay} = if getDay <= 0 || 32 <= getDay then error "prettyDay: unknown day" else case getDay `mod` 10 of 1 | getDay /= 11 -> str ++ "st" 2 | getDay /= 12 -> str ++ "nd" 3 | getDay /= 13 -> str ++ "rd" _ -> str ++ "th" where str = show getDay -- | Returns the given hour in AM-PM format. prettyHour :: Hour -> (Hour, String) prettyHour hour = if | hour < 00 -> error "prettyHour: unknown hour" | hour == 00 -> (12, "AM") | hour <= 11 -> (hour, "AM") | hour == 12 -> (hour, "PM") | hour <= 23 -> (hour - 12, "PM") | otherwise -> error "prettyHour: unknown hour" -- | Decomposes a floating point number into second and millisecond components. properFracMillis :: Floating a => RealFrac a => a -> (Second, Millis) properFracMillis millis = if rem == 1000 then (sec + 1, 0) else result where result@(sec, rem) = fmap (round . (*) 1000) $ properFraction millis -- | Decomposes a floating point number into second and microsecond components. properFracMicros :: Floating a => RealFrac a => a -> (Second, Micros) properFracMicros micros = if rem == 1000000 then (sec + 1, 0) else result where result@(sec, rem) = fmap (round . (*) 1000000) $ properFraction micros -- | Decomposes a floating point number into second and nanosecond components. properFracNanos :: Floating a => RealFrac a => a -> (Second, Nanos) properFracNanos nanos = if rem == 1000000000 then (sec + 1, 0) else result where result@(sec, rem) = fmap (round . (*) 1000000000) $ properFraction nanos -- | Decomposes a floating point number into second and picosecond components. properFracPicos :: Floating a => RealFrac a => a -> (Second, Picos) properFracPicos picos = if rem == 1000000000000 then (sec + 1, 0) else result where result@(sec, rem) = fmap (round . (*) 1000000000000) $ properFraction picos -- | Calculates the number of days that have -- elapsed between Unix epoch and the given date. epochToDate :: Year -> Month -> Day -> Day epochToDate year mon mday = epochToYear year + yearToMonth mon leap + mday - 1 where leap = isLeapYear year -- | Calculates the number of days that have -- elapsed between Unix epoch and the given year. epochToYear :: Year -> Day epochToYear Year{getYear} = Day ((getYear - 1970) * 365 + (getYear - 1969) `div` 004 - (getYear - 1901) `div` 100 + (getYear - 1601) `div` 400) -- | Calculates the number of days that have -- elapsed between January 1st and the given month. yearToMonth :: Month -> Bool -> Day yearToMonth mon leap = if leap then case mon of 01 -> 000; 02 -> 031; 03 -> 060; 04 -> 091 05 -> 121; 06 -> 152; 07 -> 182; 08 -> 213 09 -> 244; 10 -> 274; 11 -> 305; 12 -> 335 __ -> error "yearToMonth: month not supported" else case mon of 01 -> 000; 02 -> 031; 03 -> 059; 04 -> 090 05 -> 120; 06 -> 151; 07 -> 181; 08 -> 212 09 -> 243; 10 -> 273; 11 -> 304; 12 -> 334 __ -> error "yearToMonth: month not supported" -- | Calculates the number of seconds that have -- elapsed between midnight and the given time. dateToTime :: Hour -> Minute -> Second -> Second dateToTime Hour{getHour} Minute{getMinute} sec = Second ((getHour * 3600) + (getMinute * 60)) + sec -- | Checks if the given year is a leap year. isLeapYear :: Year -> Bool isLeapYear year = year `mod` 400 == 0 || (not (year `mod` 100 == 0) && year `mod` 4 == 0)