Added clock widget
This commit is contained in:
parent
7c0f602343
commit
861fa81d85
8 changed files with 184 additions and 74 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -12,4 +12,3 @@ data PanelConfig = PanelConfig { panelPosition :: Position
|
|||
|
||||
defaultPanelConfig :: PanelConfig
|
||||
defaultPanelConfig = PanelConfig { panelPosition = Top, panelSize = 24 }
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
78
lib/Phi/Widgets/Clock.hs
Normal file
78
lib/Phi/Widgets/Clock.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -11,8 +11,9 @@ maintainer: mschiffer@universe-factory.net
|
|||
build-type: Simple
|
||||
|
||||
library
|
||||
build-depends: base >= 4, template-haskell, mtl, cairo, X11
|
||||
exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11
|
||||
build-depends: base >= 4, template-haskell, mtl, time, old-locale, X11, cairo, pango
|
||||
exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11,
|
||||
Phi.Widgets.Clock
|
||||
other-modules: Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util
|
||||
hs-source-dirs: lib
|
||||
|
||||
|
|
|
|||
15
src/Phi.hs
15
src/Phi.hs
|
|
@ -1,19 +1,20 @@
|
|||
import Phi.Phi
|
||||
import Phi.Types
|
||||
import Phi.Widget
|
||||
import Phi.Panel
|
||||
import Phi.Border
|
||||
import Phi.X11
|
||||
|
||||
import Data.Monoid
|
||||
import Phi.Widgets.Clock
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
phi <- initPhi
|
||||
initPhiX phi defaultXConfig defaultPanelConfig { panelPosition = Bottom }
|
||||
[border border1 [border border3 [], border border3 []], border border2 []]
|
||||
runPhi phi
|
||||
runPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom }
|
||||
[border border1 [border border3 [], border border3 []], border border2 [], border brightBorder [theClock]]
|
||||
where
|
||||
theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 8'>%R</span>\n<span font='Sans 6'>%A %d %B</span>"
|
||||
, lineSpacing = (-2)
|
||||
, clockSize = 75
|
||||
}
|
||||
brightBorder = BorderConfig (simpleBorderWidth 1) 1 (BorderWidth (-2) 3 0 3) (0.5, 0.5, 0.5, 0.65) (0.85, 0.85, 0.85, 0.8) 5 0
|
||||
border1 = BorderConfig (simpleBorderWidth 1) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.25, 0.25, 0.25, 0.5) 7 2
|
||||
border2 = BorderConfig (simpleBorderWidth 1) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.5, 0.0, 0.25, 0.5) 7 1
|
||||
border3 = BorderConfig (simpleBorderWidth 0) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.0, 0.0, 0.5, 0.5) 3 1
|
||||
|
|
|
|||
Reference in a new issue