SimpleClock.hs

{-# LANGUAGE OverloadedStrings #-}

-- | Text clock widget with optional popup calendar.
module System.Taffybar.Widget.SimpleClock
  ( textClockNew,
    textClockNewWith,
    defaultClockConfig,
    ClockConfig (..),
    ClockUpdateStrategy (..),
  )
where

import Control.Monad.IO.Class
import Data.Default (Default (..))
import Data.Maybe
import qualified Data.Text as T
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 qualified GI.Gdk as Gdk
import GI.Gtk
import System.Taffybar.Util (VariableDelayConfig, defaultVariableDelayConfig)
import System.Taffybar.Widget.Generic.PollingLabel
import System.Taffybar.Widget.Util

-- | This module implements a very simple text-based clock widget. The widget
-- also toggles a calendar widget when clicked. This calendar is not fancy at
-- all and has no data backend.
makeCalendar :: IO TimeZone -> IO Window
makeCalendar tzfn = do
  container <- windowNew WindowTypeToplevel
  cal <- calendarNew
  containerAdd container cal
  _ <- onWidgetShow container $ resetCalendarDate cal tzfn
  -- Hide the calendar instead of destroying it
  _ <- 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

-- | Create the widget. I recommend passing @Nothing@ for the TimeLocale
-- parameter. The format string can include Pango markup
-- (<http://developer.gnome.org/pango/stable/PangoMarkupFormat.html>).
textClockNew ::
  (MonadIO m) => Maybe L.TimeLocale -> String -> Double -> m GI.Gtk.Widget
textClockNew userLocale format interval =
  textClockNewWith cfg
  where
    cfg =
      def
        { clockTimeLocale = userLocale,
          clockFormatString = format,
          clockUpdateStrategy = ConstantInterval interval
        }

-- | Strategy for scheduling clock updates.
data ClockUpdateStrategy
  = -- | Re-render at a fixed interval in seconds.
    ConstantInterval Double
  | -- | Re-render near rounded time boundaries.
    -- The first argument is the rounding step in seconds and the second is an
    -- offset in seconds.
    RoundedTargetInterval Int Double
  deriving (Eq, Ord, Show)

-- | Configuration for 'textClockNewWith'.
data ClockConfig = ClockConfig
  { clockTimeZone :: Maybe TimeZone,
    clockTimeLocale :: Maybe L.TimeLocale,
    clockFormatString :: String,
    clockUpdateStrategy :: ClockUpdateStrategy,
    clockVariableDelayConfig :: VariableDelayConfig Double
  }
  deriving (Eq, Ord, Show)

-- | A clock configuration that defaults to the current locale
defaultClockConfig :: ClockConfig
defaultClockConfig =
  ClockConfig
    { clockTimeZone = Nothing,
      clockTimeLocale = Nothing,
      clockFormatString = "%a %b %_d %r",
      clockUpdateStrategy = RoundedTargetInterval 5 0.0,
      clockVariableDelayConfig = defaultVariableDelayConfig
    }

instance Default ClockConfig where
  def = defaultClockConfig

-- | A configurable text-based clock widget.  It currently allows for
-- a configurable time zone through the 'ClockConfig'.
--
-- See also 'textClockNew'.
textClockNewWith :: (MonadIO m) => ClockConfig -> m Widget
textClockNewWith
  ClockConfig
    { clockTimeZone = userZone,
      clockTimeLocale = userLocale,
      clockFormatString = formatString,
      clockUpdateStrategy = updateStrategy,
      clockVariableDelayConfig = variableDelayConfig
    } = liftIO $ do
    let getTZ = maybe getCurrentTimeZone return userZone
        locale = fromMaybe L.defaultTimeLocale userLocale

    let getUserZonedTime =
          utcToZonedTime <$> getTZ <*> Clock.getCurrentTime

        doTimeFormat zonedTime = T.pack $ formatTime locale formatString zonedTime

        getRoundedTimeAndNextTarget = do
          zonedTime <- getUserZonedTime
          return $ case updateStrategy of
            ConstantInterval interval ->
              (doTimeFormat zonedTime, Nothing, interval)
            RoundedTargetInterval roundSeconds offset ->
              let roundSecondsDiffTime = fromIntegral roundSeconds
                  addTheRound = addLocalTime roundSecondsDiffTime
                  localTime = zonedTimeToLocalTime zonedTime
                  ourLocalTimeOfDay = localTimeOfDay localTime
                  seconds = round $ todSec ourLocalTimeOfDay
                  secondsFactor = seconds `div` roundSeconds
                  displaySeconds = secondsFactor * roundSeconds
                  baseLocalTimeOfDay =
                    ourLocalTimeOfDay {todSec = fromIntegral displaySeconds}
                  ourLocalTime =
                    localTime {localTimeOfDay = baseLocalTimeOfDay}
                  roundedLocalTime =
                    if seconds `mod` roundSeconds > roundSeconds `div` 2
                      then addTheRound ourLocalTime
                      else ourLocalTime
                  roundedZonedTime =
                    zonedTime {zonedTimeToLocalTime = roundedLocalTime}
                  nextTarget = addTheRound ourLocalTime
                  amountToWait = realToFrac $ diffLocalTime nextTarget localTime
               in (doTimeFormat roundedZonedTime, Nothing, amountToWait - offset)

    let pollingConfig =
          defaultPollingLabelConfig
            { pollingLabelVariableDelayConfig = variableDelayConfig
            }
    label <- pollingLabelWithVariableDelayWithConfig pollingConfig getRoundedTimeAndNextTarget
    _ <- widgetSetClassGI label "text-clock-label"
    ebox <- eventBoxNew
    _ <- widgetSetClassGI ebox "text-clock"
    containerAdd ebox label
    eventBoxSetVisibleWindow ebox False
    cal <- makeCalendar getTZ
    _ <-
      onWidgetButtonPressEvent ebox $
        onClick [Gdk.EventTypeButtonPress] $
          toggleCalendar label cal
    widgetShowAll ebox
    toWidget ebox