diff options
| -rw-r--r-- | lib/Phi/Phi.hs | 34 | ||||
| -rw-r--r-- | lib/Phi/Widget.hs | 14 | ||||
| -rw-r--r-- | lib/Phi/X11.hs | 39 | ||||
| -rw-r--r-- | phi.cabal | 2 | ||||
| -rw-r--r-- | src/Phi.hs | 4 |
5 files changed, 70 insertions, 23 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 @@ -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 @@ -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 |