Some more restructuring, WIP
This commit is contained in:
parent
d519f67816
commit
e4314c03fa
5 changed files with 70 additions and 23 deletions
34
lib/Phi/Phi.hs
Normal file
34
lib/Phi/Phi.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Reference in a new issue