78 lines
2.2 KiB
Haskell
78 lines
2.2 KiB
Haskell
|
{-# LANGUAGE DeriveDataTypeable, TypeFamilies #-}
|
||
|
|
|
||
|
|
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
|
||
|
|
|
||
|
|
instance WidgetClass Clock where
|
||
|
|
type WidgetData Clock = ()
|
||
|
|
|
||
|
|
initWidget (Clock _) phi _ = do
|
||
|
|
forkIO $ forever $ do
|
||
|
|
time <- getZonedTime
|
||
|
|
sendMessage phi Repaint
|
||
|
|
|
||
|
|
threadDelay $ ceiling $ 1000000*(max 1 $ 60 - (todSec . localTimeOfDay . zonedTimeToLocalTime $ time))
|
||
|
|
return ()
|
||
|
|
|
||
|
|
|
||
|
|
minSize (Clock config ) = clockSize config
|
||
|
|
|
||
|
|
render (Clock config) _ 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
|
||
|
|
|
||
|
|
clock :: ClockConfig -> Widget
|
||
|
|
clock config = do
|
||
|
|
Widget $ Clock config
|