Some more restructuring, WIP

lib/Phi/Phi.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Phi.Phi ( Phi
+               , MessageBus
+               , Message(..)
+               , initPhi
+               , runPhi
+               , sendMessage
+               , getMessageBus
+               , receiveMessage
+               ) where
+
+import Control.Concurrent.Chan
+import Control.Monad
+
+data Phi = Phi (Chan Message)
+data MessageBus = MessageBus (Chan Message)
+
+data Message = forall a. Show a => Message a
+
+initPhi :: IO Phi
+initPhi = liftM Phi newChan
+
+runPhi :: Phi -> IO ()
+runPhi (Phi chan) = forever $ readChan chan
+
+sendMessage :: Phi -> Message -> IO ()
+sendMessage (Phi chan) = writeChan chan
+
+getMessageBus :: Phi -> IO MessageBus
+getMessageBus (Phi chan) = liftM MessageBus $ dupChan chan
+
+receiveMessage :: MessageBus -> IO Message
+receiveMessage (MessageBus chan) = readChan chan

lib/Phi/Widget.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE ExistentialQuantification, TypeFamilies, StandaloneDeriving, FlexibleContexts #-}
 
-module Phi.Widget ( Widget(..)
+module Phi.Widget ( Message(..)
+                  , Widget(..)
                   , WidgetClass(..)
                   , WidgetState(..)
                   , separator
@@ -14,6 +15,8 @@ import Data.Traversable
 
 import Graphics.Rendering.Cairo
 
+import Phi.Phi
+
 
 class Show a => WidgetClass a where
   type WidgetData a :: *
@@ -30,6 +33,9 @@ class Show a => WidgetClass a where
   
   render :: a -> WidgetData a -> Int -> Int -> Render ()
   
+  handleMessage :: a -> WidgetData a -> Message -> WidgetData a
+  handleMessage _ priv _ = priv
+
 data Widget = forall a. (WidgetClass a, Show (WidgetData a)) => Widget a
 deriving instance Show Widget
 
@@ -67,7 +73,7 @@ layoutWidgets widgets x y width height = snd $ mapAccumL layoutWidgetAndX x widg
       WidgetState {stateWidget = w, statePrivateData = priv} ->
         let wWidth = floor $ (fromIntegral $ minSize w) + (fromIntegral surplus)*(nneg $ weight w)/wsum
             priv' = layout w priv wWidth height
-        in WidgetState { stateWidget = w, stateX = wX, stateY = y, stateWidth = wWidth, stateHeight = height, statePrivateData = priv' }
+        in WidgetState w wX y wWidth height priv'
     
     nneg :: (Num a, Ord a) => a -> a
     nneg x = max 0 x
@@ -84,6 +90,10 @@ renderWidgets widgets = forM_ widgets $ \WidgetState { stateWidget = widget
   render widget priv w h
   restore
 
+handleMessageWidgets :: Message -> [WidgetState] -> [WidgetState]
+handleMessageWidgets message = map handleMessageWidget
+  where
+    handleMessageWidget (WidgetState w x y width height priv) = WidgetState w x y width height $ handleMessage w priv message
 
 data Separator = Separator Int Float deriving Show
 

lib/Phi/X11.hs

@@ -2,7 +2,7 @@
 
 module Phi.X11 ( XConfig(..)
                , defaultXConfig
-               , initPhi
+               , initPhiX
                ) where
 
 import Graphics.X11.Xlib
@@ -20,6 +20,7 @@ import Control.Monad.State
 import Control.Monad.Reader
 import Control.Monad.Trans
 
+import Phi.Phi
 import qualified Phi.Types as Phi
 import qualified Phi.Panel as Panel
 import qualified Phi.Widget as Widget
@@ -54,17 +55,17 @@ newtype PhiReader a = PhiReader (ReaderT PhiConfig IO a)
 runPhiReader :: PhiConfig -> PhiReader a -> IO a
 runPhiReader config (PhiReader a) = runReaderT a config
 
-newtype Phi a = Phi (StateT PhiState PhiReader a)
+newtype PhiX a = PhiX (StateT PhiState PhiReader a)
                deriving (Monad, MonadState PhiState, MonadReader PhiConfig, MonadIO)
 
-runPhi :: PhiConfig -> PhiState -> Phi a -> IO (a, PhiState)
+runPhiX :: PhiConfig -> PhiState -> PhiX a -> IO (a, PhiState)
-runPhi config st (Phi a) = runPhiReader config $ runStateT a st
+runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
 
-liftIOContToPhi :: ((a -> IO (b, PhiState)) -> IO (b, PhiState)) -> (a -> Phi b) -> Phi b
+liftIOContToPhiX :: ((a -> IO (b, PhiState)) -> IO (b, PhiState)) -> (a -> PhiX b) -> PhiX b
-liftIOContToPhi f c = do
+liftIOContToPhiX f c = do
   config <- ask
   state <- get
-  (a, state') <- liftIO $ f $ runPhi config state . c
+  (a, state') <- liftIO $ f $ runPhiX config state . c
   put state'
   return a
 
@@ -73,13 +74,13 @@ defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
                          }
 
 
-initPhi :: XConfig -> Panel.PanelConfig -> [Widget.Widget] -> IO ()
+initPhiX :: Phi -> XConfig -> Panel.PanelConfig -> [Widget.Widget] -> IO ()
-initPhi xconfig config widgets = do
+initPhiX phi xconfig config widgets = do
   disp <- openDisplay []
   atoms <- initAtoms disp
   selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask
   
-  runPhi PhiConfig { phiXConfig = xconfig, phiPanelConfig = config, phiDisplay = disp, phiAtoms = atoms } PhiState { phiRootPixmap = 0, phiPanels = [] } $ do
+  runPhiX PhiConfig { phiXConfig = xconfig, phiPanelConfig = config, phiDisplay = disp, phiAtoms = atoms } PhiState { phiRootPixmap = 0, phiPanels = [] } $ do
     updateRootPixmap
     
     screens <- liftIO $ phiXScreenInfo xconfig disp
@@ -92,7 +93,7 @@ initPhi xconfig config widgets = do
     
     updatePanels True
 
-    liftIOContToPhi allocaXEvent $ \xevent -> do
+    liftIOContToPhiX allocaXEvent $ \xevent -> do
       forever $ do
         liftIO $ nextEvent disp xevent
         event <- liftIO $ getEvent xevent
@@ -104,7 +105,7 @@ initPhi xconfig config widgets = do
   return ()
 
 
-updatePanels :: Bool -> Phi ()
+updatePanels :: Bool -> PhiX ()
 updatePanels redraw = do
   disp <- asks phiDisplay
   
@@ -134,7 +135,7 @@ updatePanels redraw = do
   modify $ \state -> state { phiPanels = panels' }
 
 
-handlePropertyUpdate :: Event -> Phi ()
+handlePropertyUpdate :: Event -> PhiX ()
 handlePropertyUpdate PropertyEvent { ev_atom = atom } = do
   atoms <- asks phiAtoms
   panels <- gets phiPanels
@@ -144,7 +145,7 @@ handlePropertyUpdate PropertyEvent { ev_atom = atom } = do
     updatePanels True
   
 
-updateRootPixmap :: Phi ()
+updateRootPixmap :: PhiX ()
 updateRootPixmap = do
   disp <- asks phiDisplay
   atoms <- asks phiAtoms
@@ -155,7 +156,7 @@ updateRootPixmap = do
   modify $ \state -> state { phiRootPixmap = pixmap }
 
 
-createPanel :: [Widget.Widget] -> Rectangle -> Phi PanelState
+createPanel :: [Widget.Widget] -> Rectangle -> PhiX PanelState
 createPanel widgets screenRect = do
   config <- asks phiPanelConfig
   disp <- asks phiDisplay
@@ -173,7 +174,7 @@ createPanel widgets screenRect = do
   
   return PanelState { panelWindow = win, panelGC = gc, panelPixmap = pixmap, panelSurface = surface, panelArea = rect, panelScreenArea = screenRect, panelWidgetStates = map Widget.createWidgetState widgets }
 
-createPanelWindow :: Rectangle -> Phi Window
+createPanelWindow :: Rectangle -> PhiX Window
 createPanelWindow rect = do
   disp <- asks phiDisplay
   let screen = defaultScreen disp
@@ -191,7 +192,7 @@ createPanelWindow rect = do
     withRectangle rect (createWindow disp rootwin) 0 depth inputOutput visual mask attr
 
 
-setPanelProperties :: PanelState -> Phi ()
+setPanelProperties :: PanelState -> PhiX ()
 setPanelProperties panel = do
   disp <- asks phiDisplay
   atoms <- asks phiAtoms
@@ -223,7 +224,7 @@ setPanelProperties panel = do
   setStruts panel
 
 
-setStruts :: PanelState -> Phi ()
+setStruts :: PanelState -> PhiX ()
 setStruts panel = do
   atoms <- asks phiAtoms
   disp <- asks phiDisplay

phi.cabal

@@ -12,7 +12,7 @@ build-type:          Simple
 
 library
   build-depends:     base >= 4, template-haskell, mtl, cairo, X11
-  exposed-modules:   Phi.Types, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11
+  exposed-modules:   Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11
   other-modules:     Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util
   hs-source-dirs:    lib
 

src/Phi.hs

@@ -1,3 +1,4 @@
+import Phi.Phi
 import Phi.Types
 import Phi.Widget
 import Phi.Panel
@@ -8,7 +9,8 @@ import Data.Monoid
 
 main :: IO ()
 main = do
-  initPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom}
+  phi <- initPhi
+  initPhiX phi defaultXConfig defaultPanelConfig { panelPosition = Bottom, panelSize = 48 }
     [border border1 [border border3 [], border border3 []], border border2 []]
     where
       border1 = BorderConfig (simpleBorderWidth 1) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.25, 0.25, 0.25, 0.5) 7 2