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

-----------------------------------------------------------------------------
-- Bugs:
-- if 'alwaysHighlight' is True, and
--  1 type several characters
--  2 tab-complete past several entries
--  3 backspace back to the several characters
--  4 tab-complete once (results in the entry past the one in [2])
--  5 tab-complete against this shorter list of completions
-- then the prompt will freeze (XMonad continues however).
-----------------------------------------------------------------------------

module XMonad.Prompt
    ( -- * Usage
      -- $usage
      mkXPrompt
    , mkXPromptWithReturn
    , mkXPromptWithModes
    , def
    , amberXPConfig
    , greenXPConfig
    , XPMode
    , XPType (..)
    , XPColor (..)
    , XPPosition (..)
    , XPConfig (..)
    , XPrompt (..)
    , XP
    , defaultXPKeymap, defaultXPKeymap'
    , emacsLikeXPKeymap, emacsLikeXPKeymap'
    , vimLikeXPKeymap, vimLikeXPKeymap'
    , quit
    , promptSubmap, promptBuffer, toHeadChar, bufferOne
    , killBefore, killAfter, startOfLine, endOfLine
    , insertString, pasteString, pasteString'
    , clipCursor, moveCursor, moveCursorClip
    , setInput, getInput, getOffset
    , defaultColor, modifyColor, setColor
    , resetColor, setBorderColor
    , modifyPrompter, setPrompter, resetPrompter
    , selectedCompletion, setCurrentCompletions, getCurrentCompletions
    , moveWord, moveWord', killWord, killWord'
    , changeWord, deleteString
    , moveHistory, setSuccess, setDone, setModeDone
    , Direction1D(..)
    , ComplFunction
    , ComplCaseSensitivity(..)
    -- * 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           XMonad.Prelude               hiding (toList, fromList)
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.Arrow                (first, (&&&), (***))
import           Control.Concurrent           (threadDelay)
import           Control.Exception            as E hiding (handle)
import           Control.Monad.State
import           Data.Bifunctor               (bimap)
import           Data.Bits
import           Data.IORef
import qualified Data.List.NonEmpty           as NE
import qualified Data.Map                     as M
import           Data.Set                     (fromList, toList)
import           System.IO
import           System.IO.Unsafe             (unsafePerformIO)
import           System.Posix.Files
import Data.List.NonEmpty (nonEmpty)

-- $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 { XPState -> Display
dpy                   :: Display
        , XPState -> EventMask
rootw                 :: !Window
        , XPState -> EventMask
win                   :: !Window
        , XPState -> Rectangle
screen                :: !Rectangle
        , XPState -> Dimension
winWidth              :: !Dimension -- ^ Width of the prompt window
        , XPState -> Maybe ComplWindowDim
complWinDim           :: Maybe ComplWindowDim
        , XPState -> (Int, Int)
complIndex            :: !(Int,Int)
        , XPState -> IORef (Maybe EventMask)
complWin              :: IORef (Maybe Window)
        -- ^ This is an 'IORef' to enable removal of the completion
        -- window if an exception occurs, since otherwise the most
        -- recent value of 'complWin' would not be available.
        , XPState -> Bool
showComplWin          :: Bool
        , XPState -> XPOperationMode
operationMode         :: XPOperationMode
        , XPState -> Maybe String
highlightedCompl      :: Maybe String
        , XPState -> GC
gcon                  :: !GC
        , XPState -> XMonadFont
fontS                 :: !XMonadFont
        , XPState -> Stack String
commandHistory        :: W.Stack String
        , XPState -> Int
offset                :: !Int
        , XPState -> XPConfig
config                :: XPConfig
        , XPState -> Bool
successful            :: Bool
        , XPState -> KeyMask -> KeyMask
cleanMask             :: KeyMask -> KeyMask
        , XPState -> Bool
done                  :: Bool
        , XPState -> Bool
modeDone              :: Bool
        , XPState -> XPColor
color                 :: XPColor
        , XPState -> String -> String
prompter              :: String -> String
        , XPState -> [(EventMask, String, Event)]
eventBuffer           :: [(KeySym, String, Event)]
        , XPState -> String
inputBuffer           :: String
        , XPState -> Maybe [String]
currentCompletions    :: Maybe [String]
        }

data XPConfig =
    XPC { XPConfig -> String
font                  :: String       -- ^ Font. For TrueType fonts, use something like
                                                -- @"xft:Hack:pixelsize=1"@. Alternatively, use X Logical Font
                                                -- Description, i.e. something like
                                                -- @"-*-dejavu sans mono-medium-r-normal--*-80-*-*-*-*-iso10646-1"@.
        , XPConfig -> String
bgColor               :: String       -- ^ Background color
        , XPConfig -> String
fgColor               :: String       -- ^ Font color
        , XPConfig -> String
bgHLight              :: String       -- ^ Background color of a highlighted completion entry
        , XPConfig -> String
fgHLight              :: String       -- ^ Font color of a highlighted completion entry
        , XPConfig -> String
borderColor           :: String       -- ^ Border color
        , XPConfig -> Dimension
promptBorderWidth     :: !Dimension   -- ^ Border width
        , XPConfig -> XPPosition
position              :: XPPosition   -- ^ Position: 'Top', 'Bottom', or 'CenteredAt'
        , XPConfig -> Bool
alwaysHighlight       :: !Bool        -- ^ Always highlight an item, overriden to True with multiple modes
        , XPConfig -> Dimension
height                :: !Dimension   -- ^ Window height
        , XPConfig -> Maybe Dimension
maxComplRows          :: Maybe Dimension
                                                -- ^ Just x: maximum number of rows to show in completion window
        , XPConfig -> Maybe Dimension
maxComplColumns       :: Maybe Dimension
                                                -- ^ Just x: maximum number of columns to show in completion window
        , XPConfig -> Int
historySize           :: !Int         -- ^ The number of history entries to be saved
        , XPConfig -> [String] -> [String]
historyFilter         :: [String] -> [String]
                                                -- ^ a filter to determine which
                                                -- history entries to remember
        , XPConfig -> Map (KeyMask, EventMask) (XP ())
promptKeymap          :: M.Map (KeyMask,KeySym) (XP ())
                                                -- ^ Mapping from key combinations to actions
        , XPConfig -> (KeyMask, EventMask)
completionKey         :: (KeyMask, KeySym)     -- ^ Key to trigger forward completion
        , XPConfig -> (KeyMask, EventMask)
prevCompletionKey     :: (KeyMask, KeySym)     -- ^ Key to trigger backward completion
        , XPConfig -> EventMask
changeModeKey         :: KeySym       -- ^ Key to change mode (when the prompt has multiple modes)
        , XPConfig -> String
defaultText           :: String       -- ^ The text by default in the prompt line
        , XPConfig -> Maybe Int
autoComplete          :: Maybe Int    -- ^ Just x: if only one completion remains, auto-select it,
                                                --   and delay by x microseconds
        , XPConfig -> Bool
showCompletionOnTab   :: Bool         -- ^ Only show list of completions when Tab was pressed
        , XPConfig -> ComplCaseSensitivity
complCaseSensitivity  :: ComplCaseSensitivity
                                                -- ^ Perform completion in a case-sensitive manner
        , XPConfig -> String -> String -> Bool
searchPredicate       :: String -> String -> Bool
                                                -- ^ Given the typed string and a possible
                                                --   completion, is the completion valid?
        , XPConfig -> String -> String
defaultPrompter       :: String -> String
                                                -- ^ Modifies the prompt given by 'showXPrompt'
        , XPConfig -> String -> [String] -> [String]
sorter                :: String -> [String] -> [String]
                                                -- ^ Used to sort the possible completions by how well they
                                                --   match the search string (see X.P.FuzzyMatch for an
                                                --   example).
        }

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)

data ComplCaseSensitivity = CaseSensitive | CaseInSensitive

instance Show XPType where
    show :: XPType -> String
show (XPT p
p) = forall t. XPrompt t => t -> String
showXPrompt p
p

instance XPrompt XPType where
    showXPrompt :: XPType -> String
showXPrompt                 = forall a. Show a => a -> String
show
    nextCompletion :: XPType -> String -> [String] -> String
nextCompletion      (XPT p
t) = forall t. XPrompt t => t -> String -> [String] -> String
nextCompletion      p
t
    commandToComplete :: XPType -> String -> String
commandToComplete   (XPT p
t) = forall t. XPrompt t => t -> String -> String
commandToComplete   p
t
    completionToCommand :: XPType -> String -> String
completionToCommand (XPT p
t) = forall t. XPrompt t => t -> String -> String
completionToCommand p
t
    completionFunction :: XPType -> ComplFunction
completionFunction  (XPT p
t) = forall t. XPrompt t => t -> ComplFunction
completionFunction  p
t
    modeAction :: XPType -> String -> String -> X ()
modeAction          (XPT p
t) = forall t. XPrompt t => t -> String -> String -> X ()
modeAction          p
t

-- | A class for an abstract prompt. In order for your data type to be a
-- valid prompt you _must_ make it an instance of this class.
--
-- The minimal complete definition is just 'showXPrompt', i.e. the name
-- of the prompt. This string will be displayed in the command line
-- window (before the cursor).
--
-- As an example of a complete 'XPrompt' instance definition, we can
-- look at the 'XMonad.Prompt.Shell.Shell' prompt from
-- "XMonad.Prompt.Shell":
--
-- >     data Shell = Shell
-- >
-- >     instance XPrompt Shell where
-- >          showXPrompt Shell = "Run: "
class XPrompt t where
    {-# MINIMAL showXPrompt #-}

    -- | 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 = forall t. XPrompt t => t -> String -> [String] -> String
getNextOfLastWord

    -- | This method is used to generate the string to be passed to
    -- the completion function.
    commandToComplete :: t -> String -> String
    commandToComplete t
_ = String -> String
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 t
_ String
c = String
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
t = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return [String
"Completions for " forall a. [a] -> [a] -> [a]
++ forall t. XPrompt t => t -> String
showXPrompt t
t forall a. [a] -> [a] -> [a]
++ String
" 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 t
_ String
_ String
_ = forall (m :: * -> *) a. Monad m => a -> m a
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 { XPPosition -> Rational
xpCenterY :: Rational
                             -- ^ Rational between 0 and 1, giving
                             -- y coordinate of center of the prompt relative to the screen height.
                             , XPPosition -> Rational
xpWidth  :: Rational
                             -- ^ Rational between 0 and 1, giving
                             -- width of the prompt relative to the screen width.
                             }
                  deriving (Int -> XPPosition -> String -> String
[XPPosition] -> String -> String
XPPosition -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [XPPosition] -> String -> String
$cshowList :: [XPPosition] -> String -> String
show :: XPPosition -> String
$cshow :: XPPosition -> String
showsPrec :: Int -> XPPosition -> String -> String
$cshowsPrec :: Int -> XPPosition -> String -> String
Show,ReadPrec [XPPosition]
ReadPrec XPPosition
Int -> ReadS XPPosition
ReadS [XPPosition]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [XPPosition]
$creadListPrec :: ReadPrec [XPPosition]
readPrec :: ReadPrec XPPosition
$creadPrec :: ReadPrec XPPosition
readList :: ReadS [XPPosition]
$creadList :: ReadS [XPPosition]
readsPrec :: Int -> ReadS XPPosition
$creadsPrec :: Int -> ReadS XPPosition
Read)

data XPColor =
    XPColor { XPColor -> String
bgNormal      :: String   -- ^ Background color
            , XPColor -> String
fgNormal      :: String   -- ^ Font color
            , XPColor -> String
bgHighlight   :: String   -- ^ Background color of a highlighted completion entry
            , XPColor -> String
fgHighlight   :: String   -- ^ Font color of a highlighted completion entry
            , XPColor -> String
border        :: String   -- ^ Border color
            }

amberXPConfig, greenXPConfig :: XPConfig

instance Default XPColor where
    def :: XPColor
def =
        XPColor { bgNormal :: String
bgNormal    = String
"grey22"
                , fgNormal :: String
fgNormal    = String
"grey80"
                , bgHighlight :: String
bgHighlight = String
"grey"
                , fgHighlight :: String
fgHighlight = String
"black"
                , border :: String
border      = String
"white"
                }

instance Default XPConfig where
  def :: XPConfig
def =
#ifdef XFT
    XPC { font :: String
font                  = String
"xft:monospace-12"
#else
    XPC { font                  = "-misc-fixed-*-*-*-*-12-*-*-*-*-*-*-*"
#endif
        , bgColor :: String
bgColor               = XPColor -> String
bgNormal forall a. Default a => a
def
        , fgColor :: String
fgColor               = XPColor -> String
fgNormal forall a. Default a => a
def
        , bgHLight :: String
bgHLight              = XPColor -> String
bgHighlight forall a. Default a => a
def
        , fgHLight :: String
fgHLight              = XPColor -> String
fgHighlight forall a. Default a => a
def
        , borderColor :: String
borderColor           = XPColor -> String
border forall a. Default a => a
def
        , promptBorderWidth :: Dimension
promptBorderWidth     = Dimension
1
        , promptKeymap :: Map (KeyMask, EventMask) (XP ())
promptKeymap          = Map (KeyMask, EventMask) (XP ())
defaultXPKeymap
        , completionKey :: (KeyMask, EventMask)
completionKey         = (KeyMask
0, EventMask
xK_Tab)
        , prevCompletionKey :: (KeyMask, EventMask)
prevCompletionKey     = (KeyMask
shiftMask, EventMask
xK_Tab)
        , changeModeKey :: EventMask
changeModeKey         = EventMask
xK_grave
        , position :: XPPosition
position              = XPPosition
Bottom
        , height :: Dimension
height                = Dimension
18
        , maxComplRows :: Maybe Dimension
maxComplRows          = forall a. Maybe a
Nothing
        , maxComplColumns :: Maybe Dimension
maxComplColumns       = forall a. Maybe a
Nothing
        , historySize :: Int
historySize           = Int
256
        , historyFilter :: [String] -> [String]
historyFilter         = forall a. a -> a
id
        , defaultText :: String
defaultText           = []
        , autoComplete :: Maybe Int
autoComplete          = forall a. Maybe a
Nothing
        , showCompletionOnTab :: Bool
showCompletionOnTab   = Bool
False
        , complCaseSensitivity :: ComplCaseSensitivity
complCaseSensitivity  = ComplCaseSensitivity
CaseSensitive
        , searchPredicate :: String -> String -> Bool
searchPredicate       = forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf
        , alwaysHighlight :: Bool
alwaysHighlight       = Bool
False
        , defaultPrompter :: String -> String
defaultPrompter       = forall a. a -> a
id
        , sorter :: String -> [String] -> [String]
sorter                = forall a b. a -> b -> a
const forall a. a -> a
id
        }
greenXPConfig :: XPConfig
greenXPConfig = forall a. Default a => a
def { bgColor :: String
bgColor           = String
"black"
                    , fgColor :: String
fgColor           = String
"green"
                    , promptBorderWidth :: Dimension
promptBorderWidth = Dimension
0
                    }
amberXPConfig :: XPConfig
amberXPConfig = forall a. Default a => a
def { bgColor :: String
bgColor   = String
"black"
                    , fgColor :: String
fgColor   = String
"#ca8f2d"
                    , fgHLight :: String
fgHLight  = String
"#eaaf4c"
                    }

initState :: Display -> Window -> Window -> Rectangle -> XPOperationMode
          -> GC -> XMonadFont -> [String] -> XPConfig -> (KeyMask -> KeyMask)
          -> Dimension -> XPState
initState :: Display
-> EventMask
-> EventMask
-> Rectangle
-> XPOperationMode
-> GC
-> XMonadFont
-> [String]
-> XPConfig
-> (KeyMask -> KeyMask)
-> Dimension
-> XPState
initState Display
d EventMask
rw EventMask
w Rectangle
s XPOperationMode
opMode GC
gc XMonadFont
fonts [String]
h XPConfig
c KeyMask -> KeyMask
cm Dimension
width =
    XPS { dpy :: Display
dpy                   = Display
d
        , rootw :: EventMask
rootw                 = EventMask
rw
        , win :: EventMask
win                   = EventMask
w
        , screen :: Rectangle
screen                = Rectangle
s
        , winWidth :: Dimension
winWidth              = Dimension
width
        , complWinDim :: Maybe ComplWindowDim
complWinDim           = forall a. Maybe a
Nothing
        , complWin :: IORef (Maybe EventMask)
complWin              = forall a. IO a -> a
unsafePerformIO (forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing)
        , showComplWin :: Bool
showComplWin          = Bool -> Bool
not (XPConfig -> Bool
showCompletionOnTab XPConfig
c)
        , operationMode :: XPOperationMode
operationMode         = XPOperationMode
opMode
        , highlightedCompl :: Maybe String
highlightedCompl      = forall a. Maybe a
Nothing
        , gcon :: GC
gcon                  = GC
gc
        , fontS :: XMonadFont
fontS                 = XMonadFont
fonts
        , commandHistory :: Stack String
commandHistory        = W.Stack { focus :: String
W.focus = XPConfig -> String
defaultText XPConfig
c
                                          , up :: [String]
W.up    = []
                                          , down :: [String]
W.down  = [String]
h
                                          }
        , complIndex :: (Int, Int)
complIndex            = (Int
0,Int
0) --(column index, row index), used when `alwaysHighlight` in XPConfig is True
        , offset :: Int
offset                = forall (t :: * -> *) a. Foldable t => t a -> Int
length (XPConfig -> String
defaultText XPConfig
c)
        , config :: XPConfig
config                = XPConfig
c
        , successful :: Bool
successful            = Bool
False
        , done :: Bool
done                  = Bool
False
        , modeDone :: Bool
modeDone              = Bool
False
        , cleanMask :: KeyMask -> KeyMask
cleanMask             = KeyMask -> KeyMask
cm
        , prompter :: String -> String
prompter              = XPConfig -> String -> String
defaultPrompter XPConfig
c
        , color :: XPColor
color                 = XPConfig -> XPColor
defaultColor XPConfig
c
        , eventBuffer :: [(EventMask, String, Event)]
eventBuffer           = []
        , inputBuffer :: String
inputBuffer           = String
""
        , currentCompletions :: Maybe [String]
currentCompletions    = forall a. Maybe a
Nothing
        }

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

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

-- Returns the highlighted item
highlightedItem :: XPState -> [String] -> Maybe String
highlightedItem :: XPState -> [String] -> Maybe String
highlightedItem XPState
st' [String]
completions = case XPState -> Maybe ComplWindowDim
complWinDim XPState
st' of
  Maybe ComplWindowDim
Nothing -> forall a. Maybe a
Nothing -- when there isn't any compl win, we can't say how many cols,rows there are
  Just ComplWindowDim
winDim ->
    let
      ComplWindowDim{ [Position]
cwCols :: ComplWindowDim -> [Position]
cwCols :: [Position]
cwCols, [Position]
cwRows :: ComplWindowDim -> [Position]
cwRows :: [Position]
cwRows } = ComplWindowDim
winDim
      complMatrix :: [[String]]
complMatrix = forall a. Int -> [a] -> [[a]]
chunksOf (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Position]
cwRows) (forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Position]
cwCols forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length [Position]
cwRows) [String]
completions)
      (Int
col_index,Int
row_index) = XPState -> (Int, Int)
complIndex XPState
st'
    in case [String]
