Added clock widget

6 files changed, 173 insertions, 65 deletions

diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs
index 53f31a2..1994724 100644
--- a/lib/Phi/Border.hs
+++ b/lib/Phi/Border.hs
@@ -10,6 +10,8 @@ module Phi.Border ( BorderWidth(..)
 import Phi.Types
 import Phi.Widget
 
+import Control.Monad
+
 import Graphics.Rendering.Cairo
 
 
@@ -52,7 +54,7 @@ data Border = Border BorderConfig [Widget] deriving Show
 
 instance WidgetClass Border where
   type WidgetData Border = BorderState
-  initialState (Border _ widgets) = BorderState $ map createWidgetState widgets
+  initWidget (Border _ widgets) phi disp = liftM BorderState $ mapM (createWidgetState phi disp) widgets
   
   minSize (Border config widgets) = sum (map (\(Widget w) -> minSize w) widgets) + borderH p + 2*bw + borderH m
     where
@@ -74,7 +76,6 @@ instance WidgetClass Border where
       height' = height - borderV m - 2*bw - borderV p
 
   render (Border config _) (BorderState widgetStates) w h = do
-    save
     newPath
     arc (x + width - radius) (y + radius) radius (-pi/2) 0
     arc (x + width - radius) (y + height - radius) radius 0 (pi/2)
@@ -82,14 +83,16 @@ instance WidgetClass Border where
     arc (x + radius) (y + radius) radius  pi (pi*3/2)
     closePath
     
+    save
     setSourceRGBA fr fg fb fa
     fillPreserve
     
     setSourceRGBA br bg bb ba
     setLineWidth $ fromIntegral bw
-    stroke
+    strokePreserve
     restore
     
+    clip
     renderWidgets widgetStates
     
       where
@@ -105,6 +108,8 @@ instance WidgetClass Border where
         
         (br, bg, bb, ba) = borderColor config
         (fr, fg, fb, fa) = backgroundColor config
+  
+  handleMessage _ (BorderState widgetStates) m = BorderState $ handleMessageWidgets m widgetStates
     
 
 border :: BorderConfig -> [Widget] -> Widget
diff --git a/lib/Phi/Panel.hs b/lib/Phi/Panel.hs
index a31ffad..72f6954 100644
--- a/lib/Phi/Panel.hs
+++ b/lib/Phi/Panel.hs
@@ -12,4 +12,3 @@ data PanelConfig = PanelConfig { panelPosition :: Position
 
 defaultPanelConfig :: PanelConfig
 defaultPanelConfig = PanelConfig { panelPosition = Top, panelSize = 24 }
-
diff --git a/lib/Phi/Phi.hs b/lib/Phi/Phi.hs
index 5d14181..1fef39b 100644
--- a/lib/Phi/Phi.hs
+++ b/lib/Phi/Phi.hs
@@ -1,13 +1,11 @@
-{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable, StandaloneDeriving #-}
 
 module Phi.Phi ( Phi
-               , MessageBus
                , Message
+               , DefaultMessage(..)
                , fromMessage
                , initPhi
-               , runPhi
                , sendMessage
-               , getMessageBus
                , receiveMessage
                ) where
 
@@ -16,9 +14,11 @@ import Control.Monad
 import Data.Typeable
 
 data Phi = Phi (Chan Message)
-data MessageBus = MessageBus (Chan Message)
 
 data Message = forall a. (Typeable a, Show a) => Message a
+deriving instance Show Message
+
+data DefaultMessage = Repaint deriving (Typeable, Show)
 
 fromMessage :: (Typeable a, Show a) => Message -> Maybe a
 fromMessage (Message m) = cast m
@@ -26,14 +26,8 @@ fromMessage (Message m) = cast m
 initPhi :: IO Phi
 initPhi = liftM Phi newChan
 
-runPhi :: Phi -> IO ()
-runPhi (Phi chan) = forever $ readChan chan
-
 sendMessage :: (Typeable a, Show a) => Phi -> a -> IO ()
 sendMessage (Phi chan) = writeChan chan . Message
 
-getMessageBus :: Phi -> IO MessageBus
-getMessageBus (Phi chan) = liftM MessageBus $ dupChan chan
-
-receiveMessage :: MessageBus -> IO Message
-receiveMessage (MessageBus chan) = readChan chan
+receiveMessage :: Phi -> IO Message
+receiveMessage (Phi chan) = readChan chan
diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs
index f6703a7..d28c21d 100644
--- a/lib/Phi/Widget.hs
+++ b/lib/Phi/Widget.hs
@@ -1,26 +1,35 @@
 {-# LANGUAGE ExistentialQuantification, TypeFamilies, StandaloneDeriving, FlexibleContexts #-}
 
-module Phi.Widget ( Widget(..)
+module Phi.Widget ( Display
+                  , Widget(..)
                   , WidgetClass(..)
                   , WidgetState(..)
                   , separator
                   , createWidgetState
                   , layoutWidgets
                   , renderWidgets
+                  , handleMessageWidgets
                   ) where
 
+import Control.Concurrent
 import Control.Monad
+
 import Data.Traversable
 
+import qualified Graphics.X11.Xlib
+
 import Graphics.Rendering.Cairo
 
 import Phi.Phi
 
 
+type Display = MVar Graphics.X11.Xlib.Display
+
+
 class Show a => WidgetClass a where
   type WidgetData a :: *
   
-  initialState :: a -> WidgetData a
+  initWidget :: a -> Phi -> Display -> IO (WidgetData a)
   
   minSize :: a -> Int
   
@@ -47,14 +56,16 @@ data WidgetState = forall a. (WidgetClass a, Show (WidgetData a)) => WidgetState
                                                                                  }
 deriving instance Show WidgetState
 
-createWidgetState :: Widget -> WidgetState
-createWidgetState (Widget w) = WidgetState { stateWidget = w
-                                           , stateX = 0
-                                           , stateY = 0
-                                           , stateWidth = 0
-                                           , stateHeight = 0
-                                           , statePrivateData = initialState w
-                                           }
+createWidgetState :: Phi -> Display -> Widget -> IO WidgetState
+createWidgetState phi disp (Widget w) = do
+  priv <- initWidget w phi disp
+  return WidgetState { stateWidget = w
+                     , stateX = 0
+                     , stateY = 0
+                     , stateWidth = 0
+                     , stateHeight = 0
+                     , statePrivateData = priv
+                     }
 
 layoutWidgets :: [WidgetState] -> Int -> Int -> Int -> Int -> [WidgetState]
 layoutWidgets widgets x y width height = snd $ mapAccumL layoutWidgetAndX x widgets
@@ -98,7 +109,7 @@ data Separator = Separator Int Float deriving Show
 
 instance WidgetClass Separator where
   type WidgetData Separator = ()
-  initialState _ = ()
+  initWidget _ _ _ = return ()
   
   minSize (Separator s _) = s
   weight (Separator _ w) = w
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
diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs
index 806986d..3fc08e6 100644
--- a/lib/Phi/X11.hs
+++ b/lib/Phi/X11.hs
@@ -1,8 +1,8 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 module Phi.X11 ( XConfig(..)
                , defaultXConfig
-               , initPhiX
+               , runPhi
                ) where
 
 import Graphics.X11.Xlib
@@ -31,25 +31,26 @@ import qualified Phi.Widget as Widget
 import Phi.X11.Atoms
 import qualified Phi.Bindings.Util as Util
 
-data XConfig = XConfig { phiXScreenInfo :: Display -> IO [Rectangle]
+data XConfig = XConfig { phiXScreenInfo :: !(Display -> IO [Rectangle])
                        }
 
-data PhiState = PhiState { phiRootPixmap :: Pixmap
-                         , phiPanels     :: [PanelState]
+data PhiState = PhiState { phiPhi        :: !Phi
+                         , phiRootPixmap :: !Pixmap
+                         , phiPanels     :: ![PanelState]
                          }
 
-data PanelState = PanelState { panelWindow       :: Window
-                             , panelGC           :: GC
-                             , panelPixmap       :: Pixmap
-                             , panelSurface      :: Surface
-                             , panelArea         :: Rectangle
-                             , panelScreenArea   :: Rectangle
-                             , panelWidgetStates :: [Widget.WidgetState]
+data PanelState = PanelState { panelWindow       :: !Window
+                             , panelGC           :: !GC
+                             , panelPixmap       :: !Pixmap
+                             , panelSurface      :: !Surface
+                             , panelArea         :: !Rectangle
+                             , panelScreenArea   :: !Rectangle
+                             , panelWidgetStates :: ![Widget.WidgetState]
                              }
 
-data PhiConfig = PhiConfig { phiPanelConfig :: Panel.PanelConfig
-                           , phiXConfig     :: XConfig
-                           , phiAtoms       :: Atoms
+data PhiConfig = PhiConfig { phiPanelConfig :: !Panel.PanelConfig
+                           , phiXConfig     :: !XConfig
+                           , phiAtoms       :: !Atoms
                            }
 
 newtype PhiReader a = PhiReader (ReaderT PhiConfig IO a)
@@ -64,12 +65,6 @@ newtype PhiX a = PhiX (StateT PhiState PhiReader a)
 runPhiX :: PhiConfig -> PhiState -> PhiX a -> IO (a, PhiState)
 runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
 
-forkPhiX :: PhiX () -> PhiX ThreadId
-forkPhiX f = do
-  config <- ask
-  state <- get
-  liftIO $ forkIO $ (runPhiX config state f >> return ())
-
 withMVarX :: MVar a -> (a -> PhiX b) -> PhiX b
 withMVarX m f = do
   a <- liftIO $ takeMVar m
@@ -81,18 +76,23 @@ defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
                          }
 
 
-initPhiX :: Phi -> XConfig -> Panel.PanelConfig -> [Widget.Widget] -> IO ()
-initPhiX phi xconfig config widgets = do
+runPhi :: XConfig -> Panel.PanelConfig -> [Widget.Widget] -> IO ()
+runPhi xconfig config widgets = do
+  phi <- initPhi
   disp <- openDisplay []
 
   atoms <- initAtoms disp
   selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask
   
-  runPhiX PhiConfig { phiXConfig = xconfig, phiPanelConfig = config, phiAtoms = atoms } PhiState { phiRootPixmap = 0, phiPanels = [] } $ do
+  runPhiX PhiConfig { phiXConfig = xconfig, phiPanelConfig = config, phiAtoms = atoms } PhiState { phiPhi = phi, phiRootPixmap = 0, phiPanels = [] } $ do
     updateRootPixmap disp
     
     screens <- liftIO $ phiXScreenInfo xconfig disp
-    panels <- mapM (createPanel disp widgets) screens
+    
+    dispvar <- liftIO $ newEmptyMVar
+    widgetStates <- liftIO $ mapM (Widget.createWidgetState phi dispvar) widgets
+    panels <- mapM (createPanel disp widgetStates) screens
+    
     forM_ panels $ \panel -> do
       setPanelProperties disp panel
       liftIO $ mapWindow disp (panelWindow panel)
@@ -101,23 +101,36 @@ initPhiX phi xconfig config widgets = do
     
     updatePanels disp True
     
-    dispvar <- liftIO $ newMVar disp
+    liftIO $ putMVar dispvar disp
+    
     liftIO $ forkIO $ receiveEvents phi dispvar
 
-    messagebus <- liftIO $ getMessageBus phi
-    forkPhiX $ forever $ do
-      message <- liftIO $ receiveMessage messagebus
+    forever $ do
+      message <- liftIO $ receiveMessage phi
       handleMessage dispvar message
   return ()
 
 
+handlePanel :: Message -> PanelState -> PanelState
+handlePanel message panel@PanelState {panelWidgetStates = widgets} = panel {panelWidgetStates = widgets'}
+  where
+    widgets' = Widget.handleMessageWidgets message widgets
+
 handleMessage :: MVar Display -> Message -> PhiX ()
-handleMessage dispvar m
-  | Just ExposeEvent {} <- fromMessage m = withMVarX dispvar $ \disp -> do
-    updatePanels disp False
-  | Just event@PropertyEvent {} <- fromMessage m = withMVarX dispvar $ \disp -> do
-    handlePropertyUpdate disp event
-handleMessage _ _ = return ()
+handleMessage dispvar m = do
+  modify $ \state@PhiState {phiPanels = panels} -> state {phiPanels = map (handlePanel m) panels}
+  
+  case (fromMessage m) of
+    Just Repaint -> withMVarX dispvar $ \disp ->
+      updatePanels disp True
+    _ ->
+      case (fromMessage m) of
+        Just ExposeEvent {} -> withMVarX dispvar $ \disp ->
+          updatePanels disp False
+        Just event@PropertyEvent {} -> withMVarX dispvar $ \disp ->
+          handlePropertyUpdate disp event
+        _ ->
+          return ()
 
 receiveEvents :: Phi -> MVar Display -> IO ()
 receiveEvents phi dispvar = do
@@ -186,8 +199,9 @@ updateRootPixmap disp = do
   modify $ \state -> state { phiRootPixmap = pixmap }
 
 
-createPanel :: Display -> [Widget.Widget] -> Rectangle -> PhiX PanelState
+createPanel :: Display -> [Widget.WidgetState] -> Rectangle -> PhiX PanelState
 createPanel disp widgets screenRect = do
+  phi <- gets phiPhi
   config <- asks phiPanelConfig
   let rect = panelBounds config screenRect
       
@@ -201,7 +215,14 @@ createPanel disp widgets screenRect = do
   pixmap <- liftIO $ withDimension rect (createPixmap disp win) depth
   surface <- liftIO $ withDimension rect $ Util.createXlibSurface disp pixmap visual
   
-  return PanelState { panelWindow = win, panelGC = gc, panelPixmap = pixmap, panelSurface = surface, panelArea = rect, panelScreenArea = screenRect, panelWidgetStates = map Widget.createWidgetState widgets }
+  return PanelState { panelWindow = win
+                    , panelGC = gc
+                    , panelPixmap = pixmap
+                    , panelSurface = surface
+                    , panelArea = rect
+                    , panelScreenArea = screenRect
+                    , panelWidgetStates = widgets
+                    }
 
 createPanelWindow :: Display -> Rectangle -> PhiX Window
 createPanelWindow disp rect = do