{-# LINE 1 "Data/Text/ICU/Calendar.hsc" #-}
{-# LANGUAGE RankNTypes, BangPatterns, ForeignFunctionInterface, RecordWildCards #-}
module Data.Text.ICU.Calendar
(
Calendar(..), CalendarType(..), SystemTimeZoneType(..), CalendarField(..), UCalendar,
roll, add, set1, set, get,
era, year, month,
dayOfMonth, dayOfYear, dayOfWeek, dayOfWeekInMonth, amPm,
hour, hourOfDay, minute, second, millisecond, zoneOffset, dstOffset, yearWoY, doWLocal, extendedYear, julianDay,
millisecondsInDay, isLeapMonth, day, utcTime,
setEra, setYear, setMonth,
setDayOfMonth, setDayOfYear, setDayOfWeek, setDayOfWeekInMonth, setAmPm,
setHour, setHourOfDay, setMinute, setSecond, setMillisecond, setZoneOffset, setDstOffset, setYearWoY, setDoWLocal, setExtendedYear, setJulianDay,
setMillisecondsInDay, setDay,
_era, _year, _month,
_dayOfMonth, _dayOfYear, _dayOfWeek, _dayOfWeekInMonth, _amPm,
_hour, _hourOfDay, _minute, _second, _millisecond, _zoneOffset, _dstOffset, _day,
timeZoneIDs, timeZones,
calendar, openTimeZoneIDEnumeration, openTimeZones, getField, setField, setDate, setDateTime, rollField, addField, setTimeZone,
) where
import Control.Monad (forM_)
import Data.Int (Int32)
import Data.Text (Text, pack)
import Data.Text.Foreign (withCStringLen)
import Data.Text.ICU.Enumerator
import Data.Text.ICU.Error.Internal (UErrorCode, handleError)
import Data.Text.ICU.Internal (LocaleName(..), UChar, withLocaleName, newICUPtr, useAsUCharPtr)
import qualified Data.Time.Calendar as Cal
import qualified Data.Time.Clock as Clock
import Foreign.C.String (CString)
import Foreign.C.Types (CInt(..))
import Foreign.ForeignPtr (withForeignPtr, ForeignPtr)
import Foreign.Ptr (FunPtr, Ptr)
import Prelude hiding (last)
import System.IO.Unsafe (unsafePerformIO)
type UCalendar = CInt
data Calendar = Calendar {calendarForeignPtr :: ForeignPtr UCalendar}
data CalendarField =
Era
| Year
| Month
| WeekOfYear
| WeekOfMonth
| DayOfMonth
| DayOfYear
| DayOfWeek
| DayOfWeekInMonth
| AmPm
| Hour
| HourOfDay
| Minute
| Second
| Millisecond
| ZoneOffset
| DstOffset
| YearWoY
| DoWLocal
| ExtendedYear
| JulianDay
| MillisecondsInDay
| IsLeapMonth
deriving (Show, Read, Eq)
type UCalendarDateFields = CInt
toUCalendarDateFields :: CalendarField -> UCalendarDateFields
toUCalendarDateFields Era = 0
{-# LINE 95 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields Year = 1
{-# LINE 96 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields Month = 2
{-# LINE 97 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields WeekOfYear = 3
{-# LINE 98 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields WeekOfMonth = 4
{-# LINE 99 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields DayOfMonth = 5
{-# LINE 100 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields DayOfYear = 6
{-# LINE 101 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields DayOfWeek = 7
{-# LINE 102 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields DayOfWeekInMonth = 8
{-# LINE 103 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields AmPm = 9
{-# LINE 104 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields Hour = 10
{-# LINE 105 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields HourOfDay = 11
{-# LINE 106 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields Minute = 12
{-# LINE 107 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields Second = 13
{-# LINE 108 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields Millisecond = 14
{-# LINE 109 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields ZoneOffset = 15
{-# LINE 110 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields DstOffset = 16
{-# LINE 111 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields YearWoY = 17
{-# LINE 112 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields DoWLocal = 18
{-# LINE 113 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields ExtendedYear = 19
{-# LINE 114 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields JulianDay = 20
{-# LINE 115 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields MillisecondsInDay = 21
{-# LINE 116 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarDateFields IsLeapMonth = 22
{-# LINE 117 "Data/Text/ICU/Calendar.hsc" #-}
data CalendarType = TraditionalCalendarType | DefaultCalendarType | GregorianCalendarType
deriving (Show, Read, Eq)
type UCalendarType = CInt
toUCalendarType :: CalendarType -> UCalendarType
toUCalendarType TraditionalCalendarType = 0
{-# LINE 125 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarType DefaultCalendarType = 0
{-# LINE 126 "Data/Text/ICU/Calendar.hsc" #-}
toUCalendarType GregorianCalendarType = 1
{-# LINE 127 "Data/Text/ICU/Calendar.hsc" #-}
data SystemTimeZoneType = AnyTimeZone | CanonicalTimeZone | CanonicalLocationTimeZone
deriving (Show, Read, Eq)
toUSystemTimeZoneType :: SystemTimeZoneType -> USystemTimeZoneType
toUSystemTimeZoneType AnyTimeZone = 0
{-# LINE 133 "Data/Text/ICU/Calendar.hsc" #-}
toUSystemTimeZoneType CanonicalTimeZone = 1
{-# LINE 134 "Data/Text/ICU/Calendar.hsc" #-}
toUSystemTimeZoneType CanonicalLocationTimeZone = 2
{-# LINE 135 "Data/Text/ICU/Calendar.hsc" #-}
type USystemTimeZoneType = CInt
calendar :: Text -> LocaleName -> CalendarType -> IO Calendar
calendar zoneId loc typ =
withLocaleName loc $ \locale ->
useAsUCharPtr zoneId $ \zoneIdPtr zoneIdLen ->
newICUPtr Calendar ucal_close $
handleError $ ucal_open zoneIdPtr (fromIntegral zoneIdLen) locale (toUCalendarType typ)
setTimeZone :: Calendar -> Text -> IO ()
setTimeZone cal zoneId =
withForeignPtr (calendarForeignPtr cal) $ \calPtr -> do
withCStringLen zoneId $ \(zoneIdPtr, zoneIdLen) -> do
handleError $ ucal_setTimeZone calPtr zoneIdPtr (fromIntegral zoneIdLen)
clone :: Calendar -> IO Calendar
clone cal =
withForeignPtr (calendarForeignPtr cal) $ \calPtr -> do
newICUPtr Calendar ucal_close $ handleError $ ucal_clone calPtr
timeZones :: IO [Text]
timeZones = do
tzEnum <- openTimeZones
tzs <- toList tzEnum
pure tzs
timeZoneIDs :: SystemTimeZoneType -> IO [Text]
timeZoneIDs typ = do
tzEnum <- openTimeZoneIDEnumeration typ
tzs <- toList tzEnum
pure tzs
openTimeZoneIDEnumeration :: SystemTimeZoneType -> IO Enumerator
openTimeZoneIDEnumeration typ = createEnumerator $
handleError $ ucal_openTimeZoneIDEnumeration (toUSystemTimeZoneType typ)
openTimeZones :: IO Enumerator
openTimeZones = createEnumerator $ handleError $ ucal_openTimeZones
getField :: Calendar -> CalendarField -> IO Int
getField cal fld = withForeignPtr (calendarForeignPtr cal) $ \calPtr -> do
n <- handleError $ ucal_get calPtr (toUCalendarDateFields fld)
pure (fromIntegral n)
setField :: Calendar -> CalendarField -> Int -> IO ()
setField cal fld n = withForeignPtr (calendarForeignPtr cal) $ \calPtr ->
ucal_set calPtr (toUCalendarDateFields fld) (fromIntegral n)
setDate :: Calendar -> Int -> Int -> Int -> IO ()
setDate cal y m d = withForeignPtr (calendarForeignPtr cal) $ \calPtr ->
handleError $ ucal_setDate calPtr (fromIntegral y) (fromIntegral m) (fromIntegral d)
setDateTime :: Calendar -> Int -> Int -> Int -> Int -> Int -> Int -> IO ()
setDateTime cal y m d hr mn sec = withForeignPtr (calendarForeignPtr cal) $ \calPtr ->
handleError $ ucal_setDateTime calPtr (fromIntegral y) (fromIntegral m) (fromIntegral d) (fromIntegral hr) (fromIntegral mn) (fromIntegral sec)
rollField :: Calendar -> CalendarField -> Int -> IO ()
rollField cal fld n = withForeignPtr (calendarForeignPtr cal) $ \calPtr ->
handleError $ ucal_roll calPtr (toUCalendarDateFields fld) (fromIntegral n)
roll ::
Calendar
-> [(CalendarField, Int)]
-> Calendar
roll cal lst = unsafePerformIO $ do
cal' <- clone cal
forM_ lst (\(fld,n) -> rollField cal' fld n)
pure cal'
addField :: Calendar -> CalendarField -> Int -> IO ()
addField cal fld n = withForeignPtr (calendarForeignPtr cal) $ \calPtr ->
handleError $ ucal_add calPtr (toUCalendarDateFields fld) (fromIntegral n)
add ::
Calendar
-> [(CalendarField, Int)]
-> Calendar
add cal lst = unsafePerformIO $ do
cal' <- clone cal
forM_ lst (\(fld,n) -> addField cal' fld n)
pure cal'
set1 :: Calendar -> CalendarField -> Int -> Calendar
set1 cal fld n = unsafePerformIO $ do
cal' <- clone cal
setField cal' fld n
pure cal'
set :: Calendar -> [(CalendarField, Int)] -> Calendar
set cal lst = unsafePerformIO $ do
cal' <- clone cal
forM_ lst (\(fld,n) -> setField cal' fld n)
pure cal'
day :: Calendar -> Cal.Day
day cal = unsafePerformIO $ do
y <- getField cal Year
m <- getField cal Month
d <- getField cal DayOfMonth
pure (Cal.fromGregorian (fromIntegral y) (m+1) d)
setDay :: Calendar -> Cal.Day -> Calendar
setDay cal aDay = unsafePerformIO $ do
cal' <- clone cal
let (y,m,d) = Cal.toGregorian aDay
setDate cal' (fromIntegral y) (m-1) d
pure cal'
utcTime :: Calendar -> Clock.UTCTime
utcTime cal = unsafePerformIO $ do
cal' <- clone cal
setTimeZone cal' (pack "UTC")
y <- getField cal' Year
m <- getField cal' Month
d <- getField cal' DayOfMonth
let day' = Cal.fromGregorian (fromIntegral y) (m+1) d
ms <- getField cal' MillisecondsInDay
let dt = realToFrac ((fromIntegral ms :: Double) / 1000)
pure $ Clock.UTCTime day' dt
get :: Calendar -> CalendarField -> Int
get cal fld = unsafePerformIO $ getField cal fld
era :: Calendar -> Int
era cal = unsafePerformIO $ getField cal Era
setEra :: Calendar -> Int -> Calendar
setEra cal = set1 cal Era
year :: Calendar -> Int
year cal = unsafePerformIO $ getField cal Year
setYear :: Calendar -> Int -> Calendar
setYear cal = set1 cal Year
month :: Calendar -> Int
month cal = unsafePerformIO $ getField cal Month
setMonth :: Calendar -> Int -> Calendar
setMonth cal = set1 cal Month
dayOfMonth :: Calendar -> Int
dayOfMonth cal = unsafePerformIO $ getField cal DayOfMonth
setDayOfMonth :: Calendar -> Int -> Calendar
setDayOfMonth cal = set1 cal DayOfMonth
dayOfYear :: Calendar -> Int
dayOfYear cal = unsafePerformIO $ getField cal DayOfYear
setDayOfYear :: Calendar -> Int -> Calendar
setDayOfYear cal = set1 cal DayOfYear
dayOfWeek :: Calendar -> Int
dayOfWeek cal = unsafePerformIO $ getField cal DayOfWeek
setDayOfWeek :: Calendar -> Int -> Calendar
setDayOfWeek cal = set1 cal DayOfWeek
dayOfWeekInMonth :: Calendar -> Int
dayOfWeekInMonth cal = unsafePerformIO $ getField cal DayOfWeekInMonth
setDayOfWeekInMonth :: Calendar -> Int -> Calendar
setDayOfWeekInMonth cal = set1 cal DayOfWeekInMonth
amPm :: Calendar -> Int
amPm cal = unsafePerformIO $ getField cal AmPm
setAmPm :: Calendar -> Int -> Calendar
setAmPm cal = set1 cal AmPm
hour :: Calendar -> Int
hour cal = unsafePerformIO $ getField cal Hour
setHour :: Calendar -> Int -> Calendar
setHour cal = set1 cal Hour
hourOfDay :: Calendar -> Int
hourOfDay cal = unsafePerformIO $ getField cal HourOfDay
setHourOfDay :: Calendar -> Int -> Calendar
setHourOfDay cal = set1 cal HourOfDay
minute :: Calendar -> Int
minute cal = unsafePerformIO $ getField cal Minute
setMinute :: Calendar -> Int -> Calendar
setMinute cal = set1 cal Minute
second :: Calendar -> Int
second cal = unsafePerformIO $ getField cal Second
setSecond :: Calendar -> Int -> Calendar
setSecond cal = set1 cal Second
millisecond :: Calendar -> Int
millisecond cal = unsafePerformIO $ getField cal Millisecond
setMillisecond :: Calendar -> Int -> Calendar
setMillisecond cal = set1 cal Millisecond
zoneOffset :: Calendar -> Int
zoneOffset cal = unsafePerformIO $ getField cal ZoneOffset
setZoneOffset :: Calendar -> Int -> Calendar
setZoneOffset cal = set1 cal ZoneOffset
dstOffset :: Calendar -> Int
dstOffset cal = unsafePerformIO $ getField cal DstOffset
setDstOffset :: Calendar -> Int -> Calendar
setDstOffset cal = set1 cal DstOffset
yearWoY :: Calendar -> Int
yearWoY cal = unsafePerformIO $ getField cal YearWoY
setYearWoY :: Calendar -> Int -> Calendar
setYearWoY cal = set1 cal YearWoY
doWLocal :: Calendar -> Int
doWLocal cal = unsafePerformIO $ getField cal DoWLocal
setDoWLocal :: Calendar -> Int -> Calendar
setDoWLocal cal = set1 cal DoWLocal
extendedYear :: Calendar -> Int
extendedYear cal = unsafePerformIO $ getField cal ExtendedYear
setExtendedYear :: Calendar -> Int -> Calendar
setExtendedYear cal = set1 cal ExtendedYear
julianDay :: Calendar -> Int
julianDay cal = unsafePerformIO $ getField cal JulianDay
setJulianDay :: Calendar -> Int -> Calendar
setJulianDay cal = set1 cal JulianDay
millisecondsInDay :: Calendar -> Int
millisecondsInDay cal = unsafePerformIO $ getField cal MillisecondsInDay
setMillisecondsInDay :: Calendar -> Int -> Calendar
setMillisecondsInDay cal = set1 cal MillisecondsInDay
isLeapMonth :: Calendar -> Bool
isLeapMonth cal = 0 /= (unsafePerformIO $ getField cal IsLeapMonth)
type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
type Lens' s a = Lens s s a a
lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
lens sa sbt afb s = sbt s <$> afb (sa s)
{-# INLINE lens #-}
_era :: Lens' Calendar Int
_era = lens era setEra
_year :: Lens' Calendar Int
_year = lens year setYear
_month :: Lens' Calendar Int
_month = lens month setMonth
_dayOfYear :: Lens' Calendar Int
_dayOfYear = lens dayOfYear setDayOfYear
_dayOfMonth :: Lens' Calendar Int
_dayOfMonth = lens dayOfMonth setDayOfMonth
_dayOfWeek :: Lens' Calendar Int
_dayOfWeek = lens dayOfWeek setDayOfWeek
_dayOfWeekInMonth :: Lens' Calendar Int
_dayOfWeekInMonth = lens dayOfWeekInMonth setDayOfWeekInMonth
_amPm :: Lens' Calendar Int
_amPm = lens amPm setAmPm
_hour :: Lens' Calendar Int
_hour = lens hour setHour
_hourOfDay :: Lens' Calendar Int
_hourOfDay = lens hour setHourOfDay
_minute :: Lens' Calendar Int
_minute = lens minute setMinute
_second :: Lens' Calendar Int
_second = lens second setSecond
_millisecond :: Lens' Calendar Int
_millisecond = lens millisecond setMillisecond
_zoneOffset :: Lens' Calendar Int
_zoneOffset = lens zoneOffset setZoneOffset
_dstOffset :: Lens' Calendar Int
_dstOffset = lens dstOffset setDstOffset
_day :: Lens' Calendar Cal.Day
_day = lens day setDay
instance Show Calendar where
show cal = show (utcTime cal)
foreign import ccall unsafe "hs_text_icu.h __hs_ucal_open" ucal_open
:: Ptr UChar -> Int32 -> CString -> UCalendar -> Ptr UErrorCode
-> IO (Ptr UCalendar)
foreign import ccall unsafe "hs_text_icu.h __hs_ucal_clone" ucal_clone
:: Ptr UCalendar -> Ptr UErrorCode
-> IO (Ptr UCalendar)
foreign import ccall unsafe "hs_text_icu.h &__hs_ucal_close" ucal_close
:: FunPtr (Ptr UCalendar -> IO ())
foreign import ccall unsafe "hs_text_icu.h __hs_ucal_get" ucal_get
:: Ptr UCalendar -> UCalendarDateFields -> Ptr UErrorCode
-> IO Int32
foreign import ccall unsafe "hs_text_icu.h __hs_ucal_set" ucal_set
:: Ptr UCalendar -> UCalendarDateFields -> Int32
-> IO ()
foreign import ccall unsafe "hs_text_icu.h __hs_ucal_setDate" ucal_setDate
:: Ptr UCalendar -> Int32 -> Int32 -> Int32
-> Ptr UErrorCode -> IO ()
foreign import ccall unsafe "hs_text_icu.h __hs_ucal_setDateTime" ucal_setDateTime
:: Ptr UCalendar -> Int32 -> Int32 -> Int32 -> Int32 -> Int32 -> Int32
-> Ptr UErrorCode -> IO ()
foreign import ccall unsafe "hs_text_icu.h __hs_ucal_add" ucal_add
:: Ptr UCalendar -> UCalendarDateFields -> Int32 -> Ptr UErrorCode
-> IO ()
foreign import ccall unsafe "hs_text_icu.h __hs_ucal_roll" ucal_roll
:: Ptr UCalendar -> UCalendarDateFields -> Int32 -> Ptr UErrorCode
-> IO ()
foreign import ccall unsafe "hs_text_icu.h _hs__ucal_openTimeZoneIDEnumeration" ucal_openTimeZoneIDEnumeration
:: USystemTimeZoneType -> Ptr UErrorCode
-> IO (Ptr UEnumerator)
foreign import ccall unsafe "hs_text_icu.h __hs_ucal_openTimeZones" ucal_openTimeZones
:: Ptr UErrorCode
-> IO (Ptr UEnumerator)
foreign import ccall unsafe "hs_text_icu.h __hs_ucal_setTimeZone" ucal_setTimeZone
:: Ptr UCalendar -> CString -> Int32 -> Ptr UErrorCode
-> IO ()