completions of
      [] -> forall a. Maybe a
Nothing
      [String]
_  -> [[String]]
complMatrix forall a. [a] -> Int -> Maybe a
!? Int
col_index forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall a. [a] -> Int -> Maybe a
!? Int
row_index)

-- | Return the selected completion, i.e. the 'String' we actually act
-- upon after the user confirmed their selection (by pressing @Enter@).
selectedCompletion :: XPState -> String
selectedCompletion :: XPState -> String
selectedCompletion XPState
st
    -- If 'alwaysHighlight' is used, look at the currently selected item (if any)
  | XPConfig -> Bool
alwaysHighlight (XPState -> XPConfig
config XPState
st) = forall a. a -> Maybe a -> a
fromMaybe (XPState -> String
command XPState
st) forall a b. (a -> b) -> a -> b
$ XPState -> Maybe String
highlightedCompl XPState
st
    -- Otherwise, look at what the user actually wrote so far
  | Bool
otherwise                   = XPState -> String
command XPState
st

-- this would be much easier with functional references
command :: XPState -> String
command :: XPState -> String
command = forall a. Stack a -> a
W.focus forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> Stack String
commandHistory

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

-- | Sets the input string to the given value.
setInput :: String -> XP ()
setInput :: String -> XP ()
setInput = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> XPState -> XPState
setCommand

-- | Returns the current input string. Intended for use in custom keymaps
-- where 'get' or similar can't be used to retrieve it.
getInput :: XP String
getInput :: XP String
getInput = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> String
command

-- | Returns the offset of the current input string. Intended for use in custom
-- keys where 'get' or similar can't be used to retrieve it.
getOffset :: XP Int
getOffset :: XP Int
getOffset = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Int
offset

-- | Accessor encapsulating disparate color fields of 'XPConfig' into an
-- 'XPColor' (the configuration provides default values).
defaultColor :: XPConfig -> XPColor
defaultColor :: XPConfig -> XPColor
defaultColor XPConfig
c = XPColor { bgNormal :: String
bgNormal     = XPConfig -> String
bgColor XPConfig
c
                         , fgNormal :: String
fgNormal     = XPConfig -> String
fgColor XPConfig
c
                         , bgHighlight :: String
bgHighlight  = XPConfig -> String
bgHLight XPConfig
c
                         , fgHighlight :: String
fgHighlight  = XPConfig -> String
fgHLight XPConfig
c
                         , border :: String
border       = XPConfig -> String
borderColor XPConfig
c
                         }

-- | Modify the prompt colors.
modifyColor :: (XPColor -> XPColor) -> XP ()
modifyColor :: (XPColor -> XPColor) -> XP ()
modifyColor XPColor -> XPColor
c = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { color :: XPColor
color = XPColor -> XPColor
c forall a b. (a -> b) -> a -> b
$ XPState -> XPColor
color XPState
s }

-- | Set the prompt colors.
setColor :: XPColor -> XP ()
setColor :: XPColor -> XP ()
setColor = (XPColor -> XPColor) -> XP ()
modifyColor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

-- | Reset the prompt colors to those from 'XPConfig'.
resetColor :: XP ()
resetColor :: XP ()
resetColor = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (XPConfig -> XPColor
defaultColor forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPConfig
config) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= XPColor -> XP ()
setColor

-- | Set the prompt border color.
setBorderColor :: String -> XPColor -> XPColor
setBorderColor :: String -> XPColor -> XPColor
setBorderColor String
bc XPColor
xpc = XPColor
xpc { border :: String
border = String
bc }

-- | Modify the prompter, i.e. for chaining prompters.
modifyPrompter :: ((String -> String) -> (String -> String)) -> XP ()
modifyPrompter :: ((String -> String) -> String -> String) -> XP ()
modifyPrompter (String -> String) -> String -> String
p = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { prompter :: String -> String
prompter = (String -> String) -> String -> String
p forall a b. (a -> b) -> a -> b
$ XPState -> String -> String
prompter XPState
s }

-- | Set the prompter.
setPrompter :: (String -> String) -> XP ()
setPrompter :: (String -> String) -> XP ()
setPrompter = ((String -> String) -> String -> String) -> XP ()
modifyPrompter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const

-- | Reset the prompter to the one from 'XPConfig'.
resetPrompter :: XP ()
resetPrompter :: XP ()
resetPrompter = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (XPConfig -> String -> String
defaultPrompter forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPConfig
config) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> String) -> XP ()
setPrompter

-- | Set the current completion list, or 'Nothing' to invalidate the current
-- completions.
setCurrentCompletions :: Maybe [String] -> XP ()
setCurrentCompletions :: Maybe [String] -> XP ()
setCurrentCompletions Maybe [String]
cs = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { currentCompletions :: Maybe [String]
currentCompletions = Maybe [String]
cs }

-- | Get the current completion list.
getCurrentCompletions :: XP (Maybe [String])
getCurrentCompletions :: XP (Maybe [String])
getCurrentCompletions = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Maybe [String]
currentCompletions

-- | 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 :: forall p a.
XPrompt p =>
p -> XPConfig -> ComplFunction -> (String -> X a) -> X (Maybe a)
mkXPromptWithReturn p
t XPConfig
conf ComplFunction
compl String -> X a
action = do
  XPState
st' <- String -> XPConfig -> XPOperationMode -> X XPState
mkXPromptImplementation (forall t. XPrompt t => t -> String
showXPrompt p
t) XPConfig
conf (ComplFunction -> XPType -> XPOperationMode
XPSingleMode ComplFunction
compl (forall p. XPrompt p => p -> XPType
XPT p
t))
  if XPState -> Bool
successful XPState
st'
    then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> X a
action (XPState -> String
selectedCompletion XPState
st')
    else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
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 :: forall p.
XPrompt p =>
p -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
mkXPrompt p
t XPConfig
conf ComplFunction
compl String -> X ()
action = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall p a.
XPrompt p =>
p -> XPConfig -> ComplFunction -> (String -> X a) -> X (Maybe a)
mkXPromptWithReturn p
t XPConfig
conf ComplFunction
compl String -> X ()
action

-- | 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 :: [XPType] -> XPConfig -> X ()
mkXPromptWithModes [] XPConfig
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
mkXPromptWithModes (XPType
defaultMode : [XPType]
modes) XPConfig
conf = do
  let modeStack :: Stack XPType
modeStack = W.Stack { focus :: XPType
W.focus = XPType
defaultMode -- Current mode
                          , up :: [XPType]
W.up = []
                          , down :: [XPType]
W.down = [XPType]
modes -- Other modes
                          }
      om :: XPOperationMode
om = Stack XPType -> XPOperationMode
XPMultipleModes Stack XPType
modeStack
  XPState
st' <- String -> XPConfig -> XPOperationMode -> X XPState
mkXPromptImplementation (forall t. XPrompt t => t -> String
showXPrompt XPType
defaultMode) XPConfig
conf { alwaysHighlight :: Bool
alwaysHighlight = Bool
True } XPOperationMode
om
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (XPState -> Bool
successful XPState
st') forall a b. (a -> b) -> a -> b
$
    case XPState -> XPOperationMode
operationMode XPState
st' of
      XPMultipleModes Stack XPType
ms -> let
        action :: String -> String -> X ()
action = forall t. XPrompt t => t -> String -> String -> X ()
modeAction forall a b. (a -> b) -> a -> b
$ forall a. Stack a -> a
W.focus Stack XPType
ms
        in String -> String -> X ()
action (XPState -> String
command XPState
st') forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe String
"" (XPState -> Maybe String
highlightedCompl XPState
st')
      XPOperationMode
_ -> forall a. HasCallStack => String -> a
error String
"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

-- Internal function used to implement 'mkXPromptWithReturn' and
-- 'mkXPromptWithModes'.
mkXPromptImplementation :: String -> XPConfig -> XPOperationMode -> X XPState
mkXPromptImplementation :: String -> XPConfig -> XPOperationMode -> X XPState
mkXPromptImplementation String
historyKey XPConfig
conf XPOperationMode
om = do
  XConf { display :: XConf -> Display
display = Display
d, theRoot :: XConf -> EventMask
theRoot = EventMask
rw } <- forall r (m :: * -> *). MonadReader r m => m r
ask
  Rectangle
s <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ ScreenDetail -> Rectangle
screenRect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> sd
W.screenDetail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset
  KeyMask -> KeyMask
cleanMask <- X (KeyMask -> KeyMask)
cleanKeyMask
  String
cachedir <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a. Directories' a -> a
cacheDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> Directories
directories)
  Map String [String]
hist <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ XPConfig -> String -> IO (Map String [String])
readHistory XPConfig
conf String
cachedir
  XMonadFont
fs <- String -> X XMonadFont
initXMF (XPConfig -> String
font XPConfig
conf)
  let width :: Dimension
width = Rectangle -> XPPosition -> Dimension
getWinWidth Rectangle
s (XPConfig -> XPPosition
position XPConfig
conf)
  XPState
st' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
      (Display
-> EventMask -> XPConfig -> Rectangle -> Dimension -> IO EventMask
createPromptWin Display
d EventMask
rw XPConfig
conf Rectangle
s Dimension
width)
      (Display -> EventMask -> IO ()
destroyWindow Display
d)
      (\EventMask
w ->
        forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
          (Display -> EventMask -> IO GC
createGC Display
d EventMask
w)
          (Display -> GC -> IO ()
freeGC Display
d)
          (\GC
gc -> do
            Display -> EventMask -> EventMask -> IO ()
selectInput Display
d EventMask
w forall a b. (a -> b) -> a -> b
$ EventMask
exposureMask forall a. Bits a => a -> a -> a
.|. EventMask
keyPressMask
            Display -> GC -> Bool -> IO ()
setGraphicsExposures Display
d GC
gc Bool
False
            let hs :: [String]
hs = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
historyKey Map String [String]
hist
                st :: XPState
st = Display
-> EventMask
-> EventMask
-> Rectangle
-> XPOperationMode
-> GC
-> XMonadFont
-> [String]
-> XPConfig
-> (KeyMask -> KeyMask)
-> Dimension
-> XPState
initState Display
d EventMask
rw EventMask
w Rectangle
s XPOperationMode
om GC
gc XMonadFont
fs [String]
hs XPConfig
conf KeyMask -> KeyMask
cleanMask Dimension
width
            XPState -> IO XPState
runXP XPState
st))
  XMonadFont -> X ()
releaseXMF XMonadFont
fs
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (XPState -> Bool
successful XPState
st') forall a b. (a -> b) -> a -> b
$ do
    let prune :: [a] -> [a]
prune = forall a. Int -> [a] -> [a]
take (XPConfig -> Int
historySize XPConfig
conf)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ XPConfig -> String -> Map String [String] -> IO ()
writeHistory XPConfig
conf String
cachedir forall a b. (a -> b) -> a -> b
$
      forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith
      (\[String]
xs [String]
ys -> forall {a}. [a] -> [a]
prune forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPConfig -> [String] -> [String]
historyFilter XPConfig
conf forall a b. (a -> b) -> a -> b
$ [String]
xs forall a. [a] -> [a] -> [a]
++ [String]
ys)
      String
historyKey
      -- We need to apply historyFilter before as well, since
      -- otherwise the filter would not be applied if there is no
      -- history
      (forall {a}. [a] -> [a]
prune forall a b. (a -> b) -> a -> b
$ XPConfig -> [String] -> [String]
historyFilter XPConfig
conf [XPState -> String
selectedCompletion XPState
st'])
      Map String [String]
hist
  forall (m :: * -> *) a. Monad m => a -> m a
return XPState
st'
 where
  -- | Based on the ultimate position of the prompt and the screen
  -- dimensions, calculate its width.
  getWinWidth :: Rectangle -> XPPosition -> Dimension
  getWinWidth :: Rectangle -> XPPosition -> Dimension
getWinWidth Rectangle
scr = \case
    CenteredAt{ Rational
xpWidth :: Rational
xpWidth :: XPPosition -> Rational
xpWidth } -> forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
scr) forall a. Num a => a -> a -> a
* Rational
xpWidth
    XPPosition
_                     -> Rectangle -> Dimension
rect_width Rectangle
scr

-- | Inverse of 'Codec.Binary.UTF8.String.utf8Encode', that is, a convenience
-- function that checks to see if the input string is UTF8 encoded before
-- decoding.
utf8Decode :: String -> String
utf8Decode :: String -> String
utf8Decode String
str
    | String -> Bool
isUTF8Encoded String
str = String -> String
decodeString String
str
    | Bool
otherwise         = String
str

runXP :: XPState -> IO XPState
runXP :: XPState -> IO XPState
runXP XPState
st = do
  let d :: Display
d = XPState -> Display
dpy XPState
st
      w :: EventMask
w = XPState -> EventMask
win XPState
st
  forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
    (Display
-> EventMask -> Bool -> CInt -> CInt -> EventMask -> IO CInt
grabKeyboard Display
d EventMask
w Bool
True CInt
grabModeAsync CInt
grabModeAsync EventMask
currentTime)
    (\CInt
_ -> Display -> EventMask -> IO ()
ungrabKeyboard Display
d EventMask
currentTime)
    (\CInt
status ->
      forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT
        (forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
status forall a. Eq a => a -> a -> Bool
== CInt
grabSuccess) forall a b. (a -> b) -> a -> b
$ do
          Bool
ah <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (XPConfig -> Bool
alwaysHighlight forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPConfig
config)
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ah forall a b. (a -> b) -> a -> b
$ do
            Maybe String
compl <- forall a. [a] -> Maybe a
listToMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XP [String]
getCompletions
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' forall a b. (a -> b) -> a -> b
$ \XPState
xpst -> XPState
xpst{ highlightedCompl :: Maybe String
highlightedCompl = Maybe String
compl }
          XP ()
updateWindows
          (KeyStroke -> Event -> XP ()) -> XP Bool -> XP ()
eventLoop KeyStroke -> Event -> XP ()
handleMain XP Bool
evDefaultStop)
        XPState
st
      forall a b. IO a -> IO b -> IO a
`finally` (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Display -> EventMask -> IO ()
destroyWindow Display
d) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. IORef a -> IO a
readIORef (XPState -> IORef (Maybe EventMask)
complWin XPState
st))
      forall a b. IO a -> IO b -> IO a
`finally` Display -> Bool -> IO ()
sync Display
d Bool
False)

type KeyStroke = (KeySym, String)

-- | Check whether the given key stroke is a modifier.
isModifier :: KeyStroke -> Bool
isModifier :: KeyStroke -> Bool
isModifier (EventMask
_, String
keyString) = forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
keyString

-- | Main event "loop". Gives priority to events from the state's event buffer.
eventLoop :: (KeyStroke -> Event -> XP ())
          -> XP Bool
          -> XP ()
eventLoop :: (KeyStroke -> Event -> XP ()) -> XP Bool -> XP ()
eventLoop KeyStroke -> Event -> XP ()
handle XP Bool
stopAction = do
    [(EventMask, String, Event)]
b <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> [(EventMask, String, Event)]
eventBuffer
    (EventMask
keysym,String
keystr,Event
event) <- case [(EventMask, String, Event)]
b of
        []  -> do
                Display
d <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Display
dpy
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent forall a b. (a -> b) -> a -> b
$ \XEventPtr
e -> do
                    -- Also capture @buttonPressMask@, see Note [Allow ButtonEvents]
                    Display -> EventMask -> XEventPtr -> IO ()
maskEvent Display
d (EventMask
exposureMask forall a. Bits a => a -> a -> a
.|. EventMask
keyPressMask forall a. Bits a => a -> a -> a
.|. EventMask
buttonPressMask) XEventPtr
e
                    Event
ev <- XEventPtr -> IO Event
getEvent XEventPtr
e
                    if Event -> Dimension
ev_event_type Event
ev forall a. Eq a => a -> a -> Bool
== Dimension
keyPress
                        then do (Maybe EventMask
_, String
s) <- XKeyEventPtr -> IO (Maybe EventMask, String)
lookupString forall a b. (a -> b) -> a -> b
$ XEventPtr -> XKeyEventPtr
asKeyEvent XEventPtr
e
                                EventMask
ks <- Display -> KeyCode -> CInt -> IO EventMask
keycodeToKeysym Display
d (Event -> KeyCode
ev_keycode Event
ev) CInt
0
                                forall (m :: * -> *) a. Monad m => a -> m a
return (EventMask
ks, String
s, Event
ev)
                        else forall (m :: * -> *) a. Monad m => a -> m a
return (EventMask
noSymbol, String
"", Event
ev)
        ((EventMask, String, Event)
l : [(EventMask, String, Event)]
ls) -> do
                forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { eventBuffer :: [(EventMask, String, Event)]
eventBuffer = [(EventMask, String, Event)]
ls }
                forall (m :: * -> *) a. Monad m => a -> m a
return (EventMask, String, Event)
l
    KeyStroke -> Event -> XP ()
handle (EventMask
keysym,String
keystr) Event
event
    XP Bool
stopAction forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
stop -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
stop ((KeyStroke -> Event -> XP ()) -> XP Bool -> XP ()
eventLoop KeyStroke -> Event -> XP ()
handle XP Bool
stopAction)

-- | Default event loop stop condition.
evDefaultStop :: XP Bool
evDefaultStop :: XP Bool
evDefaultStop = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Bool -> Bool -> Bool
(||) forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> Bool
modeDone) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Bool
done

-- | Common patterns shared by all event handlers.
handleOther :: KeyStroke -> Event -> XP ()
handleOther :: KeyStroke -> Event -> XP ()
handleOther KeyStroke
_ ExposeEvent{ev_window :: Event -> EventMask
ev_window = EventMask
w} = do
    -- Expose events can be triggered by switching virtual consoles.
    XPState
st <- forall s (m :: * -> *). MonadState s m => m s
get
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (XPState -> EventMask
win XPState
st forall a. Eq a => a -> a -> Bool
== EventMask
w) XP ()
updateWindows
handleOther KeyStroke
_ ButtonEvent{ev_event_type :: Event -> Dimension
ev_event_type = Dimension
t} = do
    -- See Note [Allow ButtonEvents]
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Dimension
t forall a. Eq a => a -> a -> Bool
== Dimension
buttonPress) forall a b. (a -> b) -> a -> b
$ do
        Display
d <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Display
dpy
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> CInt -> EventMask -> IO ()
allowEvents Display
d CInt
replayPointer EventMask
currentTime
handleOther KeyStroke
_ Event
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

{- Note [Allow ButtonEvents]

Some settings (like @clickJustFocuses = False@) set up the passive
pointer grabs that xmonad makes to intercept clicks to unfocused windows
with @pointer_mode = grabModeSync@ and @keyboard_mode = grabModeSync@.
This means that any click in an unfocused window leads to a
pointer/keyboard grab that freezes both devices until 'allowEvents' is
called. But "XMonad.Prompt" has its own X event loop, so 'allowEvents'
is never called and everything remains frozen indefinitely.

This does not happen when the grabs are made with @grabModeAsync@, as
pointer events processing is not frozen and the grab only lasts as long
as the mouse button is pressed.

Hence, in this situation we call 'allowEvents' in the prompts event loop
whenever a button event is received, releasing the pointer grab. In this
case, 'replayPointer' takes care of the fact that these events are not
merely discarded, but passed to the respective application window.
-}

-- | Prompt event handler for the main loop. Dispatches to input, completion
-- and mode switching handlers.
handleMain :: KeyStroke -> Event -> XP ()
handleMain :: KeyStroke -> Event -> XP ()
handleMain stroke :: KeyStroke
stroke@(EventMask
keysym, String
keystr) = \case
    KeyEvent{ev_event_type :: Event -> Dimension
ev_event_type = Dimension
t, ev_state :: Event -> KeyMask
ev_state = KeyMask
m} -> do
      ((KeyMask, EventMask)
prevCompKey, ((KeyMask, EventMask)
compKey, EventMask
modeKey)) <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$
          (XPConfig -> (KeyMask, EventMask)
prevCompletionKey forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPConfig -> (KeyMask, EventMask)
completionKey forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPConfig -> EventMask
changeModeKey) forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPConfig
config
      KeyMask
keymask <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> KeyMask -> KeyMask
cleanMask forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyMask
m
      -- haven't subscribed to keyRelease, so just in case
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Dimension
t forall a. Eq a => a -> a -> Bool
== Dimension
keyPress) forall a b. (a -> b) -> a -> b
$ if
          | (KeyMask
keymask, EventMask
keysym) forall a. Eq a => a -> a -> Bool
== (KeyMask, EventMask)
compKey ->
               XP (Maybe [String])
