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 :: !Year
, _d_mon :: !Month
, _d_mday :: !Day
, _d_wday :: !DayOfWeek
} deriving (Eq,Generic,Ord,Show,Typeable)
data DateZoneStruct = DateZoneStruct {
_dz_year :: !Year
, _dz_mon :: !Month
, _dz_mday :: !Day
, _dz_wday :: !DayOfWeek
, _dz_zone :: !TimeZone
} deriving (Eq,Generic,Ord,Show,Typeable)
data DateTimeStruct = DateTimeStruct {
_dt_year :: !Year
, _dt_mon :: !Month
, _dt_mday :: !Day
, _dt_wday :: !DayOfWeek
, _dt_hour :: !Hour
, _dt_min :: !Minute
, _dt_sec :: !Double
} deriving (Eq,Generic,Ord,Show,Typeable)
data DateTimeZoneStruct = DateTimeZoneStruct {
_dtz_year :: !Year
, _dtz_mon :: !Month
, _dtz_mday :: !Day
, _dtz_wday :: !DayOfWeek
, _dtz_hour :: !Hour
, _dtz_min :: !Minute
, _dtz_sec :: !Double
, _dtz_zone :: !TimeZone
} 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
parens :: Num a => Ord a => Show a => a -> String
parens x = if x < 0 then '(' : show x ++ ")" else show x
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"
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
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"
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
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
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
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
epochToDate :: Year -> Month -> Day -> Day
epochToDate year mon mday =
epochToYear year + yearToMonth mon leap + mday 1
where leap = isLeapYear year
epochToYear :: Year -> Day
epochToYear Year{getYear} =
Day ((getYear 1970) * 365 + (getYear 1969) `div` 004
(getYear 1901) `div` 100 + (getYear 1601) `div` 400)
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"
dateToTime :: Hour -> Minute -> Second -> Second
dateToTime Hour{getHour} Minute{getMinute} sec =
Second ((getHour * 3600) + (getMinute * 60)) + sec
isLeapYear :: Year -> Bool
isLeapYear year = year `mod` 400 == 0 || (not (year `mod` 100 == 0) && year `mod` 4 == 0)