-----------------------------------------------------------------------------
-- |
-- Module      :  XMonadContrib.Commands
-- Copyright   :  (C) 2007 Andrea Rossato
-- License     :  BSD3
-- 
-- Maintainer  :  andrea.rossato@unibz.it
-- Stability   :  unstable
-- Portability :  unportable
--
-- A prompt for XMonad
--
-----------------------------------------------------------------------------

module XMonadContrib.Prompt (
                             -- * Usage
                             -- $usage
                             startPrompt
                            , defaultPromptConfig
                            , XPType (..)
                            , XPPosition (..)
                            , XPConfig (..)
                              ) where
{-
usage:
in Config.hs add:
> import XMonadContrib.Prompt

in you keybindings add:

>   , ((modMask .|. controlMask, xK_x), xmonadPrompt defaultPromptConfig)
>   , ((modMask .|. controlMask.|. shiftMask, xK_x), shellPrompt  defaultPromptConfig)

-}

import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras
import XMonad  hiding (io)
import Operations
import XMonadContrib.Commands

--import Control.Monad
--import Control.Concurrent

import Control.Monad.Reader
import Control.Monad.State
import Data.Bits
import Data.Char
import Data.Maybe
import Data.List
import System.Console.Readline
import System.Environment

type XP = StateT XPState IO

data XPState = 
    XPS { dpy :: Display    
        , rootw :: Window   
        , win :: Window
        , complWin :: Maybe Window
        , gcon :: GC
        , fs :: FontStruct 
        , xptype :: XPType
        , command :: String 
        , offset :: Int     
        , config :: XPConfig
        } deriving (Show)

data XPConfig = 
    XPC { font           :: String   -- ^ Font
        , bgColor        :: String   -- ^ Backgroud color
        , fgColor        :: String   -- ^ Default font color
        , borderColor    :: String   -- ^ 
        , borderWidth    :: Dimension
        , position       :: XPPosition
        , height         :: Dimension      -- ^ Window height
        } deriving (Show, Read)

data XPType = Shell | XMonad
            deriving (Read)

instance Show XPType where
    show Shell = "Run:   "
    show XMonad = "XMonad:   "

data XPPosition = Top | Bottom
                deriving (Show,Read)

defaultPromptConfig :: XPConfig
defaultPromptConfig =
    XPC { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
        , bgColor = "#999999"
        , fgColor = "#FFFFFF"
        , borderColor = "#FFFFFF"
        , borderWidth = 1
        , position = Bottom
        , height = 18
        }

initState :: Display -> Window -> Window -> GC 
          -> FontStruct -> XPType -> XPConfig-> XPState
initState d rw w gc f pt c =
    XPS d rw w Nothing gc f pt "" 0 c

shellPrompt :: XPConfig -> X ()
shellPrompt c = startPrompt Shell c
 
xmonadPrompt :: XPConfig -> X ()
xmonadPrompt c = startPrompt XMonad c

startPrompt :: XPType -> XPConfig -> X ()
startPrompt t conf = 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 gc fontS t conf
  st' <- liftIO $ execStateT runXP st

  liftIO $ freeGC d gc
  liftIO $ freeFont d fontS
  case t of 
    XMonad -> runCommand' $ command st'
    Shell -> spawn $ 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
  -- FIXME 
  --st <- get
  --io $ putStrLn $ "offset = " ++ show (offset st) ++ "str: " ++ (prompt st ++ command st)
  (keysym,string,event) <- io $ 
            allocaXEvent $ \e -> do 
              nextEvent d e
              ev <- getEvent e
              -- FIXME 
              --putStrLn $ eventName ev
              (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 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
  d <- gets dpy
  destroyComplWin
  drawWin
  io $ sync d 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
  compl <- case xptype st of
             Shell -> io $ getCompletions (command st)
             XMonad -> return []

  when (compl /= []) (drawComplWin compl)

  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

setComplWin :: Window -> XP ()
setComplWin w = do
  modify (\s -> s { complWin = Just w })

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 })
    Nothing -> return ()

drawComplWin :: [String] -> XP ()
drawComplWin compl = do
  st <- get
  let c = config st
      d = dpy st
      scr = defaultScreenOfDisplay d
      wh = widthOfScreen scr
      ht = height c
      bw = borderWidth c
      gc = gcon st
      fontst = fs st
  bgcolor <- io $ initColor d (bgColor c)
  fgcolor <- io $ initColor d (fgColor c)
  border <- io $ initColor d (borderColor c)

  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)
      needed_height = needed_rows * fi ht
      actual_max_number_of_rows = rem_height `div` ht
      actual_completions = if needed_height > fi rem_height 
                           then take (fi (actual_max_number_of_rows * columns)) compl
                           else compl
      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))

  w <- io $ mkUnmanagedWindow d scr (rootw st)
                      x (fi y) wh actual_height
  io $ mapWindow d w
  setComplWin w
  io $ fillDrawable d w gc border bgcolor (fi bw) wh actual_height
  -- creating a table of completions...;-)
  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)..]
      ac = spliInSubListsAt (fi actual_rows) actual_completions
  -- printing the table of completion
  io $ printComplList d w gc fgcolor bgcolor xx yy ac

printComplList :: Display -> Drawable -> GC -> Pixel -> Pixel
               -> [Position] -> [Position] -> [[String]] -> IO ()
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] -> IO ()
printComplColumn _ _ _ _ _ _ _ [] = return ()
printComplColumn _ _ _ _ _ _ [] _ = return ()
printComplColumn d drw gc fc bc x (y:yy) (s:ss) = do
  printString d drw gc fc bc x y s
  printComplColumn d drw gc fc bc x yy ss

-- 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
getCompletions :: String -> IO [String]
getCompletions s 
    | s /= "" && last s /= ' ' = do
  fl <- filenameCompletionFunction (last . words $ s)
  c <- commandCompletionFunction (last . words $ s)
  return $ sort . nub $ fl ++ c
    | otherwise = return []

commandCompletionFunction :: String -> IO [String]
commandCompletionFunction str 
    | '/' `elem` str = return []
    | otherwise = do
  p <- getEnv "PATH"
  cl p
    where
      cl = liftM (nub . rmPath . concat) . mapM fCF . map addToPath . split ':'  
      addToPath = flip (++) ("/" ++ str)
      fCF = filenameCompletionFunction
      rmPath [] = []
      rmPath s = map (last . split '/') s

-- Lift an IO action into the XP
io :: IO a -> XP a
io = liftIO

-- shorthand
fi :: (Num b, Integral a) => a -> b
fi = fromIntegral

split :: Eq a => a -> [a] -> [[a]]
split _ [] = []
split e l =
    f : split e (rest ls)
        where 
          (f,ls) = span (/=e) l
          rest s | s == [] = []
                 | otherwise = tail s

spliInSubListsAt :: Int -> [a] -> [[a]]
spliInSubListsAt _ [] = []
spliInSubListsAt i x = f : spliInSubListsAt i rest
    where (f,rest) = splitAt i x