getCurrentCompletions forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Direction1D -> Maybe [String] -> XP ()
handleCompletionMain Direction1D
Next
          | (KeyMask
keymask, EventMask
keysym) forall a. Eq a => a -> a -> Bool
== (KeyMask, EventMask)
prevCompKey ->
               XP (Maybe [String])
getCurrentCompletions forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Direction1D -> Maybe [String] -> XP ()
handleCompletionMain Direction1D
Prev
          | Bool
otherwise -> do
               Map (KeyMask, EventMask) (XP ())
keymap <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (XPConfig -> Map (KeyMask, EventMask) (XP ())
promptKeymap forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPConfig
config)
               let mbAction :: Maybe (XP ())
mbAction = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (KeyMask
keymask, EventMask
keysym) Map (KeyMask, EventMask) (XP ())
keymap
               -- Either run when we can insert a valid character, or the
               -- pressed key has an action associated to it.
               forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (KeyStroke -> Bool
isModifier KeyStroke
stroke Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe (XP ())
mbAction) forall a b. (a -> b) -> a -> b
$ do
                   Maybe [String] -> XP ()
setCurrentCompletions forall a. Maybe a
Nothing
                   if EventMask
keysym forall a. Eq a => a -> a -> Bool
== EventMask
modeKey
                      then forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify XPState -> XPState
setNextMode forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
updateWindows
                      else KeyMask -> Maybe (XP ()) -> XP ()
handleInput KeyMask
keymask Maybe (XP ())
mbAction
    Event
event -> KeyStroke -> Event -> XP ()
handleOther KeyStroke
stroke Event
event
  where
    -- Prompt input handler for the main loop.
    handleInput :: KeyMask -> Maybe (XP ()) -> XP ()
    handleInput :: KeyMask -> Maybe (XP ()) -> XP ()
handleInput KeyMask
keymask = \case
        Just XP ()
action -> XP ()
action forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
updateWindows
        Maybe (XP ())
Nothing     -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeyMask
keymask forall a. Bits a => a -> a -> a
.&. KeyMask
controlMask forall a. Eq a => a -> a -> Bool
== KeyMask
0) forall a b. (a -> b) -> a -> b
$ do
            String -> XP ()
insertString forall a b. (a -> b) -> a -> b
$ String -> String
utf8Decode String
keystr
            XP ()
updateWindows
            XP ()
updateHighlightedCompl
            Bool
complete <- XP Bool
tryAutoComplete
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
complete XP ()
acceptSelection

-- There are two options to store the completion list during the main loop:
-- * Use the State monad, with 'Nothing' as the initial state.
-- * Join the output of the event loop handler to the input of the (same)
--   subsequent handler, using 'Nothing' as the initial input.
-- Both approaches are, under the hood, equivalent.
--
-- | Prompt completion handler for the main loop. Given 'Nothing', generate the
-- current completion list. With the current list, trigger a completion.
handleCompletionMain :: Direction1D -> Maybe [String] -> XP ()
handleCompletionMain :: Direction1D -> Maybe [String] -> XP ()
handleCompletionMain Direction1D
dir Maybe [String]
compls = case Maybe [String]
compls of
   Just [String]
cs -> Direction1D -> [String] -> XP ()
handleCompletion Direction1D
dir [String]
cs
   Maybe [String]
Nothing -> do
       [String]
cs <- XP [String]
getCompletions
       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
cs forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$
           forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { showComplWin :: Bool
showComplWin = Bool
True }
       Maybe [String] -> XP ()
setCurrentCompletions forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [String]
cs
       Direction1D -> [String] -> XP ()
handleCompletion Direction1D
dir [String]
cs

handleCompletion :: Direction1D -> [String] -> XP ()
handleCompletion :: Direction1D -> [String] -> XP ()
handleCompletion Direction1D
dir [String]
cs = do
    Bool
alwaysHlight <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ XPConfig -> Bool
alwaysHighlight forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPConfig
config
    XPState
st <- forall s (m :: * -> *). MonadState s m => m s
get

    let updateWins :: [String] -> XP ()
