{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
module System.Taffybar.Widget.SimpleClock
( textClockNew
, textClockNewWith
, defaultClockConfig
, ClockConfig(..)
) where
import Control.Monad.IO.Class
import Data.Time.Calendar ( toGregorian )
import qualified Data.Time.Clock as Clock
import Data.Time.Format
import Data.Time.LocalTime
import qualified Data.Time.Locale.Compat as L
import GI.Gtk
import qualified GI.Gdk as D
import System.Taffybar.Widget.Generic.PollingLabel
import System.Taffybar.Widget.Util
import qualified Data.Text as T
makeCalendar :: IO TimeZone -> IO Window
makeCalendar tzfn = do
container <- windowNew WindowTypeToplevel
cal <- calendarNew
containerAdd container cal
_ <- onWidgetShow container $ resetCalendarDate cal tzfn
_ <- onWidgetDeleteEvent container $ \_ -> widgetHide container >> return True
return container
resetCalendarDate :: Calendar -> IO TimeZone -> IO ()
resetCalendarDate cal tzfn = do
tz <- tzfn
current <- Clock.getCurrentTime
let (y,m,d) = toGregorian $ localDay $ utcToLocalTime tz current
calendarSelectMonth cal (fromIntegral m - 1) (fromIntegral y)
calendarSelectDay cal (fromIntegral d)
toggleCalendar :: IsWidget w => w -> Window -> IO Bool
toggleCalendar w c = do
isVis <- widgetGetVisible c
if isVis
then widgetHide c
else do
attachPopup w "Calendar" c
displayPopup w c
return True
textClockNew :: MonadIO m => Maybe L.TimeLocale -> String -> Double -> m GI.Gtk.Widget
textClockNew userLocale =
textClockNewWith cfg
where
cfg = defaultClockConfig { clockTimeLocale = userLocale }
data ClockConfig = ClockConfig { clockTimeZone :: Maybe TimeZone
, clockTimeLocale :: Maybe L.TimeLocale
}
deriving (Eq, Ord, Show)
defaultClockConfig :: ClockConfig
defaultClockConfig = ClockConfig Nothing Nothing
data TimeInfo = TimeInfo { getTZ :: IO TimeZone
, getLocale :: IO L.TimeLocale
}
systemGetTZ :: IO TimeZone
systemGetTZ = setTZ >> getCurrentTimeZone
setTZ :: IO ()
#if MIN_VERSION_time(1, 4, 2)
setTZ = return ()
#else
setTZ = c_tzset
foreign import ccall unsafe "time.h tzset"
c_tzset :: IO ()
#endif
textClockNewWith :: MonadIO m => ClockConfig -> String -> Double -> m Widget
textClockNewWith cfg fmt updateSeconds = liftIO $ do
let ti = TimeInfo { getTZ = maybe systemGetTZ return userZone
, getLocale = maybe (return L.defaultTimeLocale) return userLocale
}
l <- pollingLabelNew "" updateSeconds (getCurrentTime' ti fmt)
ebox <- eventBoxNew
containerAdd ebox l
eventBoxSetVisibleWindow ebox False
cal <- makeCalendar $ getTZ ti
_ <- onWidgetButtonPressEvent ebox $ onClick [D.EventTypeButtonPress] (toggleCalendar l cal)
widgetShowAll ebox
toWidget ebox
where
userZone = clockTimeZone cfg
userLocale = clockTimeLocale cfg
getCurrentTime' :: TimeInfo -> String -> IO T.Text
getCurrentTime' ti f = do
l <- getLocale ti
z <- getTZ ti
t <- Clock.getCurrentTime
return $ T.pack $ formatTime l f $ utcToZonedTime z t