diff options
Diffstat (limited to 'XMonad/Util')
| -rw-r--r-- | XMonad/Util/Anneal.hs | 90 | ||||
| -rw-r--r-- | XMonad/Util/Dmenu.hs | 49 | ||||
| -rw-r--r-- | XMonad/Util/Dzen.hs | 71 | ||||
| -rw-r--r-- | XMonad/Util/Invisible.hs | 45 | ||||
| -rw-r--r-- | XMonad/Util/NamedWindows.hs | 57 | ||||
| -rw-r--r-- | XMonad/Util/Run.hs | 114 | ||||
| -rw-r--r-- | XMonad/Util/XSelection.hs | 175 | ||||
| -rw-r--r-- | XMonad/Util/XUtils.hs | 191 |
8 files changed, 792 insertions, 0 deletions
diff --git a/XMonad/Util/Anneal.hs b/XMonad/Util/Anneal.hs new file mode 100644 index 0000000..6852308 --- /dev/null +++ b/XMonad/Util/Anneal.hs @@ -0,0 +1,90 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.Anneal +-- Copyright : (c) David Roundy +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : David Roundy <droundy@darcs.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Requires the 'random' package +-- +----------------------------------------------------------------------------- + +module XMonad.Util.Anneal ( Rated(Rated), the_value, the_rating + , anneal, annealMax ) where + +import System.Random ( StdGen, Random, mkStdGen, randomR ) +import Control.Monad.State ( State, runState, put, get, gets, modify ) + +-- %import XMonad.Util.Anneal + +data Rated a b = Rated !a !b + deriving ( Show ) +instance Functor (Rated a) where + f `fmap` (Rated v a) = Rated v (f a) + +the_value :: Rated a b -> b +the_value (Rated _ b) = b +the_rating :: Rated a b -> a +the_rating (Rated a _) = a + +instance Eq a => Eq (Rated a b) where + (Rated a _) == (Rated a' _) = a == a' +instance Ord a => Ord (Rated a b) where + compare (Rated a _) (Rated a' _) = compare a a' + +anneal :: a -> (a -> Double) -> (a -> [a]) -> Rated Double a +anneal st r sel = runAnneal st r (do_anneal sel) + +annealMax :: a -> (a -> Double) -> (a -> [a]) -> Rated Double a +annealMax st r sel = runAnneal st (negate . r) (do_anneal sel) + +do_anneal :: (a -> [a]) -> State (Anneal a) (Rated Double a) +do_anneal sel = do sequence_ $ replicate 100 da + gets best + where da = do select_metropolis sel + modify $ \s -> s { temperature = temperature s *0.99 } + +data Anneal a = A { g :: StdGen + , best :: Rated Double a + , current :: Rated Double a + , rate :: a -> Rated Double a + , temperature :: Double } + +runAnneal :: a -> (a -> Double) -> State (Anneal a) b -> b +runAnneal start r x = fst $ runState x (A { g = mkStdGen 137 + , best = Rated (r start) start + , current = Rated (r start) start + , rate = \xx -> Rated (r xx) xx + , temperature = 1.0 }) + +select_metropolis :: (a -> [a]) -> State (Anneal a) () +select_metropolis x = do c <- gets current + a <- select $ x $ the_value c + metropolis a + +metropolis :: a -> State (Anneal a) () +metropolis x = do r <- gets rate + c <- gets current + t <- gets temperature + let rx = r x + boltz = exp $ (the_rating c - the_rating rx) / t + if rx < c then do modify $ \s -> s { current = rx, best = rx } + else do p <- getOne (0,1) + if p < boltz + then modify $ \s -> s { current = rx } + else return () + +select :: [a] -> State (Anneal a) a +select [] = the_value `fmap` gets best +select [x] = return x +select xs = do n <- getOne (0,length xs - 1) + return (xs !! n) + +getOne :: (Random a) => (a,a) -> State (Anneal x) a +getOne bounds = do s <- get + (x,g') <- return $ randomR bounds (g s) + put $ s { g = g' } + return x diff --git a/XMonad/Util/Dmenu.hs b/XMonad/Util/Dmenu.hs new file mode 100644 index 0000000..8eeb0d9 --- /dev/null +++ b/XMonad/Util/Dmenu.hs @@ -0,0 +1,49 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.Dmenu +-- Copyright : (c) Spencer Janssen <sjanssen@cse.unl.edu> +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Spencer Janssen <sjanssen@cse.unl.edu> +-- Stability : unstable +-- Portability : unportable +-- +-- A convenient binding to dmenu. +-- +-- Requires the process-1.0 package +-- +----------------------------------------------------------------------------- + +module XMonad.Util.Dmenu ( + -- * Usage + -- $usage + dmenu, dmenuXinerama, dmenuMap + ) where + +import XMonad +import qualified XMonad.StackSet as W +import qualified Data.Map as M +import Control.Monad.State +import XMonad.Util.Run + +-- $usage +-- You can use this module with the following in your Config.hs file: +-- +-- > import XMonad.Util.Dmenu + +-- %import XMonad.Util.Dmenu + +-- | Starts dmenu on the current screen. Requires this patch to dmenu: +-- <http://www.jcreigh.com/dmenu/dmenu-3.2-xinerama.patch> +dmenuXinerama :: [String] -> X String +dmenuXinerama opts = do + curscreen <- (fromIntegral . W.screen . W.current) `liftM` gets windowset :: X Int + io $ runProcessWithInput "dmenu" ["-xs", show (curscreen+1)] (unlines opts) + +dmenu :: [String] -> X String +dmenu opts = io $ runProcessWithInput "dmenu" [] (unlines opts) + +dmenuMap :: M.Map String a -> X (Maybe a) +dmenuMap selectionMap = do + selection <- dmenu (M.keys selectionMap) + return $ M.lookup selection selectionMap diff --git a/XMonad/Util/Dzen.hs b/XMonad/Util/Dzen.hs new file mode 100644 index 0000000..02fce05 --- /dev/null +++ b/XMonad/Util/Dzen.hs @@ -0,0 +1,71 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.Dzen +-- Copyright : (c) glasser@mit.edu +-- License : BSD +-- +-- Maintainer : glasser@mit.edu +-- Stability : unstable +-- Portability : unportable +-- +-- Handy wrapper for dzen. Requires dzen >= 0.2.4. +-- +----------------------------------------------------------------------------- + +module XMonad.Util.Dzen (dzen, dzenWithArgs, dzenScreen, + dzenUrgencyHook, dzenUrgencyHookWithArgs, + seconds) where + +import Control.Monad (when) +import Control.Monad.State (gets) +import qualified Data.Set as S +import Graphics.X11.Types (Window) + +import qualified XMonad.StackSet as W +import XMonad + +import XMonad.Util.NamedWindows (getName) +import XMonad.Util.Run (runProcessWithInputAndWait, seconds) + +-- | @dzen str timeout@ pipes @str@ to dzen2 for @timeout@ microseconds. +-- Example usage: +-- > dzen "Hi, mom!" (5 `seconds`) +dzen :: String -> Int -> X () +dzen str timeout = dzenWithArgs str [] timeout + +-- | @dzen str args timeout@ pipes @str@ to dzen2 for @timeout@ seconds, passing @args@ to dzen. +-- Example usage: +-- > dzenWithArgs "Hi, dons!" ["-ta", "r"] (5 `seconds`) +dzenWithArgs :: String -> [String] -> Int -> X () +dzenWithArgs str args timeout = io $ runProcessWithInputAndWait "dzen2" args (unchomp str) timeout + -- dzen seems to require the input to terminate with exactly one newline. + where unchomp s@['\n'] = s + unchomp [] = ['\n'] + unchomp (c:cs) = c : unchomp cs + +-- | @dzenScreen sc str timeout@ pipes @str@ to dzen2 for @timeout@ microseconds, and on screen @sc@. +-- Requires dzen to be compiled with Xinerama support. +dzenScreen :: ScreenId -> String -> Int -> X() +dzenScreen sc str timeout = dzenWithArgs str ["-xs", screen] timeout + where screen = toXineramaArg sc + toXineramaArg n = show ( ((fromIntegral n)+1)::Int ) + +-- | Flashes when a window requests your attention and you can't see it. For use with +-- XMonadContrib.UrgencyHook. Usage: +-- > urgencyHook = dzenUrgencyHook (5 `seconds`) +dzenUrgencyHook :: Int -> Window -> X () +dzenUrgencyHook = dzenUrgencyHookWithArgs [] + +-- | Flashes when a window requests your attention and you can't see it. For use with +-- XMonadContrib.UrgencyHook. Usage: +-- > urgencyHook = dzenUrgencyHookWithArgs ["-bg", "darkgreen"] (5 `seconds`) +dzenUrgencyHookWithArgs :: [String] -> Int -> Window -> X () +dzenUrgencyHookWithArgs args duration w = do + visibles <- gets mapped + name <- getName w + ws <- gets windowset + whenJust (W.findTag w ws) (flash name visibles) + where flash name visibles index = + when (not $ S.member w visibles) $ + dzenWithArgs (show name ++ " requests your attention on workspace " ++ index) + args duration diff --git a/XMonad/Util/Invisible.hs b/XMonad/Util/Invisible.hs new file mode 100644 index 0000000..f387158 --- /dev/null +++ b/XMonad/Util/Invisible.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.Invisible +-- Copyright : (c) 2007 Andrea Rossato, David Roundy +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : andrea.rossato@unibz.it, droundy@darcs.net +-- Stability : unstable +-- Portability : unportable +-- +-- A data type to store the layout state +-- +----------------------------------------------------------------------------- + +module XMonad.Util.Invisible ( + -- * Usage: + -- $usage + Invisible (..) + , whenIJust + , fromIMaybe + ) where + +-- $usage +-- A wrapper data type to store layout state that shouldn't be persisted across +-- restarts. A common wrapped type to use is @Maybe a@. +-- Invisible derives trivial definitions for Read and Show, so the wrapped data +-- type need not do so. + +newtype Invisible m a = I (m a) deriving (Monad, Functor) + +instance (Functor m, Monad m) => Read (Invisible m a) where + readsPrec _ s = [(fail "Read Invisible", s)] + +instance Monad m => Show (Invisible m a) where + show _ = "" + +whenIJust :: (Monad m) => Invisible Maybe a -> (a -> m ()) -> m () +whenIJust (I (Just x)) f = f x +whenIJust (I Nothing) _ = return () + +fromIMaybe :: a -> Invisible Maybe a -> a +fromIMaybe _ (I (Just x)) = x +fromIMaybe a (I Nothing) = a diff --git a/XMonad/Util/NamedWindows.hs b/XMonad/Util/NamedWindows.hs new file mode 100644 index 0000000..05613b2 --- /dev/null +++ b/XMonad/Util/NamedWindows.hs @@ -0,0 +1,57 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.NamedWindows +-- Copyright : (c) David Roundy <droundy@darcs.net> +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : David Roundy <droundy@darcs.net> +-- Stability : unstable +-- Portability : unportable +-- +-- This module allows you to associate the X titles of windows with +-- them. +-- +----------------------------------------------------------------------------- + +module XMonad.Util.NamedWindows ( + -- * Usage + -- $usage + NamedWindow, + getName, + withNamedWindow, + unName + ) where + +import Control.Monad.Reader ( asks ) +import Control.Monad.State ( gets ) + +import qualified XMonad.StackSet as W ( peek ) + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +import XMonad + +-- $usage +-- See "XMonadContrib.Mosaic" for an example of its use. + + +data NamedWindow = NW !String !Window +instance Eq NamedWindow where + (NW s _) == (NW s' _) = s == s' +instance Ord NamedWindow where + compare (NW s _) (NW s' _) = compare s s' +instance Show NamedWindow where + show (NW n _) = n + +getName :: Window -> X NamedWindow +getName w = asks display >>= \d -> do s <- io $ getClassHint d w + n <- maybe (resName s) id `fmap` io (fetchName d w) + return $ NW n w + +unName :: NamedWindow -> Window +unName (NW _ w) = w + +withNamedWindow :: (NamedWindow -> X ()) -> X () +withNamedWindow f = do ws <- gets windowset + whenJust (W.peek ws) $ \w -> getName w >>= f diff --git a/XMonad/Util/Run.hs b/XMonad/Util/Run.hs new file mode 100644 index 0000000..39a653a --- /dev/null +++ b/XMonad/Util/Run.hs @@ -0,0 +1,114 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.Run +-- Copyright : (C) 2007 Spencer Janssen, Andrea Rossato, glasser@mit.edu +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Christian Thiemann <mail@christian-thiemann.de> +-- Stability : unstable +-- Portability : unportable +-- +-- This modules provides several commands to run an external process. +-- It is composed of functions formerly defined in XMonad.Util.Dmenu (by +-- Spenver Jannsen), XMonad.Util.Dzen (by glasser@mit.edu) and +-- XMonad.Util.RunInXTerm (by Andrea Rossato). +-- +----------------------------------------------------------------------------- + +module XMonad.Util.Run ( + -- * Usage + -- $usage + runProcessWithInput, + runProcessWithInputAndWait, + safeSpawn, + unsafeSpawn, + runInTerm, + safeRunInTerm, + seconds + ) where + +import Control.Monad.Reader +import System.Posix.Process (createSession, forkProcess, executeFile, + getProcessStatus) +import Control.Concurrent (threadDelay) +import Control.Exception (try) +import System.Exit (ExitCode(ExitSuccess), exitWith) +import System.IO (IO, FilePath, hPutStr, hGetContents, hFlush, hClose) +import System.Process (runInteractiveProcess, waitForProcess) +import XMonad + +-- $usage +-- For an example usage of runInTerm see XMonad.Prompt.Ssh +-- +-- For an example usage of runProcessWithInput see +-- XMonad.Prompt.{DirectoryPrompt,Dmenu,ShellPrompt,WmiiActions,WorkspaceDir} +-- +-- For an example usage of runProcessWithInputAndWait see XMonad.Util.Dzen + +-- | Returns Just output if the command succeeded, and Nothing if it didn't. +-- This corresponds to dmenu's notion of exit code 1 for a cancelled invocation. +runProcessWithInput :: FilePath -> [String] -> String -> IO String +runProcessWithInput cmd args input = do + (pin, pout, perr, ph) <- runInteractiveProcess cmd args Nothing Nothing + hPutStr pin input + hClose pin + output <- hGetContents pout + when (output==output) $ return () + hClose pout + hClose perr + waitForProcess ph + return output + +-- wait is in us +runProcessWithInputAndWait :: FilePath -> [String] -> String -> Int -> IO () +runProcessWithInputAndWait cmd args input timeout = do + pid <- forkProcess $ do + forkProcess $ do -- double fork it over to init + createSession + (pin, pout, perr, ph) <- runInteractiveProcess cmd args Nothing Nothing + hPutStr pin input + hFlush pin + threadDelay timeout + hClose pin + hClose pout + hClose perr + waitForProcess ph + return () + exitWith ExitSuccess + return () + getProcessStatus True False pid + return () + +{- | Multiplies by ONE MILLION, for use with runProcessWithInputAndWait. + Use like: + > (5.5 `seconds`) +-} +seconds :: Rational -> Int +seconds = fromEnum . (* 1000000) + +{- | safeSpawn bypasses XMonad's 'spawn' command, because spawn passes strings to /bin/sh to be interpreted as shell + commands. This is often what one wants, but in many cases the passed string will contain shell metacharacters + which one does not want interpreted as such (URLs particularly often have shell metacharacters like '&' in them). + In this case, it is more useful to specify a file or program to be run and a string to give it as an argument so + as to bypass the shell and be certain the program will receive the string as you typed it. + unsafeSpawn is an alias for XMonad's 'spawn', to remind one that use of it can be, well, unsafe. + Examples: + > , ((modMask, xK_Print ), unsafeSpawn "import -window root png:$HOME/xwd-$(date +%s)$$.png") + > , ((modMask, xK_d ), safeSpawn "firefox" "") + + Note that the unsafeSpawn example must be unsafe and not safe because it makes use of shell interpretation by relying on + $HOME and interpolation, whereas the safeSpawn example can be safe because Firefox doesn't need any arguments if it is + just being started. +-} +safeSpawn :: FilePath -> String -> X () +safeSpawn prog arg = io (try (forkProcess $ executeFile prog True [arg] Nothing) >> return ()) +unsafeSpawn :: String -> X () +unsafeSpawn = spawn + +-- | Run a given program in the preferred terminal emulator. This uses safeSpawn. +safeRunInTerm :: String -> X () +safeRunInTerm command = asks (terminal . config) >>= \t -> safeSpawn t ("-e " ++ command) + +unsafeRunInTerm, runInTerm :: String -> X () +unsafeRunInTerm command = asks (terminal . config) >>= \t -> unsafeSpawn $ t ++ " -e " ++ command +runInTerm = unsafeRunInTerm diff --git a/XMonad/Util/XSelection.hs b/XMonad/Util/XSelection.hs new file mode 100644 index 0000000..00d6723 --- /dev/null +++ b/XMonad/Util/XSelection.hs @@ -0,0 +1,175 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonadContrib.XSelection +-- Copyright : (C) 2007 Andrea Rossato, Matthew Sackman +-- License : BSD3 +-- +-- Maintainer : Andrea Rossato <andrea.rossato@unibz.it>, +-- Matthew Sackman <matthew@wellquite.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A module for accessing and manipulating the X Window mouse selection (used in copy and pasting). +-- getSelection and putSelection are adaptations of Hxsel.hs and Hxput.hs from XMonad-utils, available: +-- +-- $ darcs get "http:\/\/gorgias.mine.nu\/repos\/xmonad-utils" +----------------------------------------------------------------------------- + +module XMonad.Util.XSelection ( + -- * Usage + -- $usage + getSelection, + promptSelection, + safePromptSelection, + putSelection) where + +import Graphics.X11.Xlib.Extras (Graphics.X11.Xlib.Extras.Event(ev_event_display, + ev_time, ev_property, ev_target, ev_selection, + ev_requestor, ev_event_type), + xConvertSelection, xGetSelectionOwner, xSetSelectionOwner, getEvent, + currentTime, setSelectionNotify, getWindowProperty8, changeProperty8, + propModeReplace) +import Graphics.X11.Xlib (destroyWindow, createSimpleWindow, Display, XEventPtr, + sendEvent, nextEvent, sync, allocaXEvent, openDisplay, rootWindow, + defaultScreen, internAtom, Atom, selectionNotify, selectionRequest, noEventMask) +import Control.Concurrent (forkIO) +import Control.Exception as E (catch) +import Control.Monad(Monad (return, (>>)), Functor(..), liftM, join) +import Data.Char (chr, ord) +import Data.Maybe (fromMaybe) +import Foreign(Word8, Data.Bits.Bits (shiftL, (.&.), (.|.))) +import XMonad.Util.Run (safeSpawn, unsafeSpawn) +import XMonad (X, io) + +{- $usage + Add 'import XMonadContrib.XSelection' to the top of Config.hs + Then make use of getSelection or promptSelection as needed; if + one wanted to run Firefox with the selection as an argument (say, + the selection is an URL you just highlighted), then one could add + to the Config.hs a line like thus: + +> , ((modMask .|. shiftMask, xK_b ), promptSelection "firefox") + + TODO: + + * Fix Unicode handling. Currently it's still better than calling + 'chr' to translate to ASCII, though. + As near as I can tell, the mangling happens when the String is + outputted somewhere, such as via promptSelection's passing through + the shell, or GHCi printing to the terminal. utf-string has IO functions + which can fix this, though I do not know have to use them here. It's + a complex issue; see + <http://www.haskell.org/pipermail/xmonad/2007-September/001967.html> + and <http://www.haskell.org/pipermail/xmonad/2007-September/001966.html>. + + * Possibly add some more elaborate functionality: Emacs' registers are nice. +-} + +-- | Returns a String corresponding to the current mouse selection in X; if there is none, an empty string is returned. Note that this is +-- really only reliable for ASCII text and currently escapes or otherwise mangles more complex UTF-8 characters. +getSelection :: IO String +getSelection = do + dpy <- openDisplay "" + let dflt = defaultScreen dpy + rootw <- rootWindow dpy dflt + win <- createSimpleWindow dpy rootw 0 0 1 1 0 0 0 + p <- internAtom dpy "PRIMARY" True + ty <- E.catch + (E.catch + (internAtom dpy "UTF8_STRING" False) + (\_ -> internAtom dpy "COMPOUND_TEXT" False)) + (\_ -> internAtom dpy "sTring" False) + clp <- internAtom dpy "BLITZ_SEL_STRING" False + xConvertSelection dpy p ty clp win currentTime + allocaXEvent $ \e -> do + nextEvent dpy e + ev <- getEvent e + if ev_event_type ev == selectionNotify + then do res <- getWindowProperty8 dpy clp win + return $ decode . fromMaybe [] $ res + else destroyWindow dpy win >> return "" + +-- | Set the current X Selection to a given String. +putSelection :: String -> IO () +putSelection text = do + dpy <- openDisplay "" + let dflt = defaultScreen dpy + rootw <- rootWindow dpy dflt + win <- createSimpleWindow dpy rootw 0 0 1 1 0 0 0 + p <- internAtom dpy "PRIMARY" True + ty <- internAtom dpy "UTF8_STRING" False + xSetSelectionOwner dpy p win currentTime + winOwn <- xGetSelectionOwner dpy p + if winOwn == win + then do forkIO ((allocaXEvent $ processEvent dpy ty text) >> destroyWindow dpy win) >> return () + else do putStrLn "Unable to obtain ownership of the selection" >> destroyWindow dpy win + return () + where + processEvent :: Display -> Atom -> [Char] -> XEventPtr -> IO () + processEvent dpy ty txt e = do + nextEvent dpy e + ev <- getEvent e + if ev_event_type ev == selectionRequest + then do print ev + -- selection == eg PRIMARY + -- target == type eg UTF8 + -- property == property name or None + allocaXEvent $ \replyPtr -> do + changeProperty8 (ev_event_display ev) + (ev_requestor ev) + (ev_property ev) + ty + propModeReplace + (map (fromIntegral . ord) txt) + setSelectionNotify replyPtr (ev_requestor ev) (ev_selection ev) (ev_target ev) (ev_property ev) (ev_time ev) + sendEvent dpy (ev_requestor ev) False noEventMask replyPtr + sync dpy False + else do putStrLn "Unexpected Message Received" + print ev + processEvent dpy ty text e + +{- | A wrapper around getSelection. Makes it convenient to run a program with the current selection as an argument. +This is convenient for handling URLs, in particular. For example, in your Config.hs you could bind a key to + @promptSelection \"firefox\"@; +this would allow you to highlight a URL string and then immediately open it up in Firefox. + +promptSelection passes strings through the shell; if you do not wish your selected text to be interpreted/mangled +by the shell, use safePromptSelection which will bypass the shell using safeSpawn from Run.hs; see Run.hs for more +details on the advantages/disadvantages of this. -} +promptSelection, safePromptSelection, unsafePromptSelection :: String -> X () +promptSelection = unsafePromptSelection +safePromptSelection app = join $ io $ liftM (safeSpawn app) (getSelection) +unsafePromptSelection app = join $ io $ liftM unsafeSpawn $ fmap (\x -> app ++ " " ++ x) getSelection + +{- UTF-8 decoding for internal use in getSelection. This code is copied from Eric Mertens's utf-string library + <http://code.haskell.org/utf8-string/> (version 0.1), which is BSD-3 licensed, as is this module. + It'd be better to just import Codec.Binary.UTF8.String (decode), but then users of this would need to install it; Xmonad has enough + dependencies already. -} +decode :: [Word8] -> String +decode [ ] = "" +decode (c:cs) + | c < 0x80 = chr (fromEnum c) : decode cs + | c < 0xc0 = replacement_character : decode cs + | c < 0xe0 = multi_byte 1 0x1f 0x80 + | c < 0xf0 = multi_byte 2 0xf 0x800 + | c < 0xf8 = multi_byte 3 0x7 0x10000 + | c < 0xfc = multi_byte 4 0x3 0x200000 + | c < 0xfe = multi_byte 5 0x1 0x4000000 + | otherwise = replacement_character : decode cs + where + replacement_character :: Char + replacement_character = '\xfffd' + + multi_byte :: Int -> Word8 -> Int -> [Char] + multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask)) + where + aux :: Int -> [Word8] -> Int -> [Char] + aux 0 rs acc + | overlong <= acc && acc <= 0x10ffff && + (acc < 0xd800 || 0xdfff < acc) && + (acc < 0xfffe || 0xffff < acc) = chr acc : decode rs + | otherwise = replacement_character : decode rs + aux n (r:rs) acc + | r .&. 0xc0 == 0x80 = aux (n-1) rs + $ shiftL acc 6 .|. fromEnum (r .&. 0x3f) + aux _ rs _ = replacement_character : decode rs diff --git a/XMonad/Util/XUtils.hs b/XMonad/Util/XUtils.hs new file mode 100644 index 0000000..3986389 --- /dev/null +++ b/XMonad/Util/XUtils.hs @@ -0,0 +1,191 @@ +----------------------------------------------------------------------------- +-- | +-- Module : XMonad.Util.XUtils +-- Copyright : (c) 2007 Andrea Rossato +-- License : BSD-style (see xmonad/LICENSE) +-- +-- Maintainer : andrea.rossato@unibz.it +-- Stability : unstable +-- Portability : unportable +-- +-- A module for painting on the screen +-- +----------------------------------------------------------------------------- + +module XMonad.Util.XUtils ( + -- * Usage: + -- $usage + stringToPixel + , averagePixels + , initFont + , releaseFont + , createNewWindow + , showWindow + , hideWindow + , deleteWindow + , paintWindow + , Align (..) + , stringPosition + , paintAndWrite + ) where + + +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +import Control.Monad.Reader +import Data.Maybe +import XMonad +import XMonad.Operations + +-- $usage +-- See Tabbed or DragPane for usage examples + +-- | Get the Pixel value for a named color: if an invalid name is +-- given the black pixel will be returned. +stringToPixel :: String -> X Pixel +stringToPixel s = do + d <- asks display + io $ catch (getIt d) (fallBack d) + where getIt d = initColor d s + fallBack d = const $ return $ blackPixel d (defaultScreen d) + +-- | Compute the weighted average the colors of two given Pixel values. +averagePixels :: Pixel -> Pixel -> Double -> X Pixel +averagePixels p1 p2 f = + do d <- asks display + let cm = defaultColormap d (defaultScreen d) + [Color _ r1 g1 b1 _,Color _ r2 g2 b2 _] <- io $ queryColors d cm [Color p1 0 0 0 0,Color p2 0 0 0 0] + let mn x1 x2 = round (fromIntegral x1 * f + fromIntegral x2 * (1-f)) + Color p _ _ _ _ <- io $ allocColor d cm (Color 0 (mn r1 r2) (mn g1 g2) (mn b1 b2) 0) + return p + +-- | Given a fontname returns the fonstructure. If the font name is +-- not valid the default font will be loaded and returned. +initFont :: String -> X FontStruct +initFont s = do + d <- asks display + io $ catch (getIt d) (fallBack d) + where getIt d = loadQueryFont d s + fallBack d = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + +releaseFont :: FontStruct -> X () +releaseFont fs = do + d <- asks display + io $ freeFont d fs + +-- | Create a simple window given a rectangle. If Nothing is given +-- only the exposureMask will be set, otherwise the Just value. +-- Use 'showWindow' to map and hideWindow to unmap. +createNewWindow :: Rectangle -> Maybe EventMask -> String -> X Window +createNewWindow (Rectangle x y w h) m col = do + d <- asks display + rw <- asks theRoot + c <- stringToPixel col + win <- io $ createSimpleWindow d rw x y w h 0 c c + case m of + Just em -> io $ selectInput d win em + Nothing -> io $ selectInput d win exposureMask + return win + +-- | Map a window +showWindow :: Window -> X () +showWindow w = do + d <- asks display + io $ mapWindow d w + +-- | unmap a window +hideWindow :: Window -> X () +hideWindow w = do + d <- asks display + io $ unmapWindow d w + +-- | destroy a window +deleteWindow :: Window -> X () +deleteWindow w = do + d <- asks display + io $ destroyWindow d w + +-- | Fill a window with a rectangle and a border +paintWindow :: Window -- ^ The window where to draw + -> Dimension -- ^ Window width + -> Dimension -- ^ Window height + -> Dimension -- ^ Border width + -> String -- ^ Window background color + -> String -- ^ Border color + -> X () +paintWindow w wh ht bw c bc = + paintWindow' w (Rectangle 0 0 wh ht) bw c bc Nothing + +-- | String position +data Align = AlignCenter | AlignRight | AlignLeft + +-- | Return the string x and y 'Position' in a 'Rectangle', given a +-- 'FontStruct' and the 'Align'ment +stringPosition :: FontStruct -> Rectangle -> Align -> String -> (Position,Position) +stringPosition fs (Rectangle _ _ w h) al s = (x,y) + where width = textWidth fs s + (_,a,d,_) = textExtents fs s + y = fi $ ((h - fi (a + d)) `div` 2) + fi a + x = case al of + AlignCenter -> fi (w `div` 2) - fi (width `div` 2) + AlignLeft -> 1 + AlignRight -> fi (w - (fi width + 1)) + +-- | Fill a window with a rectangle and a border, and write a string at given position +paintAndWrite :: Window -- ^ The window where to draw + -> FontStruct -- ^ The FontStruct + -> Dimension -- ^ Window width + -> Dimension -- ^ Window height + -> Dimension -- ^ Border width + -> String -- ^ Window background color + -> String -- ^ Border color + -> String -- ^ String color + -> String -- ^ String background color + -> Align -- ^ String 'Align'ment + -> String -- ^ String to be printed + -> X () +paintAndWrite w fs wh ht bw bc borc ffc fbc al str = + paintWindow' w r bw bc borc ms + where ms = Just (fs,ffc,fbc,str) + r = Rectangle x y wh ht + (x,y) = stringPosition fs (Rectangle 0 0 wh ht) al str + +-- This stuf is not exported + +paintWindow' :: Window -> Rectangle -> Dimension -> String -> String -> Maybe (FontStruct,String,String,String) -> X () +paintWindow' win (Rectangle x y wh ht) bw color b_color str = do + d <- asks display + p <- io $ createPixmap d win wh ht (defaultDepthOfScreen $ defaultScreenOfDisplay d) + gc <- io $ createGC d p + -- draw + io $ setGraphicsExposures d gc False + [c',bc'] <- mapM stringToPixel [color,b_color] + -- we start with the border + io $ setForeground d gc bc' + io $ fillRectangle d p gc 0 0 wh ht + -- and now again + io $ setForeground d gc c' + io $ fillRectangle d p gc (fi bw) (fi bw) ((wh - (bw * 2))) (ht - (bw * 2)) + when (isJust str) $ do + let (fs,fc,bc,s) = fromJust str + io $ setFont d gc $ fontFromFontStruct fs + printString d p gc fc bc x y s + -- copy the pixmap over the window + io $ copyArea d p win gc 0 0 wh ht 0 0 + -- free the pixmap and GC + io $ freePixmap d p + io $ freeGC d gc + +-- | Prints a string on a 'Drawable' +printString :: Display -> Drawable -> GC -> String -> String + -> Position -> Position -> String -> X () +printString d drw gc fc bc x y s = do + [fc',bc'] <- mapM stringToPixel [fc,bc] + io $ setForeground d gc fc' + io $ setBackground d gc bc' + io $ drawImageString d drw gc x y s + +-- | Short-hand for 'fromIntegral' +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral |