From 7ae4f3def6b412ed3a760340dfa804deff67026d Mon Sep 17 00:00:00 2001 From: Don Stewart Date: Wed, 7 Mar 2007 03:55:35 +0100 Subject: move thunk.hs -> Main.hs. Be precise about which versions of every package are known to work darcs-hash:20070307025535-9c5c1-2468ea0782a68c4621921147f9e2101a30d9d4b2 --- Main.hs | 109 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ thunk.cabal | 4 +-- thunk.hs | 109 ------------------------------------------------------------ 3 files changed, 111 insertions(+), 111 deletions(-) create mode 100644 Main.hs delete mode 100644 thunk.hs diff --git a/Main.hs b/Main.hs new file mode 100644 index 0000000..bae8b76 --- /dev/null +++ b/Main.hs @@ -0,0 +1,109 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} + +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Sequence as Seq +import qualified Data.Foldable as Fold +import Data.Bits +import Control.Monad.State +import System.IO +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras +import System.Process (runCommand) +import System.Exit + +import Wm + +handler :: Event -> Wm () +handler (MapRequestEvent {window = w}) = manage w +handler (DestroyWindowEvent {window = w}) = do + modifyWindows (Seq.fromList . filter (/= w) . Fold.toList) + refresh +handler (KeyEvent {event_type = t, state = mod, keycode = code}) + | t == keyPress = do + dpy <- getDisplay + sym <- l $ keycodeToKeysym dpy code 0 + case filter (\(mod', sym', _) -> mod == mod' && sym == sym') keys of + [] -> return () + ((_, _, act):_) -> act +handler _ = return () + +switch :: Wm () +switch = do + ws' <- getWindows + case viewl ws' of + EmptyL -> return () + (w :< ws) -> do + setWindows (ws |> w) + refresh + +spawn :: String -> Wm () +spawn c = do + l $ runCommand c + return () + +keys :: [(KeyMask, KeySym, Wm ())] +keys = + [ (mod1Mask .|. shiftMask, xK_Return, spawn "xterm") + , (controlMask, xK_space, spawn "gmrun") + , (mod1Mask, xK_Tab, switch) + , (mod1Mask .|. shiftMask, xK_q, l $ exitWith ExitSuccess) + ] + +grabkeys = do + dpy <- getDisplay + root <- l $ rootWindow dpy (defaultScreen dpy) + forM_ keys $ \(mod, sym, _) -> do + code <- l $ keysymToKeycode dpy sym + l $ grabKey dpy code mod root True grabModeAsync grabModeAsync + +manage :: Window -> Wm () +manage w = do + trace "manage" + d <- getDisplay + ws <- getWindows + when (Fold.notElem w ws) $ do + trace "modifying" + modifyWindows (w <|) + l $ mapWindow d w + refresh + +refresh :: Wm () +refresh = do + v <- getWindows + case viewl v of + EmptyL -> return () + (w :< _) -> do + d <- getDisplay + sw <- getScreenWidth + sh <- getScreenHeight + l $ moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) + l $ raiseWindow d w + +main = do + dpy <- openDisplay "" + runWm main' (WmState + { display = dpy + , screenWidth = displayWidth dpy (defaultScreen dpy) + , screenHeight = displayHeight dpy (defaultScreen dpy) + , windows = Seq.empty + }) + return () + +main' = do + dpy <- getDisplay + let screen = defaultScreen dpy + root <- l $ rootWindow dpy screen + l $ selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask) + l $ sync dpy False + grabkeys + loop + +loop :: Wm () +loop = do + dpy <- getDisplay + e <- l $ allocaXEvent $ \ev -> do + nextEvent dpy ev + getEvent ev + handler e + loop diff --git a/thunk.cabal b/thunk.cabal index cee19bf..90bc2c1 100644 --- a/thunk.cabal +++ b/thunk.cabal @@ -7,8 +7,8 @@ license: BSD3 license-file: LICENSE author: Spencer Janssen maintainer: sjanssen@cse.unl.edu -build-depends: base >= 2.0, X11, X11-extras, unix, mtl +build-depends: base==2.0, X11==1.1, X11-extras==0.0, unix==1.0, mtl==1.0 executable: thunk -main-is: thunk.hs +main-is: Main.hs ghc-options: -O diff --git a/thunk.hs b/thunk.hs deleted file mode 100644 index bae8b76..0000000 --- a/thunk.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} - -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Sequence as Seq -import qualified Data.Foldable as Fold -import Data.Bits -import Control.Monad.State -import System.IO -import Graphics.X11.Xlib -import Graphics.X11.Xlib.Extras -import System.Process (runCommand) -import System.Exit - -import Wm - -handler :: Event -> Wm () -handler (MapRequestEvent {window = w}) = manage w -handler (DestroyWindowEvent {window = w}) = do - modifyWindows (Seq.fromList . filter (/= w) . Fold.toList) - refresh -handler (KeyEvent {event_type = t, state = mod, keycode = code}) - | t == keyPress = do - dpy <- getDisplay - sym <- l $ keycodeToKeysym dpy code 0 - case filter (\(mod', sym', _) -> mod == mod' && sym == sym') keys of - [] -> return () - ((_, _, act):_) -> act -handler _ = return () - -switch :: Wm () -switch = do - ws' <- getWindows - case viewl ws' of - EmptyL -> return () - (w :< ws) -> do - setWindows (ws |> w) - refresh - -spawn :: String -> Wm () -spawn c = do - l $ runCommand c - return () - -keys :: [(KeyMask, KeySym, Wm ())] -keys = - [ (mod1Mask .|. shiftMask, xK_Return, spawn "xterm") - , (controlMask, xK_space, spawn "gmrun") - , (mod1Mask, xK_Tab, switch) - , (mod1Mask .|. shiftMask, xK_q, l $ exitWith ExitSuccess) - ] - -grabkeys = do - dpy <- getDisplay - root <- l $ rootWindow dpy (defaultScreen dpy) - forM_ keys $ \(mod, sym, _) -> do - code <- l $ keysymToKeycode dpy sym - l $ grabKey dpy code mod root True grabModeAsync grabModeAsync - -manage :: Window -> Wm () -manage w = do - trace "manage" - d <- getDisplay - ws <- getWindows - when (Fold.notElem w ws) $ do - trace "modifying" - modifyWindows (w <|) - l $ mapWindow d w - refresh - -refresh :: Wm () -refresh = do - v <- getWindows - case viewl v of - EmptyL -> return () - (w :< _) -> do - d <- getDisplay - sw <- getScreenWidth - sh <- getScreenHeight - l $ moveResizeWindow d w 0 0 (fromIntegral sw) (fromIntegral sh) - l $ raiseWindow d w - -main = do - dpy <- openDisplay "" - runWm main' (WmState - { display = dpy - , screenWidth = displayWidth dpy (defaultScreen dpy) - , screenHeight = displayHeight dpy (defaultScreen dpy) - , windows = Seq.empty - }) - return () - -main' = do - dpy <- getDisplay - let screen = defaultScreen dpy - root <- l $ rootWindow dpy screen - l $ selectInput dpy root (substructureRedirectMask .|. substructureNotifyMask) - l $ sync dpy False - grabkeys - loop - -loop :: Wm () -loop = do - dpy <- getDisplay - e <- l $ allocaXEvent $ \ev -> do - nextEvent dpy ev - getEvent ev - handler e - loop -- cgit v1.2.3