Added clock widget

1 files changed, 78 insertions, 0 deletions

diff --git a/lib/Phi/Widgets/Clock.hs b/lib/Phi/Widgets/Clock.hs
new file mode 100644
index 0000000..602a1fc
--- /dev/null
+++ b/lib/Phi/Widgets/Clock.hs
@@ -0,0 +1,78 @@
+{-# 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
\ No newline at end of file