phi/lib/Phi/Widgets/Clock.hs

{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}

module Phi.Widgets.Clock ( ClockConfig(..)
                         , defaultClockConfig
                         , clock
                         ) where

import Control.Concurrent
import Control.Monad

import Data.Typeable
import Data.Time.LocalTime
import Data.Time.Format

import Graphics.Rendering.Cairo

import Graphics.Rendering.Pango.Cairo
import Graphics.Rendering.Pango.Enums (PangoRectangle(..))
import Graphics.Rendering.Pango.Layout

import System.Locale

import Phi.Phi
import Phi.Types
import Phi.Widget


data ClockConfig = ClockConfig { clockFormat :: !String
                               , fontColor   :: !Color
                               , lineSpacing :: !Double
                               , clockSize   :: !Int
                               } deriving Show

defaultClockConfig :: ClockConfig
defaultClockConfig = ClockConfig "%R" (0, 0, 0, 1) 0 50

data Clock = Clock ClockConfig deriving Show

data ClockState = ClockState ZonedTime deriving Show

data ClockMessage = UpdateTime ZonedTime deriving (Show, Typeable)

instance WidgetClass Clock where
  type WidgetData Clock = ClockState
  
  initWidget (Clock _) phi _ = do
    forkIO $ forever $ do
      time <- getZonedTime
      sendMessage phi $ UpdateTime time
      sendMessage phi Repaint
      
      threadDelay $ ceiling $ 1000000*(max 1 $ 60 - (todSec . localTimeOfDay . zonedTimeToLocalTime $ time))
    
    time <- getZonedTime
    return $ ClockState time

    
  minSize (Clock config ) = clockSize config
  
  render (Clock config) (ClockState time) w h _ = do
    time <- liftIO getZonedTime
    let (r, g, b, a) = fontColor config
        str = formatTime defaultTimeLocale (clockFormat config) time
    setSourceRGBA r g b a
    
    layout <- createLayout ""
    (_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do
      layoutSetMarkup layout str
      layoutSetAlignment layout AlignCenter
      layoutSetSpacing layout $ lineSpacing config
      layoutGetExtents layout
    
    let scalef = min 1 ((fromIntegral w)/textWidth)
    when (scalef < 1) $ do
      scale scalef scalef
      updateLayout layout
    
    (_, PangoRectangle _ _ textWidth' textHeight') <- liftIO $ layoutGetExtents layout
    
    moveTo (((fromIntegral w)/scalef - textWidth')/2) (((fromIntegral h)/scalef - textHeight')/2)
    showLayout layout
  
  handleMessage _ priv m = case (fromMessage m) of
    Just (UpdateTime time) -> ClockState time
    _ -> priv


clock :: ClockConfig -> Widget
clock config = do
  Widget $ Clock config