summaryrefslogtreecommitdiffstats
path: root/lib/Phi
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Phi')
-rw-r--r--lib/Phi/Phi.hs34
-rw-r--r--lib/Phi/Widget.hs14
-rw-r--r--lib/Phi/X11.hs39
3 files changed, 66 insertions, 21 deletions
diff --git a/lib/Phi/Phi.hs b/lib/Phi/Phi.hs
new file mode 100644
index 0000000..9df36f3
--- /dev/null
+++ b/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
diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs
index 9262aba..3f00508 100644
--- a/lib/Phi/Widget.hs
+++ b/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 :: *
@@ -29,6 +32,9 @@ class Show a => WidgetClass a where
layout _ priv _ _ = priv
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
diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs
index b79001c..548027c 100644
--- a/lib/Phi/X11.hs
+++ b/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)
- deriving (Monad, MonadState PhiState, MonadReader PhiConfig, MonadIO)
+newtype PhiX a = PhiX (StateT PhiState PhiReader a)
+ deriving (Monad, MonadState PhiState, MonadReader PhiConfig, MonadIO)
-runPhi :: PhiConfig -> PhiState -> Phi a -> IO (a, PhiState)
-runPhi config st (Phi a) = runPhiReader config $ runStateT a st
+runPhiX :: PhiConfig -> PhiState -> PhiX a -> IO (a, PhiState)
+runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
-liftIOContToPhi :: ((a -> IO (b, PhiState)) -> IO (b, PhiState)) -> (a -> Phi b) -> Phi b
-liftIOContToPhi f c = do
+liftIOContToPhiX :: ((a -> IO (b, PhiState)) -> IO (b, PhiState)) -> (a -> PhiX b) -> PhiX b
+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 ()
-initPhi xconfig config widgets = do
+initPhiX :: Phi -> XConfig -> Panel.PanelConfig -> [Widget.Widget] -> IO ()
+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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 04:53:11 +0100