summaryrefslogtreecommitdiffstats
path: root/lib/Phi/Widgets/Clock.hs
blob: 26b777fc159607c31f23709bcc846f33002dcbab (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
{-# 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