    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE ExistentialQuantification #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  XMonad.Prompt
    -- Copyright   :  (C) 2007 Andrea Rossato, 2015 Evgeny Kurnevsky
    --                    2015 Sibi Prabakaran
    -- License     :  BSD3
    --
    -- Maintainer  :  Spencer Janssen <spencerjanssen@gmail.com>
    -- Stability   :  unstable
    -- Portability :  unportable
    --
    -- A module for writing graphical prompts for XMonad
    --
    -----------------------------------------------------------------------------

    module XMonad.Prompt
        ( -- * Usage
          -- $usage
          mkXPrompt
        , mkXPromptWithReturn
        , mkXPromptWithModes
        , def
        , amberXPConfig
        , defaultXPConfig
        , greenXPConfig
        , XPMode
        , XPType (..)
        , XPPosition (..)
        , XPConfig (..)
        , XPrompt (..)
        , XP
        , defaultXPKeymap, defaultXPKeymap'
        , emacsLikeXPKeymap, emacsLikeXPKeymap'
        , quit
        , killBefore, killAfter, startOfLine, endOfLine
        , pasteString, moveCursor
        , setInput, getInput
        , moveWord, moveWord', killWord, killWord', deleteString
        , moveHistory, setSuccess, setDone
        , Direction1D(..)
        , ComplFunction
        -- * X Utilities
        -- $xutils
        , mkUnmanagedWindow
        , fillDrawable
        -- * Other Utilities
        -- $utils
        , mkComplFunFromList
        , mkComplFunFromList'
        -- * @nextCompletion@ implementations
        , getNextOfLastWord
        , getNextCompletion
        -- * List utilities
        , getLastWord
        , skipLastWord
        , splitInSubListsAt
        , breakAtSpace
        , uniqSort
        , historyCompletion
        , historyCompletionP
        -- * History filters
        , deleteAllDuplicates
        , deleteConsecutive
        , HistoryMatches
        , initMatches
        , historyUpMatching
        , historyDownMatching
        -- * Types
        , XPState
        ) where

    import           XMonad                       hiding (cleanMask, config)
    import qualified XMonad                       as X (numberlockMask)
    import qualified XMonad.StackSet              as W
    import           XMonad.Util.Font
    import           XMonad.Util.Types
    import           XMonad.Util.XSelection       (getSelection)

    import           Codec.Binary.UTF8.String     (decodeString,isUTF8Encoded)
    import           Control.Applicative          ((<$>))
    import           Control.Arrow                (first, (&&&), (***))
    import           Control.Concurrent           (threadDelay)
    import           Control.Exception.Extensible as E hiding (handle)
    import           Control.Monad.State
    import           Data.Bits
    import           Data.Char                    (isSpace)
    import           Data.IORef
    import           Data.List
    import qualified Data.Map                     as M
    import           Data.Maybe                   (fromMaybe)
    import           Data.Set                     (fromList, toList)
    import           System.IO
    import           System.Posix.Files

    -- $usage
    -- For usage examples see "XMonad.Prompt.Shell",
    -- "XMonad.Prompt.XMonad" or "XMonad.Prompt.Ssh"
    --
    -- TODO:
    --
    -- * scrolling the completions that don't fit in the window (?)

    type XP = StateT XPState IO

    data XPState =
        XPS { dpy                :: Display
            , rootw              :: !Window
            , win                :: !Window
            , screen             :: !Rectangle
            , complWin           :: Maybe Window
            , complWinDim        :: Maybe ComplWindowDim
            , complIndex         :: !(Int,Int)
            , showComplWin       :: Bool
            , operationMode      :: XPOperationMode
            , highlightedCompl   :: Maybe String
            , gcon               :: !GC
            , fontS              :: !XMonadFont
            , commandHistory     :: W.Stack String
            , offset             :: !Int
            , config             :: XPConfig
            , successful         :: Bool
            , numlockMask        :: KeyMask
            , done               :: Bool
            }

    data XPConfig =
        XPC { font              :: String     -- ^ Font; use the prefix @"xft:"@ for TrueType fonts
            , bgColor           :: String     -- ^ Background color
            , fgColor           :: String     -- ^ Font color
            , fgHLight          :: String     -- ^ Font color of a highlighted completion entry
            , bgHLight          :: String     -- ^ Background color of a highlighted completion entry
            , borderColor       :: String     -- ^ Border color
            , promptBorderWidth :: !Dimension -- ^ Border width
            , position          :: XPPosition -- ^ Position: 'Top', 'Bottom', or 'CenteredAt'
            , alwaysHighlight   :: !Bool      -- ^ Always highlight an item, overriden to True with multiple modes. This implies having *one* column of autocompletions only.
            , height            :: !Dimension -- ^ Window height
            , maxComplRows      :: Maybe Dimension
                                              -- ^ Just x: maximum number of rows to show in completion window
            , historySize       :: !Int       -- ^ The number of history entries to be saved
            , historyFilter     :: [String] -> [String]
                                             -- ^ a filter to determine which
                                             -- history entries to remember
            , promptKeymap      :: M.Map (KeyMask,KeySym) (XP ())
                                             -- ^ Mapping from key combinations to actions
            , completionKey     :: (KeyMask, KeySym)     -- ^ Key that should trigger completion
            , changeModeKey     :: KeySym     -- ^ Key to change mode (when the prompt has multiple modes)
            , defaultText       :: String     -- ^ The text by default in the prompt line
            , autoComplete      :: Maybe Int  -- ^ Just x: if only one completion remains, auto-select it,
                                              --   and delay by x microseconds
            , showCompletionOnTab :: Bool     -- ^ Only show list of completions when Tab was pressed
            , searchPredicate   :: String -> String -> Bool
                                              -- ^ Given the typed string and a possible
                                              --   completion, is the completion valid?
            }

    data XPType = forall p . XPrompt p => XPT p
    type ComplFunction = String -> IO [String]
    type XPMode = XPType
    data XPOperationMode = XPSingleMode ComplFunction XPType | XPMultipleModes (W.Stack XPType)

    instance Show XPType where
        show (XPT p) = showXPrompt p

    instance XPrompt XPType where
        showXPrompt                 = show
        nextCompletion      (XPT t) = nextCompletion      t
        commandToComplete   (XPT t) = commandToComplete   t
        completionToCommand (XPT t) = completionToCommand t
        completionFunction  (XPT t) = completionFunction  t
        modeAction          (XPT t) = modeAction          t

    -- | The class prompt types must be an instance of. In order to
    -- create a prompt you need to create a data type, without parameters,
    -- and make it an instance of this class, by implementing a simple
    -- method, 'showXPrompt', which will be used to print the string to be
    -- displayed in the command line window.
    --
    -- This is an example of a XPrompt instance definition:
    --
    -- >     instance XPrompt Shell where
    -- >          showXPrompt Shell = "Run: "
    class XPrompt t where

        -- | This method is used to print the string to be
        -- displayed in the command line window.
        showXPrompt :: t -> String

        -- | This method is used to generate the next completion to be
        -- printed in the command line when tab is pressed, given the
        -- string presently in the command line and the list of
        -- completion.
        -- This function is not used when in multiple modes (because alwaysHighlight in XPConfig is True)
        nextCompletion :: t -> String -> [String] -> String
        nextCompletion = getNextOfLastWord

        -- | This method is used to generate the string to be passed to
        -- the completion function.
        commandToComplete :: t -> String -> String
        commandToComplete _ = getLastWord

        -- | This method is used to process each completion in order to
        -- generate the string that will be compared with the command
        -- presently displayed in the command line. If the prompt is using
        -- 'getNextOfLastWord' for implementing 'nextCompletion' (the
        -- default implementation), this method is also used to generate,
        -- from the returned completion, the string that will form the
        -- next command line when tab is pressed.
        completionToCommand :: t -> String -> String
        completionToCommand _ c = c

        -- | When the prompt has multiple modes, this is the function
        -- used to generate the autocompletion list.
        -- The argument passed to this function is given by `commandToComplete`
        -- The default implementation shows an error message.
        completionFunction :: t -> ComplFunction
        completionFunction t = \_ -> return ["Completions for " ++ (showXPrompt t) ++ " could not be loaded"]

        -- | When the prompt has multiple modes (created with mkXPromptWithModes), this function is called
        -- when the user picks an item from the autocompletion list.
        -- The first argument is the prompt (or mode) on which the item was picked
        -- The first string argument is the autocompleted item's text.
        -- The second string argument is the query made by the user (written in the prompt's buffer).
        -- See XMonad/Actions/Launcher.hs for a usage example.
        modeAction :: t -> String -> String -> X ()
        modeAction _ _ _ = return ()

    data XPPosition = Top
                    | Bottom
                    -- | Prompt will be placed in the center horizontally and
                    --   in the certain place of screen vertically. If it's in the upper
                    --   part of the screen, completion window will be placed below(like
                    --   in 'Top') and otherwise above(like in 'Bottom')
                    | CenteredAt { xpCenterY :: Rational
                                 -- ^ Rational between 0 and 1, giving
                                 -- y coordinate of center of the prompt relative to the screen height.
                                 , xpWidth  :: Rational
                                 -- ^ Rational between 0 and 1, giving
                                 -- width of the prompt relatave to the screen width.
                                 }
                      deriving (Show,Read)

    amberXPConfig, defaultXPConfig, greenXPConfig :: XPConfig

    instance Default XPConfig where
      def =
        XPC { font              = "-misc-fixed-*-*-*-*-12-*-*-*-*-*-*-*"
            , bgColor           = "grey22"
            , fgColor           = "grey80"
            , fgHLight          = "black"
            , bgHLight          = "grey"
            , borderColor       = "white"
            , promptBorderWidth = 1
            , promptKeymap      = defaultXPKeymap
            , completionKey     = (0,xK_Tab)
            , changeModeKey     = xK_grave
            , position          = Bottom
            , height            = 18
            , maxComplRows      = Nothing
            , historySize       = 256
            , historyFilter     = id
            , defaultText       = []
            , autoComplete      = Nothing
            , showCompletionOnTab = False
            , searchPredicate   = isPrefixOf
            , alwaysHighlight   = False
            }
    {-# DEPRECATED defaultXPConfig "Use def (from Data.Default, and re-exported from XMonad.Prompt) instead." #-}
    defaultXPConfig = def
    greenXPConfig = def { fgColor = "green", bgColor = "black", promptBorderWidth = 0 }
    amberXPConfig = def { fgColor = "#ca8f2d", bgColor = "black", fgHLight = "#eaaf4c" }

    initState :: Display -> Window -> Window -> Rectangle -> XPOperationMode
              -> GC -> XMonadFont -> [String] -> XPConfig -> KeyMask -> XPState
    initState d rw w s opMode gc fonts h c nm =
        XPS { dpy                = d
            , rootw              = rw
            , win                = w
            , screen             = s
            , complWin           = Nothing
            , complWinDim        = Nothing
            , showComplWin       = not (showCompletionOnTab c)
            , operationMode      = opMode
            , highlightedCompl   = Nothing
            , gcon               = gc
            , fontS              = fonts
            , commandHistory     = W.Stack { W.focus = defaultText c
                                           , W.up    = []
                                           , W.down  = h }
            , complIndex         = (0,0) --(column index, row index), used when `alwaysHighlight` in XPConfig is True
            , offset             = length (defaultText c)
            , config             = c
            , successful         = False
            , done               = False
            , numlockMask        = nm
            }

    -- Returns the current XPType
    currentXPMode :: XPState -> XPType
    currentXPMode st = case operationMode st of
      XPMultipleModes modes -> W.focus modes
      XPSingleMode _ xptype -> xptype

    -- When in multiple modes, this function sets the next mode
    -- in the list of modes as active
    setNextMode :: XPState -> XPState
    setNextMode st = case operationMode st of
      XPMultipleModes modes -> case W.down modes of
        [] -> st -- there is no next mode, return same state
        (m:ms) -> let
          currentMode = W.focus modes
          in st { operationMode = XPMultipleModes W.Stack { W.up = [], W.focus = m, W.down = ms ++ [currentMode]}} --set next and move previous current mode to the of the stack
      _ -> st --nothing to do, the prompt's operation has only one mode

    -- Returns the highlighted item
    highlightedItem :: XPState -> [String] -> Maybe String
    highlightedItem st' completions = case complWinDim st' of
      Nothing -> Nothing -- when there isn't any compl win, we can't say how many cols,rows there are
      Just winDim ->
        let
          (_,_,_,_,xx,yy) = winDim
          complMatrix = splitInSubListsAt (length yy) (take (length xx * length yy) completions)
          (col_index,row_index) = (complIndex st')
        in case completions of
          [] -> Nothing
          _ -> Just $ complMatrix !! col_index !! row_index

    -- this would be much easier with functional references
    command :: XPState -> String
    command = W.focus . commandHistory

    setCommand :: String -> XPState -> XPState
    setCommand xs s = s { commandHistory = (commandHistory s) { W.focus = xs }}

    setHighlightedCompl :: Maybe String -> XPState -> XPState
    setHighlightedCompl hc st = st { highlightedCompl = hc}

    -- | Sets the input string to the given value.
    setInput :: String -> XP ()
    setInput = modify . setCommand

    -- | Returns the current input string. Intented for use in custom keymaps
    -- where the 'get' or similar can't be used to retrieve it.
    getInput :: XP String
    getInput = gets command

    -- | Same as 'mkXPrompt', except that the action function can have
    --   type @String -> X a@, for any @a@, and the final action returned
    --   by 'mkXPromptWithReturn' will have type @X (Maybe a)@.  @Nothing@
    --   is yielded if the user cancels the prompt (by e.g. hitting Esc or
    --   Ctrl-G).  For an example of use, see the 'XMonad.Prompt.Input'
    --   module.
    mkXPromptWithReturn :: XPrompt p => p -> XPConfig -> ComplFunction -> (String -> X a)  -> X (Maybe a)
    mkXPromptWithReturn t conf compl action = do
      XConf { display = d, theRoot = rw } <- ask
      s    <- gets $ screenRect . W.screenDetail . W.current . windowset
      hist <- io readHistory
      w    <- io $ createWin d rw conf s
      io $ selectInput d w $ exposureMask .|. keyPressMask
      gc <- io $ createGC d w
      io $ setGraphicsExposures d gc False
      fs <- initXMF (font conf)
      numlock <- gets $ X.numberlockMask
      let hs = fromMaybe [] $ M.lookup (showXPrompt t) hist
          om = (XPSingleMode compl (XPT t)) --operation mode
          st = initState d rw w s om gc fs hs conf numlock
      st' <- io $ execStateT runXP st

      releaseXMF fs
      io $ freeGC d gc
      if successful st' then do
        let
          prune = take (historySize conf)

        io $ writeHistory $ M.insertWith
          (\xs ys -> prune . historyFilter conf $ xs ++ ys)
          (showXPrompt t)
          (prune $ historyFilter conf [command st'])
          hist
                                    -- we need to apply historyFilter before as well, since
                                    -- otherwise the filter would not be applied if
                                    -- there is no history
          --When alwaysHighlight is True, autocompletion is handled with indexes.
          --When it is false, it is handled depending on the prompt buffer's value
        let selectedCompletion = case alwaysHighlight (config st') of
              False -> command st'
              True -> fromMaybe (command st') $ highlightedCompl st'
        Just <$> action selectedCompletion
        else return Nothing

    -- | Creates a prompt given:
    --
    -- * a prompt type, instance of the 'XPrompt' class.
    --
    -- * a prompt configuration ('def' can be used as a starting point)
    --
    -- * a completion function ('mkComplFunFromList' can be used to
    -- create a completions function given a list of possible completions)
    --
    -- * an action to be run: the action must take a string and return 'XMonad.X' ()
    mkXPrompt :: XPrompt p => p -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
    mkXPrompt t conf compl action = mkXPromptWithReturn t conf compl action >> return ()

    -- | Creates a prompt with multiple modes given:
    --
    -- * A non-empty list of modes
    -- * A prompt configuration
    --
    -- The created prompt allows to switch between modes with `changeModeKey` in `conf`. The modes are
    -- instances of XPrompt. See XMonad.Actions.Launcher for more details
    --
    -- The argument supplied to the action to execute is always the current highlighted item,
    -- that means that this prompt overrides the value `alwaysHighlight` for its configuration to True.
    mkXPromptWithModes :: [XPType] -> XPConfig -> X ()
    mkXPromptWithModes modes conf = do
      XConf { display = d, theRoot = rw } <- ask
      s    <- gets $ screenRect . W.screenDetail . W.current . windowset
      hist <- io readHistory
      w    <- io $ createWin d rw conf s
      io $ selectInput d w $ exposureMask .|. keyPressMask
      gc <- io $ createGC d w
      io $ setGraphicsExposures d gc False
      fs <- initXMF (font conf)
      numlock <- gets $ X.numberlockMask
      let
        defaultMode = head modes
        hs = fromMaybe [] $ M.lookup (showXPrompt defaultMode) hist
        modeStack = W.Stack{ W.focus = defaultMode --current mode
                           , W.up = []
                           , W.down = tail modes --other modes
                           }
        st = initState d rw w s (XPMultipleModes modeStack) gc fs hs conf { alwaysHighlight = True} numlock
      st' <- io $ execStateT runXP st

      releaseXMF fs
      io $ freeGC d gc

      if successful st' then do
        let
          prune = take (historySize conf)

          -- insert into history the buffers value
        io $ writeHistory $ M.insertWith
          (\xs ys -> prune . historyFilter conf $ xs ++ ys)
          (showXPrompt defaultMode)
          (prune $ historyFilter conf [command st'])
          hist

        case operationMode st' of
          XPMultipleModes ms -> let
            action = modeAction $ W.focus ms
            in action (command st') $ (fromMaybe "" $ highlightedCompl st')
          _ -> error "The impossible occurred: This prompt runs with multiple modes but they could not be found." --we are creating a prompt with multiple modes, so its operationMode should have been constructed with XPMultipleMode
        else
          return ()

    runXP :: XP ()
    runXP = do
      (d,w) <- gets (dpy &&& win)
      status <- io $ grabKeyboard d w True grabModeAsync grabModeAsync currentTime
      when (status == grabSuccess) $ do
              updateWindows
              eventLoop handle
              io $ ungrabKeyboard d currentTime
      io $ destroyWindow d w
      destroyComplWin
      io $ sync d False

    type KeyStroke = (KeySym, String)

    eventLoop :: (KeyStroke -> Event -> XP ()) -> XP ()
    eventLoop action = do
      d <- gets dpy
      (keysym,string,event) <- io $
                allocaXEvent $ \e -> do
                  maskEvent d (exposureMask .|. keyPressMask) e
                  ev <- getEvent e
                  (ks,s) <- if ev_event_type ev == keyPress
                            then lookupString $ asKeyEvent e
                            else return (Nothing, "")
                  return (ks,s,ev)
      action (fromMaybe xK_VoidSymbol keysym,string) event
      gets done >>= flip unless (eventLoop handle)

    -- | Removes numlock and capslock from a keymask.
    -- Duplicate of cleanMask from core, but in the
    -- XP monad instead of X.
    cleanMask :: KeyMask -> XP KeyMask
    cleanMask msk = do
      numlock <- gets numlockMask
      let highMasks = 1 `shiftL` 12 - 1
      return (complement (numlock .|. lockMask) .&. msk .&. highMasks)

    -- Main event handler
    handle :: KeyStroke -> Event -> XP ()
    handle ks@(sym,_) e@(KeyEvent {ev_event_type = t, ev_state = m}) = do
      complKey <- gets $ completionKey . config
      chgModeKey <- gets $ changeModeKey . config
      c <- getCompletions
      mCleaned <- cleanMask m
      when (length c > 1) $ modify (\s -> s { showComplWin = True })
      if complKey == (mCleaned,sym)
         then completionHandle c ks e
         else if (sym == chgModeKey) then
               do
                 modify setNextMode
                 updateWindows
              else when (t == keyPress) $ keyPressHandle mCleaned ks
    handle _ (ExposeEvent {ev_window = w}) = do
      st <- get
      when (win st == w) updateWindows
    handle _  _ = return ()

    -- completion event handler
    completionHandle ::  [String] -> KeyStroke -> Event -> XP ()
    completionHandle c ks@(sym,_) (KeyEvent { ev_event_type = t, ev_state = m }) = do
      complKey <- gets $ completionKey . config
      alwaysHlight <- gets $ alwaysHighlight . config
      mCleaned <- cleanMask m
      case () of
        () | t == keyPress && (mCleaned,sym) == complKey -> do
               st <- get

               let updateWins  l = redrawWindows l >> eventLoop (completionHandle l)
                   updateState l = case alwaysHlight of
                     False                                           -> simpleComplete l st
                     True | Just (command st) /= highlightedCompl st -> alwaysHighlightCurrent st
                          | otherwise                                -> alwaysHighlightNext l st

               case c of
                 []  -> updateWindows   >> eventLoop handle
                 [x] -> updateState [x] >> getCompletions >>= updateWins
                 l   -> updateState l   >> updateWins l
          | t == keyRelease && (mCleaned,sym) == complKey -> eventLoop (completionHandle c)
          | otherwise -> keyPressHandle mCleaned ks -- some other key, handle it normally
      where
        -- When alwaysHighlight is off, just complete based on what the
        -- user has typed so far.
        simpleComplete :: [String] -> XPState -> XP ()
        simpleComplete l st = do
          let newCommand = nextCompletion (currentXPMode st) (command st) l
          modify $ \s -> setCommand newCommand $
                         s { offset = length newCommand
                           , highlightedCompl = Just newCommand
                           }

        -- If alwaysHighlight is on, and this is the first use of the
        -- completion key, update the buffer so that it contains the
        -- current completion item.
        alwaysHighlightCurrent :: XPState -> XP ()
        alwaysHighlightCurrent st = do
          let newCommand = fromMaybe (command st) $ highlightedItem st c
          modify $ \s -> setCommand newCommand $
                         setHighlightedCompl (Just newCommand) $
                         s { offset = length newCommand
                           }

        -- If alwaysHighlight is on, and the user wants the next
        -- completion, move to the next completion item and update the
        -- buffer to reflect that.
        --
        --TODO: Scroll or paginate results
        alwaysHighlightNext :: [String] -> XPState -> XP ()
        alwaysHighlightNext l st = do
          let complIndex' = nextComplIndex st (length l)
              highlightedCompl' = highlightedItem st { complIndex = complIndex'} c
              newCommand = fromMaybe (command st) $ highlightedCompl'
          modify $ \s -> setHighlightedCompl highlightedCompl' $
                         setCommand newCommand $
                         s { complIndex = complIndex'
                           , offset = length newCommand
                           }

    -- some other event: go back to main loop
    completionHandle _ k e = handle k e

    --Receives an state of the prompt, the size of the autocompletion list and returns the column,row
    --which should be highlighted next
    nextComplIndex :: XPState -> Int -> (Int,Int)
    nextComplIndex st nitems = case complWinDim st of
      Nothing -> (0,0) --no window dims (just destroyed or not created)
      Just (_,_,_,_,_,yy) -> let
        (ncols,nrows) = (nitems `div` length yy + if (nitems `mod` length yy > 0) then 1 else 0, length yy)
        (currentcol,currentrow) = complIndex st
        in if (currentcol + 1 >= ncols) then --hlight is in the last column
             if (currentrow + 1 < nrows ) then --hlight is still not at the last row
               (currentcol, currentrow + 1)
             else
               (0,0)
           else if(currentrow + 1 < nrows) then --hlight not at the last row
                  (currentcol, currentrow + 1)
                else
                  (currentcol + 1, 0)

    tryAutoComplete :: XP Bool
    tryAutoComplete = do
        ac <- gets (autoComplete . config)
        case ac of
            Just d -> do cs <- getCompletions
                         case cs of
                             [c] -> runCompleted c d >> return True
                             _   -> return False
            Nothing    -> return False
      where runCompleted cmd delay = do
                st <- get
                let new_command = nextCompletion (currentXPMode st) (command st) [cmd]
                modify $ setCommand "autocompleting..."
                updateWindows
                io $ threadDelay delay
                modify $ setCommand new_command
                return True

    -- KeyPresses

    -- | Default key bindings for prompts.  Click on the \"Source\" link
    --   to the right to see the complete list.  See also 'defaultXPKeymap''.
    defaultXPKeymap :: M.Map (KeyMask,KeySym) (XP ())
    defaultXPKeymap = defaultXPKeymap' isSpace

    -- | A variant of 'defaultXPKeymap' which lets you specify a custom
    --   predicate for identifying non-word characters, which affects all
    --   the word-oriented commands (move\/kill word).  The default is
    --   'isSpace'.  For example, by default a path like @foo\/bar\/baz@
    --   would be considered as a single word.  You could use a predicate
    --   like @(\\c -> isSpace c || c == \'\/\')@ to move through or
    --   delete components of the path one at a time.
    defaultXPKeymap' :: (Char -> Bool) -> M.Map (KeyMask,KeySym) (XP ())
    defaultXPKeymap' p = M.fromList $
      map (first $ (,) controlMask) -- control + <key>
      [ (xK_u, killBefore)
      , (xK_k, killAfter)
      , (xK_a, startOfLine)
      , (xK_e, endOfLine)
      , (xK_y, pasteString)
      , (xK_Right, moveWord' p Next)
      , (xK_Left, moveWord' p Prev)
      , (xK_Delete, killWord' p Next)
      , (xK_BackSpace, killWord' p Prev)
      , (xK_w, killWord' p Prev)
      , (xK_g, quit)
      , (xK_bracketleft, quit)
      ] ++
      map (first $ (,) 0)
      [ (xK_Return, setSuccess True >> setDone True)
      , (xK_KP_Enter, setSuccess True >> setDone True)
      , (xK_BackSpace, deleteString Prev)
      , (xK_Delete, deleteString Next)
      , (xK_Left, moveCursor Prev)
      , (xK_Right, moveCursor Next)
      , (xK_Home, startOfLine)
      , (xK_End, endOfLine)
      , (xK_Down, moveHistory W.focusUp')
      , (xK_Up, moveHistory W.focusDown')
      , (xK_Escape, quit)
      ]

    -- | A keymap with many emacs-like key bindings.  Click on the
    --   \"Source\" link to the right to see the complete list.
    --   See also 'emacsLikeXPKeymap''.
    emacsLikeXPKeymap :: M.Map (KeyMask,KeySym) (XP ())
    emacsLikeXPKeymap = emacsLikeXPKeymap' isSpace

    -- | A variant of 'emacsLikeXPKeymap' which lets you specify a custom
    --   predicate for identifying non-word characters, which affects all
    --   the word-oriented commands (move\/kill word).  The default is
    --   'isSpace'.  For example, by default a path like @foo\/bar\/baz@
    --   would be considered as a single word.  You could use a predicate
    --   like @(\\c -> isSpace c || c == \'\/\')@ to move through or
    --   delete components of the path one at a time.
    emacsLikeXPKeymap' :: (Char -> Bool) -> M.Map (KeyMask,KeySym) (XP ())
    emacsLikeXPKeymap' p = M.fromList $
      map (first $ (,) controlMask) -- control + <key>
      [ (xK_z, killBefore) --kill line backwards
      , (xK_k, killAfter) -- kill line fowards
      , (xK_a, startOfLine) --move to the beginning of the line
      , (xK_e, endOfLine) -- move to the end of the line
      , (xK_d, deleteString Next) -- delete a character foward
      , (xK_b, moveCursor Prev) -- move cursor forward
      , (xK_f, moveCursor Next) -- move cursor backward
      , (xK_BackSpace, killWord' p Prev) -- kill the previous word
      , (xK_y, pasteString)
      , (xK_g, quit)
      , (xK_bracketleft, quit)
      ] ++
      map (first $ (,) mod1Mask) -- meta key + <key>
      [ (xK_BackSpace, killWord' p Prev)
      , (xK_f, moveWord' p Next) -- move a word forward
      , (xK_b, moveWord' p Prev) -- move a word backward
      , (xK_d, killWord' p Next) -- kill the next word
      , (xK_n, moveHistory W.focusUp')
      , (xK_p, moveHistory W.focusDown')
      ]
      ++
      map (first $ (,) 0) -- <key>
      [ (xK_Return, setSuccess True >> setDone True)
      , (xK_KP_Enter, setSuccess True >> setDone True)
      , (xK_BackSpace, deleteString Prev)
      , (xK_Delete, deleteString Next)
      , (xK_Left, moveCursor Prev)
      , (xK_Right, moveCursor Next)
      , (xK_Home, startOfLine)
      , (xK_End, endOfLine)
      , (xK_Down, moveHistory W.focusUp')
      , (xK_Up, moveHistory W.focusDown')
      , (xK_Escape, quit)
      ]

    keyPressHandle :: KeyMask -> KeyStroke -> XP ()
    keyPressHandle m (ks,str) = do
      km <- gets (promptKeymap . config)
      case M.lookup (m,ks) km of
        Just action -> action >> updateWindows
        Nothing -> case str of
                     "" -> eventLoop handle
                     _ -> when (m .&. controlMask == 0) $ do
                                     let str' = if isUTF8Encoded str
                                                   then decodeString str
                                                   else str
                                     insertString str'
                                     updateWindows
                                     updateHighlightedCompl
                                     completed <- tryAutoComplete
                                     when completed $ setSuccess True >> setDone True

    setSuccess :: Bool -> XP ()
    setSuccess b = modify $ \s -> s { successful = b }

    setDone :: Bool -> XP ()
    setDone b = modify $ \s -> s { done = b }

    -- KeyPress and State

    -- | Quit.
    quit :: XP ()
    quit = flushString >> setSuccess False >> setDone True

    -- | Kill the portion of the command before the cursor
    killBefore :: XP ()
    killBefore =
      modify $ \s -> setCommand (drop (offset s) (command s)) $ s { offset  = 0 }

    -- | Kill the portion of the command including and after the cursor
    killAfter :: XP ()
    killAfter =
      modify $ \s -> setCommand (take (offset s) (command s)) s

    -- | Kill the next\/previous word, using 'isSpace' as the default
    --   predicate for non-word characters.  See 'killWord''.
    killWord :: Direction1D -> XP ()
    killWord = killWord' isSpace

    -- | Kill the next\/previous word, given a predicate to identify
    --   non-word characters. First delete any consecutive non-word
    --   characters; then delete consecutive word characters, stopping
    --   just before the next non-word character.
    --
    --   For example, by default (using 'killWord') a path like
    --   @foo\/bar\/baz@ would be deleted in its entirety.  Instead you can
    --   use something like @killWord' (\\c -> isSpace c || c == \'\/\')@ to
    --   delete the path one component at a time.
    killWord' :: (Char -> Bool) -> Direction1D -> XP ()
    killWord' p d = do
      o <- gets offset
      c <- gets command
      let (f,ss)        = splitAt o c
          delNextWord   = snd . break p . dropWhile p
          delPrevWord   = reverse . delNextWord . reverse
          (ncom,noff)   =
              case d of
                Next -> (f ++ delNextWord ss, o)
                Prev -> (delPrevWord f ++ ss, length $ delPrevWord f) -- laziness!!
      modify $ \s -> setCommand ncom $ s { offset = noff}

    -- | Put the cursor at the end of line
    endOfLine :: XP ()
    endOfLine  =
        modify $ \s -> s { offset = length (command s)}

    -- | Put the cursor at the start of line
    startOfLine :: XP ()
    startOfLine  =
        modify $ \s -> s { offset = 0 }

    -- |  Flush the command string and reset the offset
    flushString :: XP ()
    flushString = modify $ \s -> setCommand "" $ s { offset = 0}

    --reset index if config has `alwaysHighlight`. The inserted char could imply fewer autocompletions.
    --If the current index was column 2, row 1 and now there are only 4 autocompletion rows with 1 column, what should we highlight? Set it to the first and start navigation again
    resetComplIndex :: XPState -> XPState
    resetComplIndex st = if (alwaysHighlight $ config st) then st { complIndex = (0,0) } else st

    -- | Insert a character at the cursor position
    insertString :: String -> XP ()
    insertString str =
      modify $ \s -> let
        cmd = (c (command s) (offset s))
        st = resetComplIndex $ s { offset = o (offset s)}
        in setCommand cmd st
      where o oo = oo + length str
            c oc oo | oo >= length oc = oc ++ str
                    | otherwise = f ++ str ++ ss
                    where (f,ss) = splitAt oo oc

    -- | Insert the current X selection string at the cursor position.
    pasteString :: XP ()
    pasteString = join $ io $ liftM insertString getSelection

    -- | Remove a character at the cursor position
    deleteString :: Direction1D -> XP ()
    deleteString d =
      modify $ \s -> setCommand (c (command s) (offset s)) $ 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 :: Direction1D -> 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)

    -- | Move the cursor one word, using 'isSpace' as the default
    --   predicate for non-word characters.  See 'moveWord''.
    moveWord :: Direction1D -> XP ()
    moveWord = moveWord' isSpace

    -- | Move the cursor one word, given a predicate to identify non-word
    --   characters. First move past any consecutive non-word characters;
    --   then move to just before the next non-word character.
    moveWord' :: (Char -> Bool) -> Direction1D -> XP ()
    moveWord' p d = do
      c <- gets command
      o <- gets offset
      let (f,ss) = splitAt o c
          len = uncurry (+)
              . (length *** (length . fst . break p))
              . break (not . p)
          newoff = case d of
                     Prev -> o - len (reverse f)
                     Next -> o + len ss
      modify $ \s -> s { offset = newoff }

    moveHistory :: (W.Stack String -> W.Stack String) -> XP ()
    moveHistory f = do
      modify $ \s -> let ch = f $ commandHistory s
                     in s { commandHistory = ch
                          , offset         = length $ W.focus ch
                          , complIndex     = (0,0) }
      updateWindows
      updateHighlightedCompl

    updateHighlightedCompl :: XP ()
    updateHighlightedCompl = do
      st <- get
      cs <- getCompletions
      alwaysHighlight' <- gets $ alwaysHighlight . config
      when (alwaysHighlight') $ modify $ \s -> s {highlightedCompl = highlightedItem st cs}

    -- X Stuff

    updateWindows :: XP ()
    updateWindows = do
      d <- gets dpy
      drawWin
      c <- getCompletions
      case c  of
        [] -> destroyComplWin >> return ()
        l  -> redrawComplWin l
      io $ sync d False

    redrawWindows :: [String] -> XP ()
    redrawWindows c = do
      d <- gets dpy
      drawWin
      case c of
        [] -> return ()
        l  -> redrawComplWin l
      io $ sync d False

    createWin :: Display -> Window -> XPConfig -> Rectangle -> IO Window
    createWin d rw c s = do
      let (x,y) = case position c of
                    Top -> (0,0)
                    Bottom -> (0, rect_height s - height c)
                    CenteredAt py w -> (floor $ (fi $ rect_width s) * ((1 - w) / 2), floor $ py * fi (rect_height s) - (fi (height c) / 2))
          width = case position c of
                    CenteredAt _ w -> floor $ fi (rect_width s) * w
                    _              -> rect_width s
      w <- mkUnmanagedWindow d (defaultScreenOfDisplay d) rw
                          (rect_x s + x) (rect_y s + fi y) width (height c)
      mapWindow d w
      return w

    drawWin :: XP ()
    drawWin = do
      st <- get
      let (c,(d,(w,gc))) = (config &&& dpy &&& win &&& gcon) st
          scr = defaultScreenOfDisplay d
          wh = case position c of
                 CenteredAt _ wd -> floor $ wd * fi (widthOfScreen scr)
                 _               -> widthOfScreen scr
          ht = height c
          bw = promptBorderWidth c
      Just bgcolor <- io $ initColor d (bgColor c)
      Just 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
      io $ copyArea d p w gc 0 0 wh ht 0 0
      io $ freePixmap d p

    printPrompt :: Drawable -> XP ()
    printPrompt drw = do
      st <- get
      let (gc,(c,(d,fs))) = (gcon &&& config &&& dpy &&& fontS) st
          (prt,(com,off)) = (show . currentXPMode &&& command &&& offset) st
          str = prt ++ com
          -- break the string in 3 parts: 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 <- io $ textWidthXMF (dpy st) fs f
      psl <- io $ textWidthXMF (dpy st) fs p
      (asc,desc) <- io $ textExtentsXMF fs str
      let y = fi $ ((ht - fi (asc + desc)) `div` 2) + fi asc
          x = (asc + desc) `div` 2

      let draw = printStringXMF d drw fs gc
      -- print the first part
      draw (fgColor c) (bgColor c) x y f
      -- reverse the colors and print the "cursor" ;-)
      draw (bgColor c) (fgColor c) (x + fromIntegral fsl) y p
      -- reverse the colors and print the rest of the string
      draw (fgColor c) (bgColor c) (x + fromIntegral (fsl + psl)) y ss

    -- get the current completion function depending on the active mode
    getCompletionFunction :: XPState -> ComplFunction
    getCompletionFunction st = case operationMode st of
      XPSingleMode compl _ -> compl
      XPMultipleModes modes -> completionFunction $ W.focus modes

    -- Completions
    getCompletions :: XP [String]
    getCompletions = do
      s <- get
      io $ getCompletionFunction s (commandToComplete (currentXPMode s) (command s))
           `E.catch` \(SomeException _) -> return []

    setComplWin :: Window -> ComplWindowDim -> XP ()
    setComplWin w wi =
      modify (\s -> s { complWin = Just w, complWinDim = Just wi })

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

    type ComplWindowDim = (Position,Position,Dimension,Dimension,Columns,Rows)
    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,(scr,fs)) = (config &&& screen &&& fontS) st
          wh = case position c of
                 CenteredAt _ w -> floor $ fi (rect_width scr) * w
                 _ -> rect_width scr
          ht = height c
          bw = promptBorderWidth c

      tws <- mapM (textWidthXMF (dpy st) fs) compl
      let max_compl_len =  fromIntegral ((fi ht `div` 2) + maximum tws)
          columns = max 1 $ wh `div` fi max_compl_len
          rem_height =  rect_height scr - ht
          (rows,r) = length compl `divMod` fi columns
          needed_rows = max 1 (rows + if r == 0 then 0 else 1)
          limit_max_number = case maxComplRows c of
                               Nothing -> id
                               Just m -> min m
          actual_max_number_of_rows = limit_max_number $ 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 - bw)
                    Bottom -> (0, (0 + rem_height - actual_height + bw))
                    CenteredAt py w
                      | py <= 1/2 -> (floor $ fi (rect_width scr) * ((1 - w) / 2), floor (py * fi (rect_height scr) + (fi ht)/2) - bw)
                      | otherwise -> (floor $ fi (rect_width scr) * ((1 - w) / 2), floor (py * fi (rect_height scr) - (fi ht)/2) - actual_height + bw)
      (asc,desc) <- io $ textExtentsXMF fs $ head compl
      let 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 (rect_x scr + x, rect_y scr + 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  = promptBorderWidth c
          gc  = gcon st
      Just bgcolor <- io $ initColor d (bgColor c)
      Just 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 c) (bgColor c) xx yy ac
      --lift $ spawn $ "xmessage " ++ " ac: " ++ show ac  ++ " xx: " ++ show xx ++ " length xx: " ++ show (length xx) ++ " yy: " ++ show (length yy)
      io $ copyArea d p w gc 0 0 wh ht 0 0
      io $ freePixmap d p

    redrawComplWin ::  [String] -> XP ()
    redrawComplWin compl = do
      st <- get
      nwi <- getComplWinDim compl
      let recreate = do destroyComplWin
                        w <- createComplWin nwi
                        drawComplWin w compl
      if compl /= [] && showComplWin st
         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

    -- Finds the column and row indexes in which a string appears.
    -- if the string is not in the matrix, the indexes default to (0,0)
    findComplIndex :: String -> [[String]] -> (Int,Int)
    findComplIndex x xss = let
      colIndex = fromMaybe 0 $ findIndex (\cols -> x `elem` cols) xss
      rowIndex = fromMaybe 0 $ elemIndex x $ (!!) xss colIndex
      in (colIndex,rowIndex)

    printComplList :: Display -> Drawable -> GC -> String -> String
                   -> [Position] -> [Position] -> [[String]] -> XP ()
    printComplList d drw gc fc bc xs ys sss =
        zipWithM_ (\x ss ->
            zipWithM_ (\y item -> do
                st <- get
                alwaysHlight <- gets $ alwaysHighlight . config
                let (f,b) = case alwaysHlight of
                      True -> -- default to the first item, the one in (0,0)
                        let
                          (colIndex,rowIndex) = findComplIndex item sss
                        in -- assign some colors
                         if ((complIndex st) == (colIndex,rowIndex)) then (fgHLight $ config st,bgHLight $ config st)
                         else (fc,bc)
                      False ->
                        -- compare item with buffer's value
                        if completionToCommand (currentXPMode st) item == commandToComplete (currentXPMode st) (command st)
                        then (fgHLight $ config st,bgHLight $ config st)
                        else (fc,bc)
                printStringXMF d drw (fontS st) gc f b x y item)
            ys ss) xs sss

    -- History

    type History = M.Map String [String]

    emptyHistory :: History
    emptyHistory = M.empty

    getHistoryFile :: IO FilePath
    getHistoryFile = fmap (++ "/prompt-history") getXMonadCacheDir

    readHistory :: IO History
    readHistory = readHist `E.catch` \(SomeException _) -> return emptyHistory
     where
        readHist = do
            path <- getHistoryFile
            xs <- bracket (openFile path ReadMode) hClose hGetLine
            readIO xs

    writeHistory :: History -> IO ()
    writeHistory hist = do
      path <- getHistoryFile
      let filtered = M.filter (not . null) hist
      writeFile path (show filtered) `E.catch` \(SomeException e) ->
                              hPutStrLn stderr ("error writing history: "++show e)
      setFileMode path mode
        where mode = ownerReadMode .|. ownerWriteMode

    -- $xutils

    -- | Fills a 'Drawable' with a rectangle and a border
    fillDrawable :: Display -> Drawable -> GC -> Pixel -> Pixel
                 -> Dimension -> Dimension -> Dimension -> IO ()
    fillDrawable d drw gc border bgcolor bw wh ht = do
      -- we start with the border
      setForeground d gc border
      fillRectangle d drw gc 0 0 wh ht
      -- here foreground means 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

    -- $utils

    -- | This function takes a list of possible completions and returns a
    -- completions function to be used with 'mkXPrompt'
    mkComplFunFromList :: [String] -> String -> IO [String]
    mkComplFunFromList _ [] = return []
    mkComplFunFromList l s =
      return $ filter (\x -> take (length s) x == s) l

    -- | This function takes a list of possible completions and returns a
    -- completions function to be used with 'mkXPrompt'. If the string is
    -- null it will return all completions.
    mkComplFunFromList' :: [String] -> String -> IO [String]
    mkComplFunFromList' l [] = return l
    mkComplFunFromList' l s =
      return $ filter (\x -> take (length s) x == s) l

    -- | Given the prompt type, the command line and the completion list,
    -- return the next completion in the list for the last word of the
    -- command line. This is the default 'nextCompletion' implementation.
    getNextOfLastWord :: XPrompt t => t -> String -> [String] -> String
    getNextOfLastWord t c l = skipLastWord c ++ completionToCommand t (l !! ni)
        where ni = case commandToComplete t c `elemIndex` map (completionToCommand t) l of
                     Just i -> if i >= length l - 1 then 0 else i + 1
                     Nothing -> 0

    -- | An alternative 'nextCompletion' implementation: given a command
    -- and a completion list, get the next completion in the list matching
    -- the whole command line.
    getNextCompletion :: String -> [String] -> String
    getNextCompletion c l = l !! idx
        where idx = case c `elemIndex` l of
                      Just i  -> if i >= length l - 1 then 0 else i + 1
                      Nothing -> 0

    -- | Given a maximum length, splits a list into sublists
    splitInSubListsAt :: Int -> [a] -> [[a]]
    splitInSubListsAt _ [] = []
    splitInSubListsAt i x = f : splitInSubListsAt i rest
        where (f,rest) = splitAt i x

    -- | Gets the last word of a string or the whole string if formed by
    -- only one word
    getLastWord :: String -> String
    getLastWord = reverse . fst . breakAtSpace . reverse

    -- | Skips the last word of the string, if the string is composed by
    -- more then one word. Otherwise returns the string.
    skipLastWord :: String -> String
    skipLastWord = reverse . snd . breakAtSpace . reverse

    breakAtSpace :: String -> (String, String)
    breakAtSpace s
        | " \\" `isPrefixOf` s2 = (s1 ++ " " ++ s1', s2')
        | otherwise = (s1, s2)
          where (s1, s2 ) = break isSpace s
                (s1',s2') = breakAtSpace $ tail s2

    -- | 'historyCompletion' provides a canned completion function much like
    --   'getShellCompl'; you pass it to mkXPrompt, and it will make completions work
    --   from the query history stored in the XMonad cache directory.
    historyCompletion :: ComplFunction
    historyCompletion = historyCompletionP (const True)

    -- | Like 'historyCompletion' but only uses history data from Prompts whose
    -- name satisfies the given predicate.
    historyCompletionP :: (String -> Bool) -> ComplFunction
    historyCompletionP p x = fmap (toComplList . M.filterWithKey (const . p)) readHistory
        where toComplList = deleteConsecutive . filter (isInfixOf x) . M.fold (++) []

    -- | Sort a list and remove duplicates. Like 'deleteAllDuplicates', but trades off
    --   laziness and stability for efficiency.
    uniqSort :: Ord a => [a] -> [a]
    uniqSort = toList . fromList

    -- | Functions to be used with the 'historyFilter' setting.
    -- 'deleteAllDuplicates' will remove all duplicate entries.
    -- 'deleteConsecutive' will only remove duplicate elements
    -- immediately next to each other.
    deleteAllDuplicates, deleteConsecutive :: [String] -> [String]
    deleteAllDuplicates = nub
    deleteConsecutive = map head . group

    newtype HistoryMatches = HistoryMatches (IORef ([String],Maybe (W.Stack String)))

    -- | Initializes a new HistoryMatches structure to be passed
    -- to historyUpMatching
    initMatches :: (Functor m, MonadIO m) => m HistoryMatches
    initMatches = HistoryMatches <$> liftIO (newIORef ([],Nothing))

    historyNextMatching :: HistoryMatches -> (W.Stack String -> W.Stack String) -> XP ()
    historyNextMatching hm@(HistoryMatches ref) next = do
      (completed,completions) <- io $ readIORef ref
      input <- getInput
      if input `elem` completed
         then case completions of
                Just cs -> do
                    let cmd = W.focus cs
                    modify $ setCommand cmd
                    modify $ \s -> s { offset = length cmd }
                    io $ writeIORef ref (cmd:completed,Just $ next cs)
                Nothing -> return ()
         else do -- the user typed something new, recompute completions
           io . writeIORef ref . ((,) [input]) . filterMatching input =<< gets commandHistory
           historyNextMatching hm next
        where filterMatching :: String -> W.Stack String -> Maybe (W.Stack String)
              filterMatching prefix = W.filter (prefix `isPrefixOf`) . next

    -- | Retrieve the next history element that starts with
    -- the current input. Pass it the result of initMatches
    -- when creating the prompt. Example:
    --
    -- > ..
    -- > ((modMask,xK_p), shellPrompt . myPrompt =<< initMatches)
    -- > ..
    -- > myPrompt ref = def
    -- >   { promptKeymap = M.union [((0,xK_Up), historyUpMatching ref)
    -- >                            ,((0,xK_Down), historyDownMatching ref)]
    -- >                            (promptKeymap def)
    -- >   , .. }
    --
    historyUpMatching, historyDownMatching :: HistoryMatches -> XP ()
    historyUpMatching hm = historyNextMatching hm W.focusDown'
    historyDownMatching hm = historyNextMatching hm W.focusUp'