phi/lib/Phi/Widgets/Clock.hs

{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances, StandaloneDeriving #-}

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, Eq)

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

data Clock d = Clock !ClockConfig deriving (Show, Eq)

deriving instance Eq ZonedTime

data ClockState = ClockState !ZonedTime deriving (Show, Eq)

data ClockMessage = UpdateTime !ZonedTime deriving (Show, Typeable)

instance Display d => Widget (Clock d) ClockState (RenderCache ClockState) d where
  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
  
  initCache (Clock config) = createRenderCache $ \(ClockState time) _ _ w h _ -> do
    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
    
  minSize (Clock config) _ _ _ = clockSize config
  
  render _ = renderCached
  
  handleMessage _ priv m = case (fromMessage m) of
    Just (UpdateTime time) -> ClockState time
    _ -> priv


clock :: ClockConfig -> Clock d
clock config = do
  Clock config