summaryrefslogtreecommitdiffstats
path: root/lib/Phi
diff options
context:
space:
mode:
authorMatthias Schiffer <mschiffer@universe-factory.net>2011-07-14 20:21:30 +0200
committerMatthias Schiffer <mschiffer@universe-factory.net>2011-07-14 20:21:30 +0200
commit861fa81d8503b64023777ec815845361bbcc2885 (patch)
treec194a5bbd4c839eb4ccf5b933d5abebcb3368385 /lib/Phi
parent7c0f602343e84823d370c8742716ce6b7a8b9850 (diff)
downloadphi-861fa81d8503b64023777ec815845361bbcc2885.tar
phi-861fa81d8503b64023777ec815845361bbcc2885.zip
Added clock widget
Diffstat (limited to 'lib/Phi')
-rw-r--r--lib/Phi/Border.hs11
-rw-r--r--lib/Phi/Panel.hs1
-rw-r--r--lib/Phi/Phi.hs20
-rw-r--r--lib/Phi/Widget.hs33
-rw-r--r--lib/Phi/Widgets/Clock.hs78
-rw-r--r--lib/Phi/X11.hs95
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