diff options
Diffstat (limited to 'lib/Phi')
| -rw-r--r-- | lib/Phi/Border.hs | 11 | ||||
| -rw-r--r-- | lib/Phi/Panel.hs | 1 | ||||
| -rw-r--r-- | lib/Phi/Phi.hs | 20 | ||||
| -rw-r--r-- | lib/Phi/Widget.hs | 33 | ||||
| -rw-r--r-- | lib/Phi/Widgets/Clock.hs | 78 | ||||
| -rw-r--r-- | lib/Phi/X11.hs | 95 |
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 |