updateWins    = XP () -> [String] -> XP ()
redrawWindows (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        updateState :: [String] -> XP ()
updateState [String]
l = if Bool
alwaysHlight
            then String -> [String] -> XPState -> XP ()
hlComplete (String -> String
getLastWord forall a b. (a -> b) -> a -> b
$ XPState -> String
command XPState
st) [String]
l XPState
st
            else [String] -> XPState -> XP ()
simpleComplete                        [String]
l XPState
st

    case [String]
cs of
      []  -> XP ()
updateWindows
      [String
x] -> do [String] -> XP ()
updateState [String
x]
                [String]
cs' <- XP [String]
getCompletions
                [String] -> XP ()
updateWins [String]
cs'
                Maybe [String] -> XP ()
setCurrentCompletions forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [String]
cs'
      [String]
l   -> [String] -> XP ()
updateState [String]
l   forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> XP ()
updateWins [String]
l
    where
        -- When alwaysHighlight is off, just complete based on what the
        -- user has typed so far.
        simpleComplete :: [String] -> XPState -> XP ()
        simpleComplete :: [String] -> XPState -> XP ()
simpleComplete [String]
l XPState
st = do
          let newCommand :: String
newCommand = forall t. XPrompt t => t -> String -> [String] -> String
nextCompletion (XPState -> XPType
currentXPMode XPState
st) (XPState -> String
command XPState
st) [String]
l
          forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> String -> XPState -> XPState
setCommand String
newCommand forall a b. (a -> b) -> a -> b
$
                         XPState
s { offset :: Int
offset = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
newCommand
                           , highlightedCompl :: Maybe String
highlightedCompl = forall a. a -> Maybe a
Just String
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
        hlComplete :: String -> [String] -> XPState -> XP ()
        hlComplete :: String -> [String] -> XPState -> XP ()
hlComplete String
prevCompl [String]
l XPState
st
          | -- The current suggestion matches the command and is a
            -- proper suffix of the last suggestion, so replace it.
            Bool
isSuffixOfCmd Bool -> Bool -> Bool
&& Bool
isProperSuffixOfLast = String -> XP ()
replaceCompletion String
prevCompl

          | -- We only have one suggestion, so we need to be a little
            -- bit smart in order to avoid a loop.
            Just (String
ch :| []) <- forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [String]
cs =
              if XPState -> String
command XPState
st forall a. Eq a => a -> a -> Bool
== String
hlCompl
              then forall s (m :: * -> *). MonadState s m => s -> m ()
put XPState
st
              else String -> XP ()
replaceCompletion String
ch

            -- The current suggestion matches the command, so advance
            -- to the next completion and try again.
          | Bool
isSuffixOfCmd =
              String -> [String] -> XPState -> XP ()
hlComplete String
hlCompl [String]
l forall a b. (a -> b) -> a -> b
$ XPState
st{ complIndex :: (Int, Int)
complIndex = (Int, Int)
complIndex'
                                       , highlightedCompl :: Maybe String
highlightedCompl = Maybe String
nextHlCompl
                                       }

            -- If nothing matches at all, delete the suggestion and
            -- highlight the next one.
          | Bool
otherwise = String -> XP ()
replaceCompletion String
prevCompl
         where
          String
hlCompl     :: String       = forall a. a -> Maybe a -> a
fromMaybe (XPState -> String
command XPState
st) forall a b. (a -> b) -> a -> b
$ XPState -> [String] -> Maybe String
highlightedItem XPState
st [String]
l
          (Int, Int)
complIndex' :: (Int, Int)   = Direction1D -> XPState -> (Int, Int)
computeComplIndex Direction1D
dir XPState
st
          Maybe String
nextHlCompl :: Maybe String = XPState -> [String] -> Maybe String
highlightedItem XPState
st{ complIndex :: (Int, Int)
complIndex = (Int, Int)
complIndex' } [String]
cs

          Bool
isSuffixOfCmd        :: Bool = String
hlCompl forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` XPState -> String
command XPState
st
          Bool
isProperSuffixOfLast :: Bool =      String
hlCompl   forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
prevCompl
                                      Bool -> Bool -> Bool
&& Bool -> Bool
not (String
prevCompl forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
hlCompl)

          String -> XP ()
replaceCompletion :: String -> XP () = \String
str -> do
              forall s (m :: * -> *). MonadState s m => s -> m ()
put XPState
st
              forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
str) forall a b. (a -> b) -> a -> b
$ Direction1D -> XP ()
killWord Direction1D
Prev
              String -> XP ()
insertString' String
hlCompl
              XP ()
endOfLine

-- | Initiate a prompt sub-map event loop. Submaps are intended to provide
-- alternate keybindings. Accepts a default action and a mapping from key
-- combinations to actions. If no entry matches, the default action is run.
promptSubmap :: XP ()
             -> M.Map (KeyMask, KeySym) (XP ())
             -> XP ()
promptSubmap :: XP () -> Map (KeyMask, EventMask) (XP ()) -> XP ()
promptSubmap XP ()
defaultAction Map (KeyMask, EventMask) (XP ())
keymap = do
    Bool
md <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Bool
modeDone
    Bool -> XP ()
setModeDone Bool
False
    XP ()
updateWindows
    (KeyStroke -> Event -> XP ()) -> XP Bool -> XP ()
eventLoop (XP ()
-> Map (KeyMask, EventMask) (XP ()) -> KeyStroke -> Event -> XP ()
handleSubmap XP ()
defaultAction Map (KeyMask, EventMask) (XP ())
keymap) XP Bool
evDefaultStop
    Bool -> XP ()
setModeDone Bool
md

handleSubmap :: XP ()
             -> M.Map (KeyMask, KeySym) (XP ())
             -> KeyStroke
             -> Event
             -> XP ()
handleSubmap :: XP ()
-> Map (KeyMask, EventMask) (XP ()) -> KeyStroke -> Event -> XP ()
handleSubmap XP ()
defaultAction Map (KeyMask, EventMask) (XP ())
keymap KeyStroke
stroke KeyEvent{ev_event_type :: Event -> Dimension
ev_event_type = Dimension
t, ev_state :: Event -> KeyMask
ev_state = KeyMask
m} = do
    KeyMask
keymask <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> KeyMask -> KeyMask
cleanMask forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyMask
m
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Dimension
t forall a. Eq a => a -> a -> Bool
== Dimension
keyPress) forall a b. (a -> b) -> a -> b
$ XP ()
-> Map (KeyMask, EventMask) (XP ())
-> KeyMask
-> KeyStroke
-> XP ()
handleInputSubmap XP ()
defaultAction Map (KeyMask, EventMask) (XP ())
keymap KeyMask
keymask KeyStroke
stroke
handleSubmap XP ()
_ Map (KeyMask, EventMask) (XP ())
_ KeyStroke
stroke Event
event = KeyStroke -> Event -> XP ()
handleOther KeyStroke
stroke Event
event

handleInputSubmap :: XP ()
                  -> M.Map (KeyMask, KeySym) (XP ())
                  -> KeyMask
                  -> KeyStroke
                  -> XP ()
handleInputSubmap :: XP ()
-> Map (KeyMask, EventMask) (XP ())
-> KeyMask
-> KeyStroke
-> XP ()
handleInputSubmap XP ()
defaultAction Map (KeyMask, EventMask) (XP ())
keymap KeyMask
keymask stroke :: KeyStroke
stroke@(EventMask
keysym, String
_) =
    case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (KeyMask
keymask,EventMask
keysym) Map (KeyMask, EventMask) (XP ())
keymap of
        Just XP ()
action -> XP ()
action forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
updateWindows
        Maybe (XP ())
Nothing     -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (KeyStroke -> Bool
isModifier KeyStroke
stroke) forall a b. (a -> b) -> a -> b
$ XP ()
defaultAction forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
updateWindows

-- | Initiate a prompt input buffer event loop. Input is sent to a buffer and
-- bypasses the prompt. The provided function is given the existing buffer and
-- the input keystring. The first field of the result determines whether the
-- input loop continues (if @True@). The second field determines whether the
-- input is appended to the buffer, or dropped (if @False@). If the loop is to
-- stop without keeping input - that is, @(False,False)@ - the event is
-- prepended to the event buffer to be processed by the parent loop. This
-- allows loop to process both fixed and indeterminate inputs.
--
-- Result given @(continue,keep)@:
--
-- * cont and keep
--
--      * grow input buffer
--
-- * stop and keep
--
--      * grow input buffer
--      * stop loop
--
-- * stop and drop
--
--      * buffer event
--      * stop loop
--
-- * cont and drop
--
--      * do nothing
promptBuffer :: (String -> String -> (Bool,Bool)) -> XP String
promptBuffer :: (String -> String -> (Bool, Bool)) -> XP String
promptBuffer String -> String -> (Bool, Bool)
f = do
    Bool
md <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Bool
modeDone
    Bool -> XP ()
setModeDone Bool
False
    (KeyStroke -> Event -> XP ()) -> XP Bool -> XP ()
eventLoop ((String -> String -> (Bool, Bool)) -> KeyStroke -> Event -> XP ()
handleBuffer String -> String -> (Bool, Bool)
f) XP Bool
evDefaultStop
    String
buff <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> String
inputBuffer
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { inputBuffer :: String
inputBuffer = String
"" }
    Bool -> XP ()
setModeDone Bool
md
    forall (m :: * -> *) a. Monad m => a -> m a
return String
buff

handleBuffer :: (String -> String -> (Bool,Bool))
             -> KeyStroke
             -> Event
             -> XP ()
handleBuffer :: (String -> String -> (Bool, Bool)) -> KeyStroke -> Event -> XP ()
handleBuffer String -> String -> (Bool, Bool)
f KeyStroke
stroke event :: Event
event@KeyEvent{ev_event_type :: Event -> Dimension
ev_event_type = Dimension
t, ev_state :: Event -> KeyMask
ev_state = KeyMask
m} = do
    KeyMask
keymask <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> KeyMask -> KeyMask
cleanMask forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyMask
m
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Dimension
t forall a. Eq a => a -> a -> Bool
== Dimension
keyPress) forall a b. (a -> b) -> a -> b
$ (String -> String -> (Bool, Bool))
-> KeyMask -> KeyStroke -> Event -> XP ()
handleInputBuffer String -> String -> (Bool, Bool)
f KeyMask
keymask KeyStroke
stroke Event
event
handleBuffer String -> String -> (Bool, Bool)
_ KeyStroke
stroke Event
event = KeyStroke -> Event -> XP ()
handleOther KeyStroke
stroke Event
event

handleInputBuffer :: (String -> String -> (Bool,Bool))
                  -> KeyMask
                  -> KeyStroke
                  -> Event
                  -> XP ()
handleInputBuffer :: (String -> String -> (Bool, Bool))
-> KeyMask -> KeyStroke -> Event -> XP ()
handleInputBuffer String -> String -> (Bool, Bool)
f KeyMask
keymask stroke :: KeyStroke
stroke@(EventMask
keysym, String
keystr) Event
event =
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (KeyStroke -> Bool
isModifier KeyStroke
stroke Bool -> Bool -> Bool
|| KeyMask
keymask forall a. Bits a => a -> a -> a
.&. KeyMask
controlMask forall a. Eq a => a -> a -> Bool
/= KeyMask
0) forall a b. (a -> b) -> a -> b
$ do
        ([(EventMask, String, Event)]
evB,String
inB) <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (XPState -> [(EventMask, String, Event)]
eventBuffer forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPState -> String
inputBuffer)
        let keystr' :: String
keystr' = String -> String
utf8Decode String
keystr
        let (Bool
cont,Bool
keep) = String -> String -> (Bool, Bool)
f String
inB String
keystr'
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
keep forall a b. (a -> b) -> a -> b
$
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { inputBuffer :: String
inputBuffer = String
inB forall a. [a] -> [a] -> [a]
++ String
keystr' }
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
cont forall a b. (a -> b) -> a -> b
$
            Bool -> XP ()
setModeDone Bool
True
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
cont Bool -> Bool -> Bool
|| Bool
keep) forall a b. (a -> b) -> a -> b
$
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { eventBuffer :: [(EventMask, String, Event)]
eventBuffer = (EventMask
keysym,String
keystr,Event
event) forall a. a -> [a] -> [a]
: [(EventMask, String, Event)]
evB }

-- | Predicate instructing 'promptBuffer' to get (and keep) a single non-empty
-- 'KeyEvent'.
bufferOne :: String -> String -> (Bool,Bool)
bufferOne :: String -> String -> (Bool, Bool)
bufferOne String
xs String
x = (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
xs Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x,Bool
True)

-- | Return the @(column, row)@ of the desired highlight, or @(0, 0)@ if
-- there is no prompt window or a wrap-around occurs.
computeComplIndex :: Direction1D -> XPState -> (Int, Int)
computeComplIndex :: Direction1D -> XPState -> (Int, Int)
computeComplIndex Direction1D
dir XPState
st = case XPState -> Maybe ComplWindowDim
complWinDim XPState
st of
  Maybe ComplWindowDim
Nothing -> (Int
0, Int
0)  -- no window dimensions (just destroyed or not created)
  Just ComplWindowDim{ [Position]
cwCols :: [Position]
cwCols :: ComplWindowDim -> [Position]
cwCols, [Position]
cwRows :: [Position]
cwRows :: ComplWindowDim -> [Position]
cwRows } ->
    if Int
rowm forall a. Eq a => a -> a -> Bool
== Int
currentrow forall a. Num a => a -> a -> a
+ Int
direction
    then (Int
currentcol, Int
rowm)  -- We are not in the last row, so advance the row
    else (Int
colm, Int
rowm)        -- otherwise advance to the respective column
   where
    (Int
currentcol, Int
currentrow) = XPState -> (Int, Int)
complIndex XPState
st
    (Int
colm, Int
rowm) =
      ( (Int
currentcol forall a. Num a => a -> a -> a
+ Int
direction) forall a. Integral a => a -> a -> a
`mod` forall (t :: * -> *) a. Foldable t => t a -> Int
length [Position]
cwCols
      , (Int
currentrow forall a. Num a => a -> a -> a
+ Int
direction) forall a. Integral a => a -> a -> a
`mod` forall (t :: * -> *) a. Foldable t => t a -> Int
length [Position]
cwRows
      )
    direction :: Int
direction = case Direction1D
dir of
      Direction1D
Next ->  Int
1
      Direction1D
Prev -> -Int
1

tryAutoComplete :: XP Bool
tryAutoComplete :: XP Bool
tryAutoComplete = do
    Maybe Int
ac <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (XPConfig -> Maybe Int
autoComplete forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPConfig
config)
    case Maybe Int
ac of
        Just Int
d -> do [String]
cs <- XP [String]
getCompletions
                     case [String]
cs of
                         [String
c] -> String -> Int -> XP Bool
runCompleted String
c Int
d forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                         [String]
_   -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Maybe Int
Nothing    -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where runCompleted :: String -> Int -> XP Bool
runCompleted String
cmd Int
delay = do
            XPState
st <- forall s (m :: * -> *). MonadState s m => m s
get
            let new_command :: String
new_command = forall t. XPrompt t => t -> String -> [String] -> String
nextCompletion (XPState -> XPType
currentXPMode XPState
st) (XPState -> String
command XPState
st) [String
cmd]
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ String -> XPState -> XPState
setCommand String
"autocompleting..."
            XP ()
updateWindows
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
delay
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ String -> XPState -> XPState
setCommand String
new_command
            forall (m :: * -> *) a. Monad m => a -> m a
return Bool
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 :: Map (KeyMask, EventMask) (XP ())
defaultXPKeymap = (Char -> Bool) -> Map (KeyMask, EventMask) (XP ())
defaultXPKeymap' Char -> Bool
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' :: (Char -> Bool) -> Map (KeyMask, EventMask) (XP ())
defaultXPKeymap' Char -> Bool
p = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$
  forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a -> b) -> a -> b
$ (,) KeyMask
controlMask) -- control + <key>
  [ (EventMask
xK_u, XP ()
killBefore)
  , (EventMask
xK_k, XP ()
killAfter)
  , (EventMask
xK_a, XP ()
startOfLine)
  , (EventMask
xK_e, XP ()
endOfLine)
  , (EventMask
xK_y, XP ()
pasteString)
  -- Retain the pre-0.14 moveWord' behavior:
  , (EventMask
xK_Right, (Char -> Bool) -> Direction1D -> XP ()
moveWord' Char -> Bool
p Direction1D
Next forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursor Direction1D
Next)
  , (EventMask
xK_Left, Direction1D -> XP ()
moveCursor Direction1D
Prev forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Direction1D -> XP ()
moveWord' Char -> Bool
p Direction1D
Prev)
  , (EventMask
xK_Delete, (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
p Direction1D
Next)
  , (EventMask
xK_BackSpace, (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
p Direction1D
Prev)
  , (EventMask
xK_w, (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
p Direction1D
Prev)
  , (EventMask
xK_g, XP ()
quit)
  , (EventMask
xK_bracketleft, XP ()
quit)
  ] forall a. [a] -> [a] -> [a]
++
  forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a -> b) -> a -> b
$ (,) KeyMask
0)
  [ (EventMask
xK_Return, XP ()
acceptSelection)
  , (EventMask
xK_KP_Enter, XP ()
acceptSelection)
  , (EventMask
xK_BackSpace, Direction1D -> XP ()
deleteString Direction1D
Prev)
  , (EventMask
xK_Delete, Direction1D -> XP ()
deleteString Direction1D
Next)
  , (EventMask
xK_Left, Direction1D -> XP ()
moveCursor Direction1D
Prev)
  , (EventMask
xK_Right, Direction1D -> XP ()
moveCursor Direction1D
Next)
  , (EventMask
xK_Home, XP ()
startOfLine)
  , (EventMask
xK_End, XP ()
endOfLine)
  , (EventMask
xK_Down, (Stack String -> Stack String) -> XP ()
moveHistory forall a. Stack a -> Stack a
W.focusUp')
  , (EventMask
xK_Up, (Stack String -> Stack String) -> XP ()
moveHistory forall a. Stack a -> Stack a
W.focusDown')
  , (EventMask
xK_Escape, XP ()
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 :: Map (KeyMask, EventMask) (XP ())
emacsLikeXPKeymap = (Char -> Bool) -> Map (KeyMask, EventMask) (XP ())
emacsLikeXPKeymap' Char -> Bool
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' :: (Char -> Bool) -> Map (KeyMask, EventMask) (XP ())
emacsLikeXPKeymap' Char -> Bool
p = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$
  forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a -> b) -> a -> b
$ (,) KeyMask
controlMask) -- control + <key>
  [ (EventMask
xK_z, XP ()
killBefore) --kill line backwards
  , (EventMask
xK_k, XP ()
killAfter) -- kill line fowards
  , (EventMask
xK_a, XP ()
startOfLine) --move to the beginning of the line
  , (EventMask
xK_e, XP ()
endOfLine) -- move to the end of the line
  , (EventMask
xK_d, Direction1D -> XP ()
deleteString Direction1D
Next) -- delete a character foward
  , (EventMask
xK_b, Direction1D -> XP ()
moveCursor Direction1D
Prev) -- move cursor forward
  , (EventMask
xK_f, Direction1D -> XP ()
moveCursor Direction1D
Next) -- move cursor backward
  , (EventMask
xK_BackSpace, (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
p Direction1D
Prev) -- kill the previous word
  , (EventMask
xK_y, XP ()
pasteString)
  , (EventMask
xK_g, XP ()
quit)
  , (EventMask
xK_bracketleft, XP ()
quit)
  , (EventMask
xK_t, XP ()
transposeChars)
  , (EventMask
xK_m, XP ()
acceptSelection)
  ] forall a. [a] -> [a] -> [a]
++
  forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a -> b) -> a -> b
$ (,) KeyMask
mod1Mask) -- meta key + <key>
  [ (EventMask
xK_BackSpace, (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
p Direction1D
Prev)
  -- Retain the pre-0.14 moveWord' behavior:
  , (EventMask
xK_f, (Char -> Bool) -> Direction1D -> XP ()
moveWord' Char -> Bool
p Direction1D
Next forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursor Direction1D
Next) -- move a word forward
  , (EventMask
xK_b, Direction1D -> XP ()
moveCursor Direction1D
Prev forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Direction1D -> XP ()
moveWord' Char -> Bool
p Direction1D
Prev) -- move a word backward
  , (EventMask
xK_d, (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
p Direction1D
Next) -- kill the next word
  , (EventMask
xK_n, (Stack String -> Stack String) -> XP ()
moveHistory forall a. Stack a -> Stack a
W.focusUp')
  , (EventMask
xK_p, (Stack String -> Stack String) -> XP ()
moveHistory forall a. Stack a -> Stack a
W.focusDown')
  ]
  forall a. [a] -> [a] -> [a]
++
  forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a -> b) -> a -> b
$ (,) KeyMask
0) -- <key>
  [ (EventMask
xK_Return, XP ()
acceptSelection)
  , (EventMask
xK_KP_Enter, XP ()
acceptSelection)
  , (EventMask
xK_BackSpace, Direction1D -> XP ()
deleteString Direction1D
Prev)
  , (EventMask
xK_Delete, Direction1D -> XP ()
deleteString Direction1D
Next)
  , (EventMask
xK_Left, Direction1D -> XP ()
moveCursor Direction1D
Prev)
  , (EventMask
xK_Right, Direction1D -> XP ()
moveCursor Direction1D
Next)
  , (EventMask
xK_Home, XP ()
startOfLine)
  , (EventMask
xK_End, XP ()
endOfLine)
  , (EventMask
xK_Down, (Stack String -> Stack String) -> XP ()
moveHistory forall a. Stack a -> Stack a
W.focusUp')
  , (EventMask
xK_Up, (Stack String -> Stack String) -> XP ()
moveHistory forall a. Stack a -> Stack a
W.focusDown')
  , (EventMask
xK_Escape, XP ()
quit)
  ]

-- | Vim-ish key bindings. Click on the \"Source\" link to the right to see the
-- complete list. See also 'vimLikeXPKeymap''.
vimLikeXPKeymap :: M.Map (KeyMask,KeySym) (XP ())
vimLikeXPKeymap :: Map (KeyMask, EventMask) (XP ())
vimLikeXPKeymap = (XPColor -> XPColor)
-> (String -> String)
-> (String -> String)
-> (Char -> Bool)
-> Map (KeyMask, EventMask) (XP ())
vimLikeXPKeymap' (String -> XPColor -> XPColor
setBorderColor String
"grey22") forall a. a -> a
id forall a. a -> a
id Char -> Bool
isSpace

-- | A variant of 'vimLikeXPKeymap' with customizable aspects:
vimLikeXPKeymap' :: (XPColor -> XPColor)
                    -- ^ Modifies the prompt color when entering normal mode.
                    -- The default is @setBorderColor "grey22"@ - same color as
                    -- the default background color.
                 -> (String -> String)
                    -- ^ Prompter to use in normal mode. The default of 'id'
                    -- balances 'defaultPrompter' but @("[n] " ++)@ is a good
                    -- alternate with 'defaultPrompter' as @("[i] " ++)@.
                 -> (String -> String)
                    -- ^ Filter applied to the X Selection before pasting. The
                    -- default is 'id' but @filter isPrint@ is a good
                    -- alternate.
                 -> (Char -> Bool)
                    -- ^ Predicate identifying non-word characters. The default
                    -- is 'isSpace'. See the documentation of other keymaps for
                    -- alternates.
                 -> M.Map (KeyMask,KeySym) (XP ())
vimLikeXPKeymap' :: (XPColor -> XPColor)
-> (String -> String)
-> (String -> String)
-> (Char -> Bool)
-> Map (KeyMask, EventMask) (XP ())
vimLikeXPKeymap' XPColor -> XPColor
fromColor String -> String
promptF String -> String
pasteFilter Char -> Bool
notWord = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a -> b) -> a -> b
$ (,) KeyMask
controlMask) -- control + <key>
    [ (EventMask
xK_m, XP ()
acceptSelection)
    ] forall a. [a] -> [a] -> [a]
++
    forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a -> b) -> a -> b
$ (,) KeyMask
0)
    [ (EventMask
xK_Return,       XP ()
acceptSelection)
    , (EventMask
xK_KP_Enter,     XP ()
acceptSelection)
    , (EventMask
xK_BackSpace,    Direction1D -> XP ()
deleteString Direction1D
Prev)
    , (EventMask
xK_Delete,       Direction1D -> XP ()
deleteString Direction1D
Next)
    , (EventMask
xK_Left,         Direction1D -> XP ()
moveCursor Direction1D
Prev)
    , (EventMask
xK_Right,        Direction1D -> XP ()
moveCursor Direction1D
Next)
    , (EventMask
xK_Home,         XP ()
startOfLine)
    , (EventMask
xK_End,          XP ()
endOfLine)
    , (EventMask
xK_Down,         (Stack String -> Stack String) -> XP ()
moveHistory forall a. Stack a -> Stack a
W.focusUp')
    , (EventMask
xK_Up,           (Stack String -> Stack String) -> XP ()
moveHistory forall a. Stack a -> Stack a
W.focusDown')
    , (EventMask
xK_Escape,       Direction1D -> XP ()
moveCursor Direction1D
Prev
                            forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (XPColor -> XPColor) -> XP ()
modifyColor XPColor -> XPColor
fromColor
                            forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (String -> String) -> XP ()
setPrompter String -> String
promptF
                            forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP () -> Map (KeyMask, EventMask) (XP ()) -> XP ()
promptSubmap (forall (m :: * -> *) a. Monad m => a -> m a
return ()) Map (KeyMask, EventMask) (XP ())
normalVimXPKeymap
                            forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
resetColor
                            forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
resetPrompter
      )
    ] where
    normalVimXPKeymap :: Map (KeyMask, EventMask) (XP ())
normalVimXPKeymap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a -> b) -> a -> b
$ (,) KeyMask
0)
        [ (EventMask
xK_i,            Bool -> XP ()
setModeDone Bool
True)
        , (EventMask
xK_a,            Direction1D -> XP ()
moveCursor Direction1D
Next forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True)
        , (EventMask
xK_s,            Direction1D -> XP ()
deleteString Direction1D
Next forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True)
        , (EventMask
xK_x,            Direction1D -> XP ()
deleteString Direction1D
Next forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
clipCursor)
        , (EventMask
xK_Delete,       Direction1D -> XP ()
deleteString Direction1D
Next forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
clipCursor)
        , (EventMask
xK_p,            Direction1D -> XP ()
moveCursor Direction1D
Next
                                forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (String -> String) -> XP ()
pasteString' String -> String
pasteFilter
                                forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursor Direction1D
Prev
          )
        , (EventMask
xK_0,            XP ()
startOfLine)
        , (EventMask
xK_Escape,       XP ()
quit)
        , (EventMask
xK_Down,         (Stack String -> Stack String) -> XP ()
moveHistory forall a. Stack a -> Stack a
W.focusUp')
        , (EventMask
xK_j,            (Stack String -> Stack String) -> XP ()
moveHistory forall a. Stack a -> Stack a
W.focusUp')
        , (EventMask
xK_Up,           (Stack String -> Stack String) -> XP ()
moveHistory forall a. Stack a -> Stack a
W.focusDown')
        , (EventMask
xK_k,            (Stack String -> Stack String) -> XP ()
moveHistory forall a. Stack a -> Stack a
W.focusDown')
        , (EventMask
xK_Right,        Direction1D -> XP ()
moveCursorClip Direction1D
Next)
        , (EventMask
xK_l,            Direction1D -> XP ()
moveCursorClip Direction1D
Next)
        , (EventMask
xK_h,            Direction1D -> XP ()
moveCursorClip Direction1D
Prev)
        , (EventMask
xK_Left,         Direction1D -> XP ()
moveCursorClip Direction1D
Prev)
        , (EventMask
xK_BackSpace,    Direction1D -> XP ()
moveCursorClip Direction1D
Prev)
        -- Implementation using the original 'moveWord'':
        --, (xK_e,            moveCursor Next >> moveWord' notWord Next >> moveCursor Prev)
        --, (xK_b,            moveWord' notWord Prev)
        --, (xK_w,            moveWord' (not . notWord) Next >> clipCursor)
        , (EventMask
xK_e,            Direction1D -> XP ()
moveCursorClip Direction1D
Next forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Direction1D -> XP ()
moveWord' Char -> Bool
notWord Direction1D
Next)
        , (EventMask
xK_b,            Direction1D -> XP ()
moveCursorClip Direction1D
Prev forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Direction1D -> XP ()
moveWord' Char -> Bool
notWord Direction1D
Prev)
        , (EventMask
xK_w,            (Char -> Bool) -> Direction1D -> XP ()
moveWord' (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
notWord) Direction1D
Next forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursorClip Direction1D
Next)
        , (EventMask
xK_f,            (String -> String -> (Bool, Bool)) -> XP String
promptBuffer String -> String -> (Bool, Bool)
bufferOne forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Direction1D -> String -> XP ()
toHeadChar Direction1D
Next)
        , (EventMask
xK_d,            XP () -> Map (KeyMask, EventMask) (XP ()) -> XP ()
promptSubmap (Bool -> XP ()
setModeDone Bool
True) Map (KeyMask, EventMask) (XP ())
deleteVimXPKeymap)
        , (EventMask
xK_c,            XP () -> Map (KeyMask, EventMask) (XP ()) -> XP ()
promptSubmap (Bool -> XP ()
setModeDone Bool
True) Map (KeyMask, EventMask) (XP ())
changeVimXPKeymap
                                forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True
          )
        , (EventMask
xK_Return,       XP ()
acceptSelection)
        , (EventMask
xK_KP_Enter,     XP ()
acceptSelection)
        ] forall a. [a] -> [a] -> [a]
++
        forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall a b. (a -> b) -> a -> b
$ (,) KeyMask
shiftMask)
        [ (EventMask
xK_dollar,       XP ()
endOfLine forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursor Direction1D
Prev)
        , (EventMask
xK_D,            XP ()
killAfter forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursor Direction1D
Prev)
        , (EventMask
xK_C,            XP ()
killAfter forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True)
        , (EventMask
xK_P,            (String -> String) -> XP ()
pasteString' String -> String
pasteFilter forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursor Direction1D
Prev)
        , (EventMask
xK_A,            XP ()
endOfLine forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True)
        , (EventMask
xK_I,            XP ()
startOfLine forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True)
        , (EventMask
xK_F,            (String -> String -> (Bool, Bool)) -> XP String
promptBuffer String -> String -> (Bool, Bool)
bufferOne forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Direction1D -> String -> XP ()
toHeadChar Direction1D
Prev)
        ]
    deleteVimXPKeymap :: Map (KeyMask, EventMask) (XP ())
deleteVimXPKeymap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (KeyMask
0 ,) (forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True))
        [ (EventMask
xK_e,            Direction1D -> XP ()
deleteString Direction1D
Next forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
notWord Direction1D
Next forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
clipCursor)
        , (EventMask
xK_w,            (Char -> Bool) -> Direction1D -> XP ()
killWord' (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
notWord) Direction1D
Next forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
clipCursor)
        , (EventMask
xK_0,            XP ()
killBefore)
        , (EventMask
xK_b,            (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
notWord Direction1D
Prev)
        , (EventMask
xK_d,            String -> XP ()
setInput String
"")
        ] forall a. [a] -> [a] -> [a]
++
        forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (KeyMask
shiftMask ,) (forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True))
        [ (EventMask
xK_dollar,       XP ()
killAfter forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursor Direction1D
Prev)
        ]
    changeVimXPKeymap :: Map (KeyMask, EventMask) (XP ())
changeVimXPKeymap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (KeyMask
0 ,) (forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True))
        [ (EventMask
xK_e,            Direction1D -> XP ()
deleteString Direction1D
Next forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
notWord Direction1D
Next)
        , (EventMask
xK_0,            XP ()
killBefore)
        , (EventMask
xK_b,            (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
notWord Direction1D
Prev)
        , (EventMask
xK_c,            String -> XP ()
setInput String
"")
        , (EventMask
xK_w,            (Char -> Bool) -> XP ()
changeWord Char -> Bool
notWord)
        ] forall a. [a] -> [a] -> [a]
++
        forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (KeyMask
shiftMask, ) (forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True))
        [ (EventMask
xK_dollar,       XP ()
killAfter)
        ]

-- Useful for exploring off-by-one issues.
--testOffset :: XP ()
--testOffset = do
--    off <- getOffset
--    str <- getInput
--    setInput $ str ++ "|" ++ (show off) ++ ":" ++ (show $ length str)

-- | Set @True@ to save the prompt's entry to history and run it via the
-- provided action.
setSuccess :: Bool -> XP ()
setSuccess :: Bool -> XP ()
setSuccess Bool
b = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { successful :: Bool
successful = Bool
b }

-- | Set @True@ to leave all event loops, no matter how nested.
setDone :: Bool -> XP ()
setDone :: Bool -> XP ()
setDone Bool
b = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { done :: Bool
done = Bool
b }

-- | Set @True@ to leave the current event loop, i.e. submaps.
setModeDone :: Bool -> XP ()
setModeDone :: Bool -> XP ()
setModeDone Bool
b = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { modeDone :: Bool
modeDone = Bool
b }

-- KeyPress and State

-- | Accept the current selection and exit.
acceptSelection :: StateT XPState IO ()
acceptSelection :: XP ()
acceptSelection = Bool -> XP ()
setSuccess Bool
True forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setDone Bool
True

-- | Quit.
quit :: XP ()
quit :: XP ()
quit = XP ()
flushString forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setSuccess Bool
False forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setDone Bool
True forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True

-- | Kill the portion of the command before the cursor
killBefore :: XP ()
killBefore :: XP ()
killBefore =
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> String -> XPState -> XPState
setCommand (forall a. Int -> [a] -> [a]
drop (XPState -> Int
offset XPState
s) (XPState -> String
command XPState
s)) forall a b. (a -> b) -> a -> b
$ XPState
s { offset :: Int
offset  = Int
0 }

-- | Kill the portion of the command including and after the cursor
killAfter :: XP ()
killAfter :: XP ()
killAfter =
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> String -> XPState -> XPState
setCommand (forall a. Int -> [a] -> [a]
take (XPState -> Int
offset XPState
s) (XPState -> String
command XPState
s)) XPState
s

-- | Kill the next\/previous word, using 'isSpace' as the default
--   predicate for non-word characters.  See 'killWord''.
killWord :: Direction1D -> XP ()
killWord :: Direction1D -> XP ()
killWord = (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
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' :: (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
p Direction1D
d = do
  Int
o <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Int
offset
  String
c <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> String
command
  let (String
f,String
ss)        = forall a. Int -> [a] -> ([a], [a])
splitAt Int
o String
c
      delNextWord :: String -> String
delNextWord   = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
p) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
p
      delPrevWord :: String -> String
delPrevWord   = forall {a}. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
delNextWord forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. [a] -> [a]
reverse
      (String
ncom,Int
noff)   =
          case Direction1D
d of
            Direction1D
Next -> (String
f forall a. [a] -> [a] -> [a]
++ String -> String
delNextWord String
ss, Int
o)
            Direction1D
Prev -> (String -> String
delPrevWord String
f forall a. [a] -> [a] -> [a]
++ String
ss, forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ String -> String
delPrevWord String
f) -- laziness!!
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> String -> XPState -> XPState
setCommand String
ncom forall a b. (a -> b) -> a -> b
$ XPState
s { offset :: Int
offset = Int
noff}

-- | From Vim's @:help cw@:
--
-- * Special case: When the cursor is in a word, "cw" and "cW" do not include
--   the white space after a word, they only change up to the end of the word.
changeWord :: (Char -> Bool) -> XP ()
changeWord :: (Char -> Bool) -> XP ()
changeWord Char -> Bool
p = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ String -> Int -> (Char -> Bool) -> XP ()
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XP String
getInput forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> XP Int
getOffset forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Char -> Bool
p
    where
        f :: String -> Int -> (Char -> Bool) -> XP ()
        f :: String -> Int -> (Char -> Bool) -> XP ()
f String
str Int
off Char -> Bool
_ | forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str forall a. Ord a => a -> a -> Bool
<= Int
off Bool -> Bool -> Bool
||
                      forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
str              = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        f String
str Int
off Char -> Bool
p'| Char -> Bool
p' forall a b. (a -> b) -> a -> b
$ String
str forall a. [a] -> Int -> a
!! Int
off       = (Char -> Bool) -> Direction1D -> XP ()
killWord' (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
p') Direction1D
Next
                    | Bool
otherwise             = (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
p' Direction1D
Next

-- | Interchange characters around point, moving forward one character
--   if not at the end of the input.
transposeChars :: XP ()
transposeChars :: XP ()
transposeChars = do
  Int
off <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Int
offset
  String
cmd <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> String
command
  let (String
beforeCursor, String
afterCursor) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
off String
cmd
      (String
ncom, Int
noff) = forall a. a -> Maybe a -> a
fromMaybe (String
cmd, Int
off) (forall a. [a] -> [a] -> Int -> Maybe ([a], Int)
go String
beforeCursor String
afterCursor Int
off)
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> String -> XPState -> XPState
setCommand String
ncom forall a b. (a -> b) -> a -> b
$ XPState
s{ offset :: Int
offset = Int
noff }
 where
  go :: [a] -> [a] -> Int -> Maybe ([a], Int)
  go :: forall a. [a] -> [a] -> Int -> Maybe ([a], Int)
go (forall {a}. [a] -> [a]
reverse -> (a
b1 : a
b2 : [a]
bs)) [] Int
offset =  -- end of line
    forall a. a -> Maybe a
Just (forall {a}. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ a
b2 forall a. a -> [a] -> [a]
: a
b1 forall a. a -> [a] -> [a]
: [a]
bs, Int
offset)
  go (forall {a}. [a] -> [a]
reverse -> (a
b : [a]
bs)) (a
a : [a]
as) Int
offset =  -- middle of line
    forall a. a -> Maybe a
Just (forall {a}. [a] -> [a]
reverse (a
a forall a. a -> [a] -> [a]
: [a]
bs) forall a. [a] -> [a] -> [a]
++ a
b forall a. a -> [a] -> [a]
: [a]
as, Int
offset forall a. Num a => a -> a -> a
+ Int
1)
  go [a]
_ [a]
_ Int
_ = forall a. Maybe a
Nothing

-- | Put the cursor at the end of line
endOfLine :: XP ()
endOfLine :: XP ()
endOfLine  =
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { offset :: Int
offset = forall (t :: * -> *) a. Foldable t => t a -> Int
length (XPState -> String
command XPState
s)}

-- | Put the cursor at the start of line
startOfLine :: XP ()
startOfLine :: XP ()
startOfLine  =
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { offset :: Int
offset = Int
0 }

-- |  Flush the command string and reset the offset
flushString :: XP ()
flushString :: XP ()
flushString = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> String -> XPState -> XPState
setCommand String
"" forall a b. (a -> b) -> a -> b
$ XPState
s { offset :: Int
offset = Int
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 :: XPState -> XPState
resetComplIndex XPState
st = if XPConfig -> Bool
alwaysHighlight (XPState -> XPConfig
config XPState
st) then XPState
st { complIndex :: (Int, Int)
complIndex = (Int
0,Int
0) } else XPState
st

-- | Insert a character at the cursor position
insertString :: String -> XP ()
insertString :: String -> XP ()
insertString String
str = do
  String -> XP ()
insertString' String
str
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify XPState -> XPState
resetComplIndex

insertString' :: String -> XP ()
insertString' :: String -> XP ()
insertString' String
str =
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> let
    cmd :: String
cmd = String -> Int -> String
c (XPState -> String
command XPState
s) (XPState -> Int
offset XPState
s)
    st :: XPState
st = XPState
s { offset :: Int
offset = Int -> Int
o (XPState -> Int
offset XPState
s)}
    in String -> XPState -> XPState
setCommand String
cmd XPState
st
  where o :: Int -> Int
o Int
oo = Int
oo forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str
        c :: String -> Int -> String
c String
oc Int
oo | Int
oo forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length String
oc = String
oc forall a. [a] -> [a] -> [a]
++ String
str
                | Bool
otherwise = String
f forall a. [a] -> [a] -> [a]
++ String
str forall a. [a] -> [a] -> [a]
++ String
ss
                where (String
f,String
ss) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
oo String
oc

-- | Insert the current X selection string at the cursor position. The X
-- selection is not modified.
pasteString :: XP ()
pasteString :: XP ()
pasteString = (String -> String) -> XP ()
pasteString' forall a. a -> a
id

-- | A variant of 'pasteString' which allows modifying the X selection before
-- pasting.
pasteString' :: (String -> String) -> XP ()
pasteString' :: (String -> String) -> XP ()
pasteString' String -> String
f = String -> XP ()
insertString forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadIO m => m String
getSelection

-- | Remove a character at the cursor position
deleteString :: Direction1D -> XP ()
deleteString :: Direction1D -> XP ()
deleteString Direction1D
d =
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> String -> XPState -> XPState
setCommand (forall {a}. [a] -> Int -> [a]
c (XPState -> String
command XPState
s) (XPState -> Int
offset XPState
s)) forall a b. (a -> b) -> a -> b
$ XPState
s { offset :: Int
offset = forall {a}. (Ord a, Num a) => a -> a
o (XPState -> Int
offset XPState
s)}
  where o :: a -> a
o a
oo = if Direction1D
d forall a. Eq a => a -> a -> Bool
== Direction1D
Prev then forall a. Ord a => a -> a -> a
max a
0 (a
oo forall a. Num a => a -> a -> a
- a
1) else a
oo
        c :: [a] -> Int -> [a]
c [a]
oc Int
oo
            | Int
oo forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
oc Bool -> Bool -> Bool
&& Direction1D
d forall a. Eq a => a -> a -> Bool
== Direction1D
Prev = forall a. Int -> [a] -> [a]
take (Int
oo forall a. Num a => a -> a -> a
- Int
1) [a]
oc
            | Int
oo forall a. Ord a => a -> a -> Bool
<  forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
oc Bool -> Bool -> Bool
&& Direction1D
d forall a. Eq a => a -> a -> Bool
== Direction1D
Prev = forall a. Int -> [a] -> [a]
take (Int
oo forall a. Num a => a -> a -> a
- Int
1) [a]
f forall a. [a] -> [a] -> [a]
++ [a]
ss
            | Int
oo forall a. Ord a => a -> a -> Bool
<  forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
oc Bool -> Bool -> Bool
&& Direction1D
d forall a. Eq a => a -> a -> Bool
== Direction1D
Next = [a]
f forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
drop Int
1 [a]
ss
            | Bool
otherwise = [a]
oc
            where ([a]
f,[a]
ss) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
oo [a]
oc

-- | Ensure the cursor remains over the command by shifting left if necessary.
clipCursor :: XP ()
clipCursor :: XP ()
clipCursor = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { offset :: Int
offset = forall {t :: * -> *} {a}. Foldable t => Int -> t a -> Int
o (XPState -> Int
offset XPState
s) (XPState -> String
command XPState
s)}
    where o :: Int -> t a -> Int
o Int
oo t a
c = forall a. Ord a => a -> a -> a
min (forall a. Ord a => a -> a -> a
max Int
0 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
c forall a. Num a => a -> a -> a
- Int
1) Int
oo

-- | Move the cursor one position.
moveCursor :: Direction1D -> XP ()
moveCursor :: Direction1D -> XP ()
moveCursor Direction1D
d =
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { offset :: Int
offset = forall {t :: * -> *} {a}. Foldable t => Int -> t a -> Int
o (XPState -> Int
offset XPState
s) (XPState -> String
command XPState
s)}
  where o :: Int -> t a -> Int
o Int
oo t a
c = if Direction1D
d forall a. Eq a => a -> a -> Bool
== Direction1D
Prev then forall a. Ord a => a -> a -> a
max Int
0 (Int
oo forall a. Num a => a -> a -> a
- Int
1) else forall a. Ord a => a -> a -> a
min (forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
c) (Int
oo forall a. Num a => a -> a -> a
+ Int
1)

-- | Move the cursor one position, but not beyond the command.
moveCursorClip :: Direction1D -> XP ()
moveCursorClip :: Direction1D -> XP ()
moveCursorClip = (forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
clipCursor) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Direction1D -> XP ()
moveCursor
--  modify $ \s -> s { offset = o (offset s) (command s)}
--  where o oo c = if d == Prev then max 0 (oo - 1) else min (max 0 $ length c - 1) (oo + 1)

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

-- | Given a direction, move the cursor to just before the next
-- (predicate,not-predicate) character transition. This means a (not-word,word)
-- transition should be followed by a 'moveCursorClip' action. Always considers
-- the character under the current cursor position.  This means a
-- (word,not-word) transition should be preceded by a 'moveCursorClip' action.
-- Calculated as the length of consecutive non-predicate characters starting
-- from the cursor position, plus the length of subsequent consecutive
-- predicate characters, plus when moving backwards the distance of the cursor
-- beyond the input. Reduced by one to avoid jumping off either end of the
-- input, when present.
--
-- Use these identities to retain the pre-0.14 behavior:
--
-- @
--     (oldMoveWord' p Prev) = (moveCursor Prev >> moveWord' p Prev)
-- @
--
-- @
--     (oldMoveWord' p Next) = (moveWord' p Next >> moveCursor Next)
-- @
moveWord' :: (Char -> Bool) -> Direction1D -> XP ()
moveWord' :: (Char -> Bool) -> Direction1D -> XP ()
moveWord' Char -> Bool
p Direction1D
d = do
  String
c <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> String
command
  Int
o <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Int
offset
  let (String
f,String
ss) = forall a. Int -> [a] -> ([a], [a])
splitOn Int
o String
c
      splitOn :: Int -> [a] -> ([a], [a])
splitOn Int
n [a]
xs = (forall a. Int -> [a] -> [a]
take (Int
nforall a. Num a => a -> a -> a
+Int
1) [a]
xs, forall a. Int -> [a] -> [a]
drop Int
n [a]
xs)
      gap :: Int
gap = case Direction1D
d of
                Direction1D
Prev -> forall a. Ord a => a -> a -> a
max Int
0 forall a b. (a -> b) -> a -> b
$ (Int
o forall a. Num a => a -> a -> a
+ Int
1) forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
c
                Direction1D
Next -> Int
0
      len :: String -> Int
len = forall a. Ord a => a -> a -> a
max Int
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (-) Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
gap forall a. Num a => a -> a -> a
+)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Num a => a -> a -> a
(+)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
p)))
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
p
      newoff :: Int
newoff = case Direction1D
d of
                Direction1D
Prev -> Int
o forall a. Num a => a -> a -> a
- String -> Int
len (forall {a}. [a] -> [a]
reverse String
f)
                Direction1D
Next -> Int
o forall a. Num a => a -> a -> a
+ String -> Int
len String
ss
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { offset :: Int
offset = Int
newoff }

-- | Set the prompt's input to an entry further up or further down the history
-- stack. Use 'Stack' functions from 'XMonad.StackSet', i.e. 'focusUp'' or
-- 'focusDown''.
moveHistory :: (W.Stack String -> W.Stack String) -> XP ()
moveHistory :: (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
f = do
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> let ch :: Stack String
ch = Stack String -> Stack String
f forall a b. (a -> b) -> a -> b
$ XPState -> Stack String
commandHistory XPState
s
                 in XPState
s { commandHistory :: Stack String
commandHistory = Stack String
ch
                      , offset :: Int
offset         = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. Stack a -> a
W.focus Stack String
ch
                      , complIndex :: (Int, Int)
complIndex     = (Int
0,Int
0) }
  XP ()
updateWindows
  XP ()
updateHighlightedCompl

-- | Move the cursor in the given direction to the first instance of the first
-- character of the given string, assuming the string is not empty. The
-- starting cursor character is not considered, and the cursor is placed over
-- the matching character.
toHeadChar :: Direction1D -> String -> XP ()
toHeadChar :: Direction1D -> String -> XP ()
toHeadChar Direction1D
_ String
""      = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
toHeadChar Direction1D
d (Char
c : String
_) = do
    String
cmd <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> String
command
    Int
off <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Int
offset
    let off' :: Int
off' = (if Direction1D
d forall a. Eq a => a -> a -> Bool
== Direction1D
Prev then forall a. Num a => a -> a
negate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst else forall a b. (a, b) -> b
snd)
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
(***) (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (forall a. Num a => a -> a -> a
+Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Char
c)
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall {a}. [a] -> [a]
reverse forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall a. Int -> [a] -> [a]
drop Int
1)
             forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> ([a], [a])
splitAt Int
off String
cmd
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
st -> XPState
st { offset :: Int
offset = XPState -> Int
offset XPState
st forall a. Num a => a -> a -> a
+ Int
off' }

updateHighlightedCompl :: XP ()
updateHighlightedCompl :: XP ()
updateHighlightedCompl = do
  XPState
st <- forall s (m :: * -> *). MonadState s m => m s
get
  [String]
cs <- XP [String]
getCompletions
  Bool
alwaysHighlight' <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ XPConfig -> Bool
alwaysHighlight forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPConfig
config
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
alwaysHighlight' forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s {highlightedCompl :: Maybe String
highlightedCompl = XPState -> [String] -> Maybe String
highlightedItem XPState
st [String]
cs}

------------------------------------------------------------------------
-- X Stuff

-- | The completion windows in its entirety.
data ComplWindowDim = ComplWindowDim
  { ComplWindowDim -> Position
cwX         :: !Position    -- ^ Starting x position
  , ComplWindowDim -> Position
cwY         :: !Position    -- ^ Starting y position
  , ComplWindowDim -> Dimension
cwWidth     :: !Dimension   -- ^ Width of the entire prompt
  , ComplWindowDim -> Dimension
cwRowHeight :: !Dimension   -- ^ Height of a single row
  , ComplWindowDim -> [Position]
cwCols      :: ![Position]  -- ^ Starting position of all columns
  , ComplWindowDim -> [Position]
cwRows      :: ![Position]  -- ^ Starting positions of all rows
  }
  deriving (ComplWindowDim -> ComplWindowDim -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ComplWindowDim -> ComplWindowDim -> Bool
$c/= :: ComplWindowDim -> ComplWindowDim -> Bool
== :: ComplWindowDim -> ComplWindowDim -> Bool
$c== :: ComplWindowDim -> ComplWindowDim -> Bool
Eq)

-- | Create the prompt window.
createPromptWin :: Display -> Window -> XPConfig -> Rectangle -> Dimension -> IO Window
createPromptWin :: Display
-> EventMask -> XPConfig -> Rectangle -> Dimension -> IO EventMask
createPromptWin Display
dpy EventMask
rootw XPC{ XPPosition
position :: XPPosition
position :: XPConfig -> XPPosition
position, Dimension
height :: Dimension
height :: XPConfig -> Dimension
height } Rectangle
scn Dimension
width = do
  EventMask
w <- Display
-> Screen
-> EventMask
-> Position
-> Position
-> Dimension
-> Dimension
-> IO EventMask
mkUnmanagedWindow Display
dpy (Display -> Screen
defaultScreenOfDisplay Display
dpy) EventMask
rootw
                      (Rectangle -> Position
rect_x Rectangle
scn forall a. Num a => a -> a -> a
+ Position
x) (Rectangle -> Position
rect_y Rectangle
scn forall a. Num a => a -> a -> a
+ Position
y) Dimension
width Dimension
height
  Display -> EventMask -> ClassHint -> IO ()
setClassHint Display
dpy EventMask
w (String -> String -> ClassHint
ClassHint String
"xmonad-prompt" String
"xmonad")
  Display -> EventMask -> IO ()
mapWindow Display
dpy EventMask
w
  forall (m :: * -> *) a. Monad m => a -> m a
return EventMask
w
 where
  (Position
x, Position
y) :: (Position, Position) = forall a b. (Integral a, Num b) => a -> b
fi forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case XPPosition
position of
    XPPosition
Top             -> (Position
0, Dimension
0)
    XPPosition
Bottom          -> (Position
0, Rectangle -> Dimension
rect_height Rectangle
scn forall a. Num a => a -> a -> a
- Dimension
height)
    CenteredAt Rational
py Rational
w ->
      ( forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
scn) forall a. Num a => a -> a -> a
* ((Rational
1 forall a. Num a => a -> a -> a
- Rational
w) forall a. Fractional a => a -> a -> a
/ Rational
2)
      , forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ Rational
py forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_height Rectangle
scn) forall a. Num a => a -> a -> a
- (forall a b. (Integral a, Num b) => a -> b
fi Dimension
height forall a. Fractional a => a -> a -> a
/ Rational
2)
      )

-- | Update the state of the completion window.
updateComplWin :: Maybe Window -> Maybe ComplWindowDim -> XP ()
updateComplWin :: Maybe EventMask -> Maybe ComplWindowDim -> XP ()
updateComplWin Maybe EventMask
win Maybe ComplWindowDim
winDim = do
  IORef (Maybe EventMask)
cwr <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> IORef (Maybe EventMask)
complWin
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe EventMask)
cwr Maybe EventMask
win
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\XPState
s -> XPState
s { complWinDim :: Maybe ComplWindowDim
complWinDim = Maybe ComplWindowDim
winDim })

--- | Update all prompt windows.
updateWindows :: XP ()
updateWindows :: XP ()
updateWindows = XP () -> [String] -> XP ()
redrawWindows (forall (f :: * -> *) a. Functor f => f a -> f ()
void XP ()
destroyComplWin) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< XP [String]
getCompletions

-- | Draw the main prompt window and, if necessary, redraw the
-- completion window.
redrawWindows
  :: XP ()     -- ^ What to do if the completions are empty
  -> [String]  -- ^ Given completions
  -> XP ()
redrawWindows :: XP () -> [String] -> XP ()
redrawWindows XP ()
emptyAction [String]
compls = do
  Display
d <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Display
dpy
  XP ()
drawWin
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe XP ()
emptyAction NonEmpty String -> XP ()
redrawComplWin (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [String]
compls)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> Bool -> IO ()
sync Display
d Bool
False
 where
  -- | Draw the main prompt window.
  XP ()
drawWin :: XP () = do
    XPS{ XPColor
color :: XPColor
color :: XPState -> XPColor
color, Display
dpy :: Display
dpy :: XPState -> Display
dpy, EventMask
win :: EventMask
win :: XPState -> EventMask
win, GC
gcon :: GC
gcon :: XPState -> GC
gcon, Dimension
winWidth :: Dimension
winWidth :: XPState -> Dimension
winWidth } <- forall s (m :: * -> *). MonadState s m => m s
get
    XPC{ Dimension
height :: Dimension
height :: XPConfig -> Dimension
height, Dimension
promptBorderWidth :: Dimension
promptBorderWidth :: XPConfig -> Dimension
promptBorderWidth } <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> XPConfig
config
    let scr :: Screen
scr = Display -> Screen
defaultScreenOfDisplay Display
dpy
        ht :: Dimension
ht  = Dimension
height            -- height of a single row
        bw :: Dimension
bw  = Dimension
promptBorderWidth
    Just EventMask
bgcolor <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> String -> IO (Maybe EventMask)
initColor Display
dpy (XPColor -> String
bgNormal XPColor
color)
    Just EventMask
borderC <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> String -> IO (Maybe EventMask)
initColor Display
dpy (XPColor -> String
border XPColor
color)
    EventMask
pm <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display
-> EventMask -> Dimension -> Dimension -> CInt -> IO EventMask
createPixmap Display
dpy EventMask
win Dimension
winWidth Dimension
ht (Screen -> CInt
defaultDepthOfScreen Screen
scr)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display
-> EventMask
-> GC
-> EventMask
-> EventMask
-> Dimension
-> Dimension
-> Dimension
-> IO ()
fillDrawable Display
dpy EventMask
pm GC
gcon EventMask
borderC EventMask
bgcolor (forall a b. (Integral a, Num b) => a -> b
fi Dimension
bw) Dimension
winWidth Dimension
ht
    EventMask -> XP ()
printPrompt EventMask
pm
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display
-> EventMask
-> EventMask
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> Position
-> Position
-> IO ()
copyArea Display
dpy EventMask
pm EventMask
win GC
gcon Position
0 Position
0 Dimension
winWidth Dimension
ht Position
0 Position
0
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> EventMask -> IO ()
freePixmap Display
dpy EventMask
pm

-- | Redraw the completion window, if necessary.
redrawComplWin ::  NonEmpty String -> XP ()
redrawComplWin :: NonEmpty String -> XP ()
redrawComplWin NonEmpty String
compl = do
  XPS{ Bool
showComplWin :: Bool
showComplWin :: XPState -> Bool
showComplWin, Maybe ComplWindowDim
complWinDim :: Maybe ComplWindowDim
complWinDim :: XPState -> Maybe ComplWindowDim
complWinDim, IORef (Maybe EventMask)
complWin :: IORef (Maybe EventMask)
complWin :: XPState -> IORef (Maybe EventMask)
complWin } <- forall s (m :: * -> *). MonadState s m => m s
get
  ComplWindowDim
nwi <- NonEmpty String -> XP ComplWindowDim
getComplWinDim NonEmpty String
compl
  let recreate :: XP ()
recreate = do XP ()
destroyComplWin
                    EventMask
w <- ComplWindowDim -> StateT XPState IO EventMask
createComplWin ComplWindowDim
nwi
                    EventMask -> NonEmpty String -> XP ()
drawComplWin EventMask
w NonEmpty String
compl
  if Bool
showComplWin
     then forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (forall a. IORef a -> IO a
readIORef IORef (Maybe EventMask)
complWin) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just EventMask
w -> case Maybe ComplWindowDim
complWinDim of
                        Just ComplWindowDim
wi -> if ComplWindowDim
nwi forall a. Eq a => a -> a -> Bool
== ComplWindowDim
wi -- complWinDim did not change
                                   then EventMask -> NonEmpty String -> XP ()
drawComplWin EventMask
w NonEmpty String
compl -- so update
                                   else XP ()
recreate
                        Maybe ComplWindowDim
Nothing -> XP ()
recreate
            Maybe EventMask
Nothing -> XP ()
recreate
     else XP ()
destroyComplWin
 where
  createComplWin :: ComplWindowDim -> XP Window
  createComplWin :: ComplWindowDim -> StateT XPState IO EventMask
createComplWin wi :: ComplWindowDim
wi@ComplWindowDim{ Position
cwX :: Position
cwX :: ComplWindowDim -> Position
cwX, Position
cwY :: Position
cwY :: ComplWindowDim -> Position
cwY, Dimension
cwWidth :: Dimension
cwWidth :: ComplWindowDim -> Dimension
cwWidth, Dimension
cwRowHeight :: Dimension
cwRowHeight :: ComplWindowDim -> Dimension
cwRowHeight } = do
    XPS{ Display
dpy :: Display
dpy :: XPState -> Display
dpy, EventMask
rootw :: EventMask
rootw :: XPState -> EventMask
rootw } <- forall s (m :: * -> *). MonadState s m => m s
get
    let scr :: Screen
scr = Display -> Screen
defaultScreenOfDisplay Display
dpy
    EventMask
w <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display
-> Screen
-> EventMask
-> Position
-> Position
-> Dimension
-> Dimension
-> IO EventMask
mkUnmanagedWindow Display
dpy Screen
scr EventMask
rootw Position
cwX Position
cwY Dimension
cwWidth Dimension
cwRowHeight
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> EventMask -> IO ()
mapWindow Display
dpy EventMask
w
    Maybe EventMask -> Maybe ComplWindowDim -> XP ()
updateComplWin (forall a. a -> Maybe a
Just EventMask
w) (forall a. a -> Maybe a
Just ComplWindowDim
wi)
    forall (m :: * -> *) a. Monad m => a -> m a
return EventMask
w

-- | Print the main part of the prompt: the prompter, as well as the
-- command line (including the current input) and the cursor.
printPrompt :: Drawable -> XP ()
printPrompt :: EventMask -> XP ()
printPrompt EventMask
drw = do
  st :: XPState
st@XPS{ String -> String
prompter :: String -> String
prompter :: XPState -> String -> String
prompter, XPColor
color :: XPColor
color :: XPState -> XPColor
color, GC
gcon :: GC
gcon :: XPState -> GC
gcon, XPConfig
config :: XPConfig
config :: XPState -> XPConfig
config, Display
dpy :: Display
dpy :: XPState -> Display
dpy, XMonadFont
fontS :: XMonadFont
fontS :: XPState -> XMonadFont
fontS, Int
offset :: Int
offset :: XPState -> Int
offset } <- forall s (m :: * -> *). MonadState s m => m s
get
  let -- (prompt-specific text before the command, the entered command)
      (String
prt, String
com) = (String -> String
prompter forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPType
currentXPMode forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPState -> String
command) XPState
st
      str :: String
str = String
prt forall a. [a] -> [a] -> [a]
++ String
com
      -- break the string in 3 parts: till the cursor, the cursor and the rest
      (String
preCursor, String
cursor, String
postCursor) = if Int
offset forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length String
com
                 then (String
str, String
" ",String
"") -- add a space: it will be our cursor ;-)
                 else let (String
a, String
b) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
offset String
com
                      in (String
prt forall a. [a] -> [a] -> [a]
++ String
a, forall a. Int -> [a] -> [a]
take Int
1 String
b, forall a. Int -> [a] -> [a]
drop Int
1 String
b)

  -- vertical and horizontal text alignment
  (Position
asc, Position
desc) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
XMonadFont -> String -> m (Position, Position)
textExtentsXMF XMonadFont
fontS String
str  -- font ascent and descent
  let y :: Position
y = forall a b. (Integral a, Num b) => a -> b
fi ((XPConfig -> Dimension
height XPConfig
config forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fi (Position
asc forall a. Num a => a -> a -> a
+ Position
desc)) forall a. Integral a => a -> a -> a
`div` Dimension
2) forall a. Num a => a -> a -> a
+ Position
asc
      x :: Position
x = (Position
asc forall a. Num a => a -> a -> a
+ Position
desc) forall a. Integral a => a -> a -> a
`div` Position
2

  Int
pcFont <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF Display
dpy XMonadFont
fontS String
preCursor
  Int
cFont  <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF Display
dpy XMonadFont
fontS String
cursor
  let draw :: String -> String -> Position -> Position -> String -> XP ()
draw = forall (m :: * -> *).
(Functor m, MonadIO m) =>
Display
-> EventMask
-> XMonadFont
-> GC
-> String
-> String
-> Position
-> Position
-> String
-> m ()
printStringXMF Display
dpy EventMask
drw XMonadFont
fontS GC
gcon
  -- print the first part
  String -> String -> Position -> Position -> String -> XP ()
draw (XPColor -> String
fgNormal XPColor
color) (XPColor -> String
bgNormal XPColor
color) Position
x Position
y String
preCursor
  -- reverse the colors and print the "cursor" ;-)
  String -> String -> Position -> Position -> String -> XP ()
draw (XPColor -> String
bgNormal XPColor
color) (XPColor -> String
fgNormal XPColor
color) (Position
x forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi Int
pcFont) Position
y String
cursor
  -- flip back to the original colors and print the rest of the string
  String -> String -> Position -> Position -> String -> XP ()
draw (XPColor -> String
fgNormal XPColor
color) (XPColor -> String
bgNormal XPColor
color) (Position
x forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi (Int
pcFont forall a. Num a => a -> a -> a
+ Int
cFont)) Position
y String
postCursor

-- | Get all available completions for the current input.
getCompletions :: XP [String]
getCompletions :: XP [String]
getCompletions = do
  st :: XPState
st@XPS{ XPConfig
config :: XPConfig
config :: XPState -> XPConfig
config } <- forall s (m :: * -> *). MonadState s m => m s
get
  let cmd :: String
cmd   = forall t. XPrompt t => t -> String -> String
commandToComplete (XPState -> XPType
currentXPMode XPState
st) (XPState -> String
command XPState
st)
      compl :: ComplFunction
compl = XPState -> ComplFunction
getCompletionFunction XPState
st
      srt :: String -> [String] -> [String]
srt   = XPConfig -> String -> [String] -> [String]
sorter XPConfig
config
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ (String -> [String] -> [String]
srt String
cmd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ComplFunction
compl String
cmd) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(SomeException e
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return []
 where
  -- | Get the current completion function depending on the active mode.
  getCompletionFunction :: XPState -> ComplFunction
  getCompletionFunction :: XPState -> ComplFunction
getCompletionFunction XPState
st = case XPState -> XPOperationMode
operationMode XPState
st of
    XPSingleMode ComplFunction
compl XPType
_ -> ComplFunction
compl
    XPMultipleModes Stack XPType
modes -> forall t. XPrompt t => t -> ComplFunction
completionFunction forall a b. (a -> b) -> a -> b
$ forall a. Stack a -> a
W.focus Stack XPType
modes

-- | Destroy the currently drawn completion window, if there is one.
destroyComplWin :: XP ()
destroyComplWin :: XP ()
destroyComplWin = do
  XPS{ Display
dpy :: Display
dpy :: XPState -> Display
dpy, IORef (Maybe EventMask)
complWin :: IORef (Maybe EventMask)
complWin :: XPState -> IORef (Maybe EventMask)
complWin } <- forall s (m :: * -> *). MonadState s m => m s
get
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (forall a. IORef a -> IO a
readIORef IORef (Maybe EventMask)
complWin) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just EventMask
w -> do forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> EventMask -> IO ()
destroyWindow Display
dpy EventMask
w
                 Maybe EventMask -> Maybe ComplWindowDim -> XP ()
updateComplWin forall a. Maybe a
Nothing forall a. Maybe a
Nothing
    Maybe EventMask
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Given the completions that we would like to show, calculate the
-- required dimensions for the completion windows.
getComplWinDim :: NonEmpty String -> XP ComplWindowDim
getComplWinDim :: NonEmpty String -> XP ComplWindowDim
getComplWinDim NonEmpty String
compl = do
  XPS{ config :: XPState -> XPConfig
config = XPConfig
cfg, screen :: XPState -> Rectangle
screen = Rectangle
scr, fontS :: XPState -> XMonadFont
fontS = XMonadFont
fs, Display
dpy :: Display
dpy :: XPState -> Display
dpy, Dimension
winWidth :: Dimension
winWidth :: XPState -> Dimension
winWidth } <- forall s (m :: * -> *). MonadState s m => m s
get
  let -- Height of a single completion row
      ht :: Dimension
ht = XPConfig -> Dimension
height XPConfig
cfg
      bw :: Dimension
bw = XPConfig -> Dimension
promptBorderWidth XPConfig
cfg

  NonEmpty Int
tws <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF Display
dpy XMonadFont
fs) NonEmpty String
compl
  let -- Length of widest completion we will print
      maxComplLen :: Int
maxComplLen = (forall a b. (Integral a, Num b) => a -> b
fi Dimension
ht forall a. Integral a => a -> a -> a
`div` Int
2) forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum NonEmpty Int
tws
      -- Height of the screen rectangle _without_ the prompt window
      remHeight :: Dimension
remHeight   = Rectangle -> Dimension
rect_height Rectangle
scr forall a. Num a => a -> a -> a
- Dimension
ht

      maxColumns :: Dimension -> Dimension
maxColumns  = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall a. Ord a => a -> a -> a
min (XPConfig -> Maybe Dimension
maxComplColumns XPConfig
cfg)
      columns :: Dimension
columns     = forall a. Ord a => a -> a -> a
max Dimension
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dimension -> Dimension
maxColumns forall a b. (a -> b) -> a -> b
$ Dimension
winWidth forall a. Integral a => a -> a -> a
`div` forall a b. (Integral a, Num b) => a -> b
fi Int
maxComplLen
      columnWidth :: Dimension
columnWidth = Dimension
winWidth forall a. Integral a => a -> a -> a
`div` Dimension
columns

      (Int
fullRows, Int
lastRow) = forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty String
compl forall a. Integral a => a -> a -> (a, a)
`divMod` forall a b. (Integral a, Num b) => a -> b
fi Dimension
columns
      allRows :: Int
allRows   = forall a. Ord a => a -> a -> a
max Int
1 (Int
fullRows forall a. Num a => a -> a -> a
+ if Int
lastRow forall a. Eq a => a -> a -> Bool
== Int
0 then Int
0 else Int
1)
      -- Maximum number of rows allowed by the config and the screen dimensions
      maxRows :: Dimension
maxRows   = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall a. Ord a => a -> a -> a
min (XPConfig -> Maybe Dimension
maxComplRows XPConfig
cfg) (Dimension
remHeight forall a. Integral a => a -> a -> a
`div` Dimension
ht)
      -- Actual number of rows to be drawn
      rows :: Dimension
rows      = forall a. Ord a => a -> a -> a
min Dimension
maxRows (forall a b. (Integral a, Num b) => a -> b
fi Int
allRows)
      rowHeight :: Dimension
rowHeight = Dimension
rows forall a. Num a => a -> a -> a
* Dimension
ht

      -- Starting x and y position of the completion windows.
      (Position
x, Position
y) = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (Rectangle -> Position
rect_x Rectangle
scr forall a. Num a => a -> a -> a
+) ((Rectangle -> Position
rect_y Rectangle
scr forall a. Num a => a -> a -> a
+) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fi) forall a b. (a -> b) -> a -> b
$ case XPConfig -> XPPosition
position XPConfig
cfg of
        XPPosition
Top    -> (Position
0, Dimension
ht forall a. Num a => a -> a -> a
- Dimension
bw)
        XPPosition
Bottom -> (Position
0, Dimension
remHeight forall a. Num a => a -> a -> a
- Dimension
rowHeight forall a. Num a => a -> a -> a
+ Dimension
bw)
        CenteredAt Rational
py Rational
w
          | Rational
py forall a. Ord a => a -> a -> Bool
<= Rational
1forall a. Fractional a => a -> a -> a
/Rational
2 ->
              ( forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
scr) forall a. Num a => a -> a -> a
* ((Rational
1 forall a. Num a => a -> a -> a
- Rational
w) forall a. Fractional a => a -> a -> a
/ Rational
2)
              , forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational
py forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_height Rectangle
scr) forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fi Dimension
ht forall a. Fractional a => a -> a -> a
/ Rational
2)) forall a. Num a => a -> a -> a
- Dimension
bw
              )
          | Bool
otherwise ->
              ( forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
scr) forall a. Num a => a -> a -> a
* ((Rational
1 forall a. Num a => a -> a -> a
- Rational
w) forall a. Fractional a => a -> a -> a
/ Rational
2)
              , forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational
py forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_height Rectangle
scr) forall a. Num a => a -> a -> a
- (forall a b. (Integral a, Num b) => a -> b
fi Dimension
ht forall a. Fractional a => a -> a -> a
/ Rational
2)) forall a. Num a => a -> a -> a
- Dimension
rowHeight forall a. Num a => a -> a -> a
+ Dimension
bw
              )

  -- Get font ascent and descent.  Coherence condition: we will print
  -- everything using the same font.
  (Position
asc, Position
desc) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
XMonadFont -> String -> m (Position, Position)
textExtentsXMF XMonadFont
fs forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
NE.head NonEmpty String
compl
  let yp :: Position
yp    = forall a b. (Integral a, Num b) => a -> b
fi forall a b. (a -> b) -> a -> b
$ (Dimension
ht forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi (Position
asc forall a. Num a => a -> a -> a
- Position
desc)) forall a. Integral a => a -> a -> a
`div` Dimension
2 -- y position of the first row
      yRows :: [Position]
yRows = forall a. Int -> [a] -> [a]
take (forall a b. (Integral a, Num b) => a -> b
fi Dimension
rows) [Position
yp, Position
yp forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi Dimension
ht ..]  -- y positions of all rows

      xp :: Position
xp    = (Position
asc forall a. Num a => a -> a -> a
+ Position
desc) forall a. Integral a => a -> a -> a
`div` Position
2                           -- x position of the first column
      xCols :: [Position]
xCols = forall a. Int -> [a] -> [a]
take (forall a b. (Integral a, Num b) => a -> b
fi Dimension
columns) [Position
xp, Position
xp forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fi Dimension
columnWidth ..] -- x positions of all columns

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Position
-> Position
-> Dimension
-> Dimension
-> [Position]
-> [Position]
-> ComplWindowDim
ComplWindowDim Position
x Position
y Dimension
winWidth Dimension
rowHeight [Position]
xCols [Position]
yRows

-- | Draw the completion window.
drawComplWin :: Window -> NonEmpty String -> XP ()
drawComplWin :: EventMask -> NonEmpty String -> XP ()
drawComplWin EventMask
w NonEmpty String
entries = do
  XPS{ XPConfig
config :: XPConfig
config :: XPState -> XPConfig
config, XPColor
color :: XPColor
color :: XPState -> XPColor
color, Display
dpy :: Display
dpy :: XPState -> Display
dpy, GC
gcon :: GC
gcon :: XPState -> GC
gcon } <- forall s (m :: * -> *). MonadState s m => m s
get
  let scr :: Screen
scr = Display -> Screen
defaultScreenOfDisplay Display
dpy
      bw :: Dimension
bw  = XPConfig -> Dimension
promptBorderWidth XPConfig
config
  Just EventMask
bgcolor <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> String -> IO (Maybe EventMask)
initColor Display
dpy (XPColor -> String
bgNormal XPColor
color)
  Just EventMask
borderC <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> String -> IO (Maybe EventMask)
initColor Display
dpy (XPColor -> String
border XPColor
color)
  cwd :: ComplWindowDim
cwd@ComplWindowDim{ Dimension
cwWidth :: Dimension
cwWidth :: ComplWindowDim -> Dimension
cwWidth, Dimension
cwRowHeight :: Dimension
cwRowHeight :: ComplWindowDim -> Dimension
cwRowHeight } <- NonEmpty String -> XP ComplWindowDim
getComplWinDim NonEmpty String
entries

  EventMask
p <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display
-> EventMask -> Dimension -> Dimension -> CInt -> IO EventMask
createPixmap Display
dpy EventMask
w Dimension
cwWidth Dimension
cwRowHeight (Screen -> CInt
defaultDepthOfScreen Screen
scr)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display
-> EventMask
-> GC
-> EventMask
-> EventMask
-> Dimension
-> Dimension
-> Dimension
-> IO ()
fillDrawable Display
dpy EventMask
p GC
gcon EventMask
borderC EventMask
bgcolor (forall a b. (Integral a, Num b) => a -> b
fi Dimension
bw) Dimension
cwWidth Dimension
cwRowHeight
  Display
-> EventMask
-> GC
-> String
-> String
-> NonEmpty String
-> ComplWindowDim
-> XP ()
printComplEntries Display
dpy EventMask
p GC
gcon (XPColor -> String
fgNormal XPColor
color) (XPColor -> String
bgNormal XPColor
color) NonEmpty String
entries ComplWindowDim
cwd
  --lift $ spawn $ "xmessage " ++ " ac: " ++ show ac  ++ " xx: " ++ show xx ++ " length xx: " ++ show (length xx) ++ " yy: " ++ show (length yy)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display
-> EventMask
-> EventMask
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> Position
-> Position
-> IO ()
copyArea Display
dpy EventMask
p EventMask
w GC
gcon Position
0 Position
0 Dimension
cwWidth Dimension
cwRowHeight Position
0 Position
0
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Display -> EventMask -> IO ()
freePixmap Display
dpy EventMask
p

-- | Print all of the completion entries.
printComplEntries
  :: Display
  -> Drawable
  -> GC
  -> String         -- ^ Default foreground color
  -> String         -- ^ Default background color
  -> NonEmpty String -- ^ Entries to be printed...
  -> ComplWindowDim -- ^ ...into a window of this size
  -> XP ()
printComplEntries :: Display
-> EventMask
-> GC
-> String
-> String
-> NonEmpty String
-> ComplWindowDim
-> XP ()
printComplEntries Display
dpy EventMask
drw GC
gc String
fc String
bc NonEmpty String
entries ComplWindowDim{ [Position]
cwCols :: [Position]
cwCols :: ComplWindowDim -> [Position]
cwCols, [Position]
cwRows :: [Position]
cwRows :: ComplWindowDim -> [Position]
cwRows } = do
  st :: XPState
st@XPS{ XPColor
color :: XPColor
color :: XPState -> XPColor
color, (Int, Int)
complIndex :: (Int, Int)
complIndex :: XPState -> (Int, Int)
complIndex, config :: XPState -> XPConfig
config = XPC{ Bool
alwaysHighlight :: Bool
alwaysHighlight :: XPConfig -> Bool
alwaysHighlight } } <- forall s (m :: * -> *). MonadState s m => m s
get
  let printItemAt :: Position -> Position -> String -> XP ()
      printItemAt :: Position -> Position -> String -> XP ()
printItemAt Position
x Position
y String
item =
        forall (m :: * -> *).
(Functor m, MonadIO m) =>
Display
-> EventMask
-> XMonadFont
-> GC
-> String
-> String
-> Position
-> Position
-> String
-> m ()
printStringXMF Display
dpy EventMask
drw (XPState -> XMonadFont
fontS XPState
st) GC
gc String
fgCol String
bgCol Position
x Position
y String
item
       where
        (String
fgCol, String
bgCol)
          | -- default to the first item, the one in (0, 0)
            Bool
alwaysHighlight, (Int, Int)
complIndex forall a. Eq a => a -> a -> Bool
== String -> (Int, Int)
findComplIndex String
item
          = (XPColor -> String
fgHighlight XPColor
color, XPColor -> String
bgHighlight XPColor
color)
          | -- compare item with buffer's value
            forall t. XPrompt t => t -> String -> String
completionToCommand (XPState -> XPType
currentXPMode XPState
st) String
item forall a. Eq a => a -> a -> Bool
== forall t. XPrompt t => t -> String -> String
commandToComplete (XPState -> XPType
currentXPMode XPState
st) (XPState -> String
command XPState
st)
          = (XPColor -> String
fgHighlight XPColor
color, XPColor -> String
bgHighlight XPColor
color)
          | -- if nothing matches, use default colors
            Bool
otherwise = (String
fc, String
bc)
  forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (\Position
x -> forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (Position -> Position -> String -> XP ()
printItemAt Position
x) [Position]
cwRows) [Position]
cwCols [[String]]
complMat
 where
  -- | Create the completion matrix to be printed.
  [[String]]
complMat :: [[String]]
    = forall a. Int -> [a] -> [[a]]
chunksOf (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Position]
cwRows) (forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Position]
cwCols forall a. Num a => a -> a -> a
* forall (t :: * -> *) a. Foldable t => t a -> Int
length [Position]
cwRows) (forall a. NonEmpty a -> [a]
NE.toList NonEmpty String
entries))

  -- | Find the column and row indexes in which a string appears.
  -- If the string is not in the matrix, the indices default to @(0, 0)@.
  findComplIndex :: String -> (Int, Int)
  findComplIndex :: String -> (Int, Int)
findComplIndex String
item = (Int
colIndex, Int
rowIndex)
   where
    colIndex :: Int
colIndex = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (\[String]
cols -> String
item forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
cols) [[String]]
complMat
    rowIndex :: Int
rowIndex = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall a. Eq a => a -> [a] -> Maybe Int
elemIndex String
item forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [[String]]
complMat forall a. [a] -> Int -> Maybe a
!? Int
colIndex

-- History

type History = M.Map String [String]

emptyHistory :: History
emptyHistory :: Map String [String]
emptyHistory = forall k a. Map k a
M.empty

getHistoryFile :: FilePath -> FilePath
getHistoryFile :: String -> String
getHistoryFile String
cachedir = String
cachedir forall a. [a] -> [a] -> [a]
++ String
"/prompt-history"

readHistory :: XPConfig -> FilePath -> IO History
readHistory :: XPConfig -> String -> IO (Map String [String])
readHistory (XPC { historySize :: XPConfig -> Int
historySize = Int
0 }) String
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Map String [String]
emptyHistory
readHistory XPConfig
_ String
cachedir = IO (Map String [String])
readHist forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(SomeException e
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Map String [String]
emptyHistory
 where
    readHist :: IO (Map String [String])
readHist = do
        let path :: String
path = String -> String
getHistoryFile String
cachedir
        String
xs <- forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
ReadMode Handle -> IO String
hGetLine
        forall a. Read a => String -> IO a
readIO String
xs

writeHistory :: XPConfig -> FilePath -> History -> IO ()
writeHistory :: XPConfig -> String -> Map String [String] -> IO ()
writeHistory (XPC { historySize :: XPConfig -> Int
historySize = Int
0 }) String
_ Map String [String]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
writeHistory XPConfig
_ String
cachedir Map String [String]
hist = do
  let path :: String
path = String -> String
getHistoryFile String
cachedir
      filtered :: Map String [String]
filtered = forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) Map String [String]
hist
  String -> String -> IO ()
writeFile String
path (forall a. Show a => a -> String
show Map String [String]
filtered) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(SomeException e
e) ->
                          Handle -> String -> IO ()
hPutStrLn Handle
stderr (String
"error writing history: "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show e
e)
  String -> FileMode -> IO ()
setFileMode String
path FileMode
mode
    where mode :: FileMode
mode = FileMode
ownerReadMode forall a. Bits a => a -> a -> a
.|. FileMode
ownerWriteMode

-- $xutils

-- | Fills a 'Drawable' with a rectangle and a border
fillDrawable :: Display -> Drawable -> GC -> Pixel -> Pixel
             -> Dimension -> Dimension -> Dimension -> IO ()
fillDrawable :: Display
-> EventMask
-> GC
-> EventMask
-> EventMask
-> Dimension
-> Dimension
-> Dimension
-> IO ()
fillDrawable Display
d EventMask
drw GC
gc EventMask
borderC EventMask
bgcolor Dimension
bw Dimension
wh Dimension
ht = do
  -- we start with the border
  Display -> GC -> EventMask -> IO ()
setForeground Display
d GC
gc EventMask
borderC
  Display
-> EventMask
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> IO ()
fillRectangle Display
d EventMask
drw GC
gc Position
0 Position
0 Dimension
wh Dimension
ht
  -- here foreground means the background of the text
  Display -> GC -> EventMask -> IO ()
setForeground Display
d GC
gc EventMask
bgcolor
  Display
-> EventMask
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> IO ()
fillRectangle Display
d EventMask
drw GC
gc (forall a b. (Integral a, Num b) => a -> b
fi Dimension
bw) (forall a b. (Integral a, Num b) => a -> b
fi Dimension
bw) (Dimension
wh forall a. Num a => a -> a -> a
- (Dimension
bw forall a. Num a => a -> a -> a
* Dimension
2)) (Dimension
ht forall a. Num a => a -> a -> a
- (Dimension
bw forall a. Num a => a -> a -> a
* Dimension
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 :: Display
-> Screen
-> EventMask
-> Position
-> Position
-> Dimension
-> Dimension
-> IO EventMask
mkUnmanagedWindow Display
d Screen
s EventMask
rw Position
x Position
y Dimension
w Dimension
h = do
  let visual :: Visual
visual = Screen -> Visual
defaultVisualOfScreen Screen
s
      attrmask :: EventMask
attrmask = EventMask
cWOverrideRedirect
  forall a. (Ptr SetWindowAttributes -> IO a) -> IO a
allocaSetWindowAttributes forall a b. (a -> b) -> a -> b
$
         \Ptr SetWindowAttributes
attributes -> do
           Ptr SetWindowAttributes -> Bool -> IO ()
set_override_redirect Ptr SetWindowAttributes
attributes Bool
True
           Display
-> EventMask
-> Position
-> Position
-> Dimension
-> Dimension
-> CInt
-> CInt
-> CInt
-> Visual
-> EventMask
-> Ptr SetWindowAttributes
-> IO EventMask
createWindow Display
d EventMask
rw Position
x Position
y Dimension
w Dimension
h CInt
0 (Screen -> CInt
defaultDepthOfScreen Screen
s)
                        CInt
inputOutput Visual
visual EventMask
attrmask Ptr SetWindowAttributes
attributes

-- $utils

-- | This function takes a list of possible completions and returns a
-- completions function to be used with 'mkXPrompt'
mkComplFunFromList :: XPConfig -> [String] -> String -> IO [String]
mkComplFunFromList :: XPConfig -> [String] -> ComplFunction
mkComplFunFromList XPConfig
_ [String]
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
mkComplFunFromList XPConfig
c [String]
l String
s =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (XPConfig -> String -> String -> Bool
searchPredicate XPConfig
c String
s) [String]
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' :: XPConfig -> [String] -> String -> IO [String]
mkComplFunFromList' :: XPConfig -> [String] -> ComplFunction
mkComplFunFromList' XPConfig
_ [String]
l [] = forall (m :: * -> *) a. Monad m => a -> m a
return [String]
l
mkComplFunFromList' XPConfig
c [String]
l String
s =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (XPConfig -> String -> String -> Bool
searchPredicate XPConfig
c String
s) [String]
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 :: forall t. XPrompt t => t -> String -> [String] -> String
getNextOfLastWord t
t String
c [String]
l = String -> String
skipLastWord String
c forall a. [a] -> [a] -> [a]
++ forall t. XPrompt t => t -> String -> String
completionToCommand t
t ([String]
l forall a. [a] -> Int -> a
!! Int
ni)
    where ni :: Int
ni = case forall t. XPrompt t => t -> String -> String
commandToComplete t
t String
c forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` forall a b. (a -> b) -> [a] -> [b]
map (forall t. XPrompt t => t -> String -> String
completionToCommand t
t) [String]
l of
                 Just Int
i -> if Int
i forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
l forall a. Num a => a -> a -> a
- Int
1 then Int
0 else Int
i forall a. Num a => a -> a -> a
+ Int
1
                 Maybe Int
Nothing -> Int
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 :: String -> [String] -> String
getNextCompletion String
c [String]
l = [String]
l forall a. [a] -> Int -> a
!! Int
idx
    where idx :: Int
idx = case String
c forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` [String]
l of
                  Just Int
i  -> if Int
i forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
l forall a. Num a => a -> a -> a
- Int
1 then Int
0 else Int
i forall a. Num a => a -> a -> a
+ Int
1
                  Maybe Int
Nothing -> Int
0

-- | Given a maximum length, splits a list into sublists
splitInSubListsAt :: Int -> [a] -> [[a]]
splitInSubListsAt :: forall a. Int -> [a] -> [[a]]
splitInSubListsAt = forall a. Int -> [a] -> [[a]]
chunksOf
{-# DEPRECATED splitInSubListsAt "Use XMonad.Prelude.chunksOf instead." #-}

-- | Gets the last word of a string or the whole string if formed by
-- only one word
getLastWord :: String -> String
getLastWord :: String -> String
getLastWord = forall {a}. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String, String)
breakAtSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. [a] -> [a]
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 :: String -> String
skipLastWord = forall {a}. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String, String)
breakAtSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. [a] -> [a]
reverse

breakAtSpace :: String -> (String, String)
breakAtSpace :: String -> (String, String)
breakAtSpace String
s
    | String
" \\" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s2 = (String
s1 forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
s1', String
s2')
    | Bool
otherwise = (String
s1, String
s2)
      where (String
s1, String
s2 ) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace String
s
            (String
s1',String
s2') = String -> (String, String)
breakAtSpace forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
1 String
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 :: XPConfig -> X ComplFunction
historyCompletion :: XPConfig -> X ComplFunction
historyCompletion XPConfig
conf = XPConfig -> (String -> Bool) -> X ComplFunction
historyCompletionP XPConfig
conf (forall a b. a -> b -> a
const Bool
True)

-- | Like 'historyCompletion' but only uses history data from Prompts whose
-- name satisfies the given predicate.
historyCompletionP :: XPConfig -> (String -> Bool) -> X ComplFunction
historyCompletionP :: XPConfig -> (String -> Bool) -> X ComplFunction
historyCompletionP XPConfig
conf String -> Bool
p = do
    String
cd <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a. Directories' a -> a
cacheDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> Directories
directories)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \String
x ->
        let toComplList :: Map k [String] -> [String]
toComplList = [String] -> [String]
deleteConsecutive forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => [a] -> [a] -> Bool
isInfixOf String
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> b -> b) -> b -> Map k a -> b
M.foldr forall a. [a] -> [a] -> [a]
(++) []
         in forall {k}. Map k [String] -> [String]
toComplList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
p) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XPConfig -> String -> IO (Map String [String])
readHistory XPConfig
conf String
cd

-- | Sort a list and remove duplicates. Like 'deleteAllDuplicates', but trades off
--   laziness and stability for efficiency.
uniqSort :: Ord a => [a] -> [a]
uniqSort :: forall a. Ord a => [a] -> [a]
uniqSort = forall a. Set a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
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 :: [String] -> [String]
deleteAllDuplicates = forall a. Eq a => [a] -> [a]
nub
deleteConsecutive :: [String] -> [String]
deleteConsecutive = forall a b. (a -> b) -> [a] -> [b]
map (forall a. NonEmpty a -> a
NE.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => [a] -> NonEmpty a
notEmpty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [[a]]
group
-- The elements of group will always have at least one element.

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 :: forall (m :: * -> *). (Functor m, MonadIO m) => m HistoryMatches
initMatches = IORef ([String], Maybe (Stack String)) -> HistoryMatches
HistoryMatches forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. a -> IO (IORef a)
newIORef ([],forall a. Maybe a
Nothing))

historyNextMatching :: HistoryMatches -> (W.Stack String -> W.Stack String) -> XP ()
historyNextMatching :: HistoryMatches -> (Stack String -> Stack String) -> XP ()
historyNextMatching hm :: HistoryMatches
hm@(HistoryMatches IORef ([String], Maybe (Stack String))
ref) Stack String -> Stack String
next = do
  ([String]
completed,Maybe (Stack String)
completions) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef ([String], Maybe (Stack String))
ref
  String
input <- XP String
getInput
  if String
input forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
completed
     then case Maybe (Stack String)
completions of
            Just Stack String
cs -> do
                let cmd :: String
cmd = forall a. Stack a -> a
W.focus Stack String
cs
                forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ String -> XPState -> XPState
setCommand String
cmd
                forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { offset :: Int
offset = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
cmd }
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef ([String], Maybe (Stack String))
ref (String
cmdforall a. a -> [a] -> [a]
:[String]
completed,forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Stack String -> Stack String
next Stack String
cs)
            Maybe (Stack String)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
     else do -- the user typed something new, recompute completions
       forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IORef a -> a -> IO ()
writeIORef IORef ([String], Maybe (Stack String))
ref forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String
input] ,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Stack String -> Maybe (Stack String)
filterMatching String
input forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Stack String
commandHistory
       HistoryMatches -> (Stack String -> Stack String) -> XP ()
historyNextMatching HistoryMatches
hm Stack String -> Stack String
next
    where filterMatching :: String -> W.Stack String -> Maybe (W.Stack String)
          filterMatching :: String -> Stack String -> Maybe (Stack String)
filterMatching String
prefix = forall a. (a -> Bool) -> Stack a -> Maybe (Stack a)
W.filter (String
prefix forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stack String -> Stack String
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 :: HistoryMatches -> XP ()
historyUpMatching HistoryMatches
hm = HistoryMatches -> (Stack String -> Stack String) -> XP ()
historyNextMatching HistoryMatches
hm forall a. Stack a -> Stack a
W.focusDown'
historyDownMatching :: HistoryMatches -> XP ()
historyDownMatching HistoryMatches
hm = HistoryMatches -> (Stack String -> Stack String) -> XP ()
historyNextMatching HistoryMatches
hm forall a. Stack a -> Stack a
W.focusUp'