90 lines
2.7 KiB
Haskell
90 lines
2.7 KiB
Haskell
{-# 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
|