XPrompt: a module for easily writing graphical prompts

darcs-hash:20070802171552-32816-2fa9aa8feda763ffb7d7ad4e9be344e96318bd5b.gz

1 files changed, 512 insertions, 0 deletions

diff --git a/XPrompt.hs b/XPrompt.hs
new file mode 100644
index 0000000..cdc6890
--- /dev/null
+++ b/XPrompt.hs
@@ -0,0 +1,512 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  XMonadContrib.XPrompt
+-- Copyright   :  (C) 2007 Andrea Rossato
+-- License     :  BSD3
+-- 
+-- Maintainer  :  andrea.rossato@unibz.it
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- A module for writing graphical prompts for XMonad
+--
+-----------------------------------------------------------------------------
+
+module XMonadContrib.XPrompt (
+                             -- * Usage
+                             -- $usage
+                             mkXPrompt
+                             , defaultPromptConfig
+                             , mkComplFunFromList
+                             , XPType (..)
+                             , XPPosition (..)
+                             , XPConfig (..)
+                             , XPrompt (..)
+                             ) where
+
+import Graphics.X11.Xlib
+import Graphics.X11.Xlib.Extras
+import XMonad  hiding (io)
+import Operations
+
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.Bits
+import Data.Char
+import Data.Maybe
+import Data.List
+
+
+-- $usage:
+--
+-- For example usage see XMonadContrib.ShellPrompt or
+-- XMonadContrib.XMonadPrompt
+
+
+type XP = StateT XPState IO
+
+data XPState =
+    XPS { dpy :: Display    
+        , rootw :: Window   
+        , win :: Window
+        , complWin :: Maybe Window
+        , complWinDim :: Maybe ComplWindowDim
+        , completionFunction :: String -> IO [String]
+        , compList :: Maybe [String]
+        , gcon :: GC
+        , fs :: FontStruct 
+        , xptype :: XPType
+        , command :: String 
+        , offset :: Int     
+        , config :: XPConfig
+        }
+
+data XPConfig =  
+    XPC { font           :: String   -- ^ Font
+        , bgColor        :: String   -- ^ Backgroud color
+        , fgColor        :: String   -- ^ Default font color
+        , hLight         :: String   -- ^ Default font color
+        , borderColor    :: String   -- ^ 
+        , borderWidth    :: Dimension
+        , position       :: XPPosition
+        , height         :: Dimension      -- ^ Window height
+        } deriving (Show, Read)
+
+data XPType = forall p . XPrompt p => XPT p 
+
+instance Show XPType where
+    show (XPT p) = showXPrompt p
+
+instance XPrompt XPType where
+    showXPrompt = show
+
+class XPrompt t where
+    showXPrompt :: t -> String
+
+data XPPosition = Top 
+                | Bottom
+                  deriving (Show,Read)
+
+defaultPromptConfig :: XPConfig
+defaultPromptConfig =
+    XPC { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
+        , bgColor = "#666666"
+        , fgColor = "#FFFFFF"
+        , hLight = "#999999"
+        , borderColor = "#FFFFFF"
+        , borderWidth = 1
+        , position = Bottom
+        , height = 18
+        }
+
+type ComplFunction = String -> IO [String]
+
+initState :: XPrompt p => Display -> Window -> Window -> ComplFunction
+          -> GC -> FontStruct -> p -> XPConfig -> XPState
+initState d rw w compl gc f pt c =
+    XPS d rw w Nothing Nothing compl Nothing gc f (XPT pt) "" 0 c
+
+mkXPrompt :: XPrompt p => p -> XPConfig -> ComplFunction -> (String -> X ())  -> X ()
+mkXPrompt t conf compl action = do
+  c <- ask
+  let d = display c
+      rw = theRoot c
+  w <- liftIO $ createWin d rw conf
+  liftIO $ selectInput d w $ exposureMask .|. keyPressMask
+  gc <- liftIO $ createGC d w
+  liftIO $ setGraphicsExposures d gc False
+  fontS <- liftIO $ loadQueryFont d (font conf)
+
+  let st = initState d rw w compl gc fontS (XPT t) conf
+  st' <- liftIO $ execStateT runXP st
+
+  liftIO $ freeGC d gc
+  liftIO $ freeFont d fontS
+  action (command st')
+
+runXP :: XP ()
+runXP = do
+  st <- get
+  let d = dpy st
+      w = win st
+  status <- io $ grabKeyboard d w True grabModeAsync grabModeAsync currentTime
+  when (status == grabSuccess) $ do
+            updateWin
+            io $ ungrabKeyboard d currentTime
+  io $ destroyWindow d w
+  destroyComplWin
+  io $ sync d False
+
+eventLoop :: XP ()
+eventLoop = do
+  d <- gets dpy
+  (keysym,string,event) <- io $ 
+            allocaXEvent $ \e -> do 
+              nextEvent d e
+              ev <- getEvent e
+              (ks,s) <- lookupString $ asKeyEvent e
+              return (ks,s,ev)
+  handle (fromMaybe xK_VoidSymbol keysym,string) event
+
+type KeyStroke = (KeySym, String)
+
+-- Main event handler
+handle :: KeyStroke -> Event -> XP ()
+handle ks (KeyEvent {ev_event_type = t, ev_state = m}) 
+    | t == keyPress = do
+  keyPressHandle m ks
+handle _ (AnyEvent {ev_event_type = t, ev_window = w}) 
+    | t == expose = do 
+  st <- get
+  when (win st == w) updateWin                 
+handle _  _ = eventLoop
+
+-- KeyPresses
+
+data Direction = Prev | Next deriving (Eq,Show,Read)
+
+keyPressHandle :: KeyMask -> KeyStroke -> XP ()
+-- commands: ctrl + ... todo
+keyPressHandle mask (ks,s)
+    | mask == controlMask = do
+  -- TODO
+  eventLoop
+
+keyPressHandle _ (ks,_)
+-- exit
+    | ks == xK_Return = do
+  return ()
+-- backspace
+    | ks == xK_BackSpace = do
+  deleteString Prev
+  updateWin
+-- delete
+    | ks == xK_Delete = do
+  deleteString Next
+  updateWin
+-- left
+    | ks == xK_Left = do
+  moveCursor Prev
+  updateWin
+-- right
+    | ks == xK_Right = do
+  moveCursor Next
+  updateWin
+-- exscape: exit and discard everything
+    | ks  == xK_Escape = do
+  flushString
+  return ()
+-- tab -> completion loop
+    | ks  == xK_Tab = do
+  completionLoop
+  --eventLoop
+
+-- insert a character
+keyPressHandle _ (_,s)
+    | s == "" = eventLoop
+    | otherwise = do
+  insertString s
+  updateWin
+
+-- KeyPress and State
+
+-- |  Flush the command string and reset the offest
+flushString :: XP ()
+flushString =
+  modify (\s -> s { command = "", offset = 0} )  
+ 
+-- | Insert a character at the cursor position
+insertString :: String -> XP ()
+insertString str = 
+  modify (\s -> s { command = c (command s) (offset s), offset = o (offset s)} )
+  where o oo = oo + length str
+        c oc oo
+            | oo >= length oc = oc ++ str
+            | otherwise = f ++ str ++ ss
+            where (f,ss) = splitAt oo oc
+
+-- | Remove a character at the cursor position
+deleteString :: Direction -> XP ()
+deleteString d =
+  modify (\s -> s { command = c (command s) (offset s), offset = o (offset s)} )
+  where o oo = if d == Prev then max 0 (oo - 1) else oo
+        c oc oo
+            | oo >= length oc && d == Prev = take (oo - 1) oc
+            | oo < length oc && d == Prev = take (oo - 1) f ++ ss
+            | oo < length oc && d == Next = f ++ tail ss
+            | otherwise = oc
+            where (f,ss) = splitAt oo oc
+
+-- | move the cursor one position
+moveCursor :: Direction -> XP ()
+moveCursor d =
+  modify (\s -> s { offset = o (offset s) (command s)} )
+  where o oo c = if d == Prev then max 0 (oo - 1) else min (length c) (oo + 1)
+
+
+-- X Stuff
+
+createWin :: Display -> Window -> XPConfig -> IO Window
+createWin d rw c = do
+  let scr = defaultScreenOfDisplay d
+      wh = widthOfScreen scr
+      (x,y) = case position c of
+                Top -> (0,0)
+                Bottom -> (0,heightOfScreen scr - (height c))
+  w <- mkUnmanagedWindow d scr rw 
+                      x (fi y) wh (height c)
+  mapWindow d w
+  return w
+
+updateWin :: XP ()
+updateWin = do
+  st <- get
+  drawWin
+  compl <- getCompletions (command st)
+  nwi <- getComplWinDim compl
+  let recreate = do destroyComplWin
+                    w <- createComplWin nwi
+                    drawComplWin w compl
+  -- check if we have to recreate the completion window
+  if (compl /= [] )
+     then case complWin st of
+            Just w -> case complWinDim st of
+                        Just wi -> if nwi == wi -- complWinDim did not change
+                                   then drawComplWin w compl -- so update
+                                   else recreate
+                        Nothing -> recreate
+            Nothing -> recreate
+     else destroyComplWin
+  io $ sync (dpy st) False
+  eventLoop
+
+drawWin :: XP ()
+drawWin = do
+  st <- get
+  let c = config st
+      d = dpy st
+      scr = defaultScreenOfDisplay d
+      w = win st
+      wh = widthOfScreen scr
+      ht = height c
+      bw = borderWidth c
+      gc = gcon st
+      fontStruc = fs st
+  bgcolor <- io $ initColor d (bgColor c)
+  border <- io $ initColor d (borderColor c)
+  p <- io $ createPixmap d w wh ht
+                         (defaultDepthOfScreen scr)
+  io $ fillDrawable d p gc border bgcolor (fi bw) wh ht
+  printPrompt p gc fontStruc
+  io $ copyArea d p w gc 0 0 wh ht 0 0
+  io $ freePixmap d p
+
+printPrompt :: Drawable -> GC -> FontStruct -> XP ()
+printPrompt drw gc fontst = do
+  c <- gets config
+  st <- get
+  let d = dpy st
+      (prt,com,off) = (show (xptype st), command st, offset st)
+      str = prt ++ com
+      -- scompose the string in 3 part: till the cursor, the cursor and the rest
+      (f,p,ss) = if off >= length com
+                 then (str, " ","") -- add a space: it will be our cursor ;-)
+                 else let (a,b) = (splitAt off com) 
+                      in (prt ++ a, [head b], tail b)
+      ht = height c
+      (fsl,psl) = (textWidth fontst f, textWidth fontst p)
+      (_,asc,desc,_) = textExtents fontst str
+      y = fi $ (ht + fi (asc + desc)) `div` 2
+      x = (asc + desc) `div` 2
+  fgcolor <- io $ initColor d $ fgColor c
+  bgcolor <- io $ initColor d $ bgColor c
+  -- print the first part
+  io $ printString d drw gc fgcolor bgcolor x y f
+  -- reverse the colors and print the "cursor" ;-)
+  io $ printString d drw gc bgcolor fgcolor (x + fsl) y p
+  -- reverse the colors and print the rest of the string
+  io $ printString d drw gc fgcolor bgcolor (x + fsl + psl) y ss
+
+
+-- Completions
+
+getCompletions :: String -> XP [String]
+getCompletions s = do
+  cf <- gets completionFunction 
+  c <- io $ cf s
+  setComplList c
+  return c
+
+setComplWin :: Window -> ComplWindowDim -> XP ()
+setComplWin w wi =
+  modify (\s -> s { complWin = Just w, complWinDim = Just wi })
+
+setComplList :: [String] -> XP ()
+setComplList l =
+  modify (\s -> s { compList = Just l })
+
+destroyComplWin :: XP ()
+destroyComplWin = do
+  d <- gets dpy
+  cw <- gets complWin
+  case cw of
+    Just w -> do io $ destroyWindow d w
+                 modify (\s -> s { complWin = Nothing, complWinDim = Nothing, compList = Nothing })
+    Nothing -> return ()
+
+completionLoop :: XP ()
+completionLoop = do
+  cl <- gets compList
+  let nc oc | oc == [] = []
+            | otherwise = head $ fromMaybe [oc] cl 
+  case cl of
+    Just (l:_) -> do modify (\s -> s { command = l, offset = length l })
+                     updateWin
+    _ -> eventLoop
+
+type ComplWindowDim = (Position,Position,Dimension,Dimension,Rows,Columns)
+type Rows = [Position]
+type Columns = [Position]
+
+createComplWin :: ComplWindowDim -> XP Window
+createComplWin wi@(x,y,wh,ht,_,_) = do
+  st <- get
+  let d = dpy st
+      scr = defaultScreenOfDisplay d
+  w <- io $ mkUnmanagedWindow d scr (rootw st)
+                      x y wh ht
+  io $ mapWindow d w
+  setComplWin w wi
+  return w
+
+getComplWinDim :: [String] -> XP ComplWindowDim
+getComplWinDim compl = do
+  st <- get
+  let c = config st
+      d = dpy st
+      scr = defaultScreenOfDisplay d
+      wh = widthOfScreen scr
+      ht = height c
+      fontst = fs st
+
+  let compl_number = length compl
+      max_compl_len =  (fi ht `div` 2) + (maximum . map (textWidth fontst) $ compl)
+      columns = wh `div` (fi max_compl_len)
+      rem_height =  heightOfScreen scr - ht
+      needed_rows = max 1 (compl_number `div` fi columns)
+      actual_max_number_of_rows = rem_height `div` ht
+      actual_rows = min actual_max_number_of_rows (fi needed_rows)
+      actual_height = actual_rows * ht
+      (x,y) = case position c of
+                Top -> (0,ht)
+                Bottom -> (0, (0 + rem_height - actual_height))
+
+  let (_,asc,desc,_) = textExtents fontst $ head compl
+      yp = fi $ (ht + fi (asc + desc)) `div` 2
+      xp = (asc + desc) `div` 2
+      yy = map fi . take (fi actual_rows) $ [yp,(yp + ht)..]
+      xx = take (fi columns) [xp,(xp + max_compl_len)..]
+
+  return (x, fi y, wh, actual_height, xx, yy)
+
+drawComplWin :: Window -> [String] -> XP ()
+drawComplWin w compl = do
+  st <- get
+  let c = config st
+      d = dpy st
+      scr = defaultScreenOfDisplay d
+      bw = borderWidth c
+      gc = gcon st
+  bgcolor <- io $ initColor d (bgColor c)
+  fgcolor <- io $ initColor d (fgColor c)
+  border <- io $ initColor d (borderColor c)
+
+  (_,_,wh,ht,xx,yy) <- getComplWinDim compl
+
+  p <- io $ createPixmap d w wh ht
+                         (defaultDepthOfScreen scr)
+  io $ fillDrawable d p gc border bgcolor (fi bw) wh ht
+  let ac = splitInSubListsAt (length yy) (take ((length xx) * (length yy)) compl)
+  printComplList d p gc fgcolor bgcolor xx yy ac
+  io $ copyArea d p w gc 0 0 wh ht 0 0
+  io $ freePixmap d p
+
+printComplList :: Display -> Drawable -> GC -> Pixel -> Pixel
+               -> [Position] -> [Position] -> [[String]] -> XP ()
+printComplList _ _ _ _ _ _ _ [] = return ()
+printComplList _ _ _ _ _ [] _ _ = return ()
+printComplList d drw gc fc bc (x:xs) y (s:ss) = do
+  printComplColumn d drw gc fc bc x y s
+  printComplList d drw gc fc bc xs y ss
+
+printComplColumn :: Display -> Drawable -> GC -> Pixel -> Pixel
+                 -> Position -> [Position] -> [String] -> XP ()
+printComplColumn _ _ _ _ _ _ _ [] = return ()
+printComplColumn _ _ _ _ _ _ [] _ = return ()
+printComplColumn d drw gc fc bc x (y:yy) (s:ss) = do
+  printComplString d drw gc fc bc x y s
+  printComplColumn d drw gc fc bc x yy ss
+
+printComplString :: Display -> Drawable -> GC -> Pixel -> Pixel
+                 -> Position -> Position -> String  -> XP ()
+printComplString d drw gc fc bc x y s = do
+  st <- get
+  if s == command st
+     then do c <- io $ initColor d (hLight $ config st)
+             io $ printString d drw gc fc c x y s
+     else io $ printString d drw gc fc bc x y s
+
+-- More general X Stuff
+
+printString :: Display -> Drawable -> GC -> Pixel -> Pixel
+            -> Position -> Position -> String  -> IO ()
+printString d drw gc fc bc x y s = do
+  setForeground d gc fc
+  setBackground d gc bc
+  drawImageString d drw gc x y s
+
+fillDrawable :: Display -> Drawable -> GC -> Pixel -> Pixel
+             -> Dimension -> Dimension -> Dimension -> IO ()
+fillDrawable d drw gc border bgcolor bw wh ht = do
+  -- we strat with the border
+  setForeground d gc border
+  fillRectangle d drw gc 0 0 wh ht
+  -- this foreground is the background of the text
+  setForeground d gc bgcolor
+  fillRectangle d drw gc (fi bw) (fi bw) (wh - (bw * 2)) (ht - (bw * 2))
+
+-- | Creates a window with the attribute override_redirect set to True.
+-- Windows Managers should not touch this kind of windows.
+mkUnmanagedWindow :: Display -> Screen -> Window -> Position 
+                  -> Position -> Dimension -> Dimension -> IO Window
+mkUnmanagedWindow d s rw x y w h = do
+  let visual = defaultVisualOfScreen s
+      attrmask = cWOverrideRedirect
+  allocaSetWindowAttributes $ 
+         \attributes -> do
+           set_override_redirect attributes True
+           createWindow d rw x y w h 0 (defaultDepthOfScreen s) 
+                        inputOutput visual attrmask attributes
+
+-- Utilities
+
+-- completions
+mkComplFunFromList :: [String] -> String -> IO [String]
+mkComplFunFromList _ [] = return []
+mkComplFunFromList l s =
+  return $ filter (\x -> take (length s) x == s) l
+
+
+-- Lift an IO action into the XP
+io :: IO a -> XP a
+io = liftIO
+
+-- shorthand
+fi :: (Num b, Integral a) => a -> b
+fi = fromIntegral
+
+splitInSubListsAt :: Int -> [a] -> [[a]]
+splitInSubListsAt _ [] = []
+splitInSubListsAt i x = f : splitInSubListsAt i rest
+    where (f,rest) = splitAt i x
+