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
91
92
93
94
95
96
97
|
{-# LANGUAGE MultiParamTypeClasses, 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, Eq)
defaultClockConfig :: ClockConfig
defaultClockConfig = ClockConfig "%R" (0, 0, 0, 1) 0 50
data Clock = Clock !ClockConfig deriving (Show, Eq)
instance Eq ZonedTime where
(ZonedTime localTime timezone) == (ZonedTime localTime' timezone') = (localTime == localTime') && (timezone == timezone')
data ClockState = ClockState !ZonedTime deriving (Show, Eq)
data ClockMessage = UpdateTime !ZonedTime deriving (Show, Typeable)
instance Widget Clock ClockState () 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
minSize (Clock config) _ _ _ = clockSize config
render (Clock config) (ClockState time) _ _ w h _ = do
surface <- createImageSurface FormatARGB32 w h
renderWith surface $ do
setOperator OperatorClear
paint
setOperator OperatorOver
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
return [(True, SurfaceSlice 0 surface)]
handleMessage _ priv m = case (fromMessage m) of
Just (UpdateTime time) -> ClockState time
_ -> priv
clock :: ClockConfig -> Clock
clock config = do
Clock config
|
