{-# 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) = p -> String
forall t. XPrompt t => t -> String
showXPrompt p
p

instance XPrompt XPType where
    showXPrompt :: XPType -> String
showXPrompt                 = XPType -> String
forall a. Show a => a -> String
show
    nextCompletion :: XPType -> String -> [String] -> String
nextCompletion      (XPT p
t) = p -> String -> [String] -> String
forall t. XPrompt t => t -> String -> [String] -> String
nextCompletion      p
t
    commandToComplete :: XPType -> String -> String
commandToComplete   (XPT p
t) = p -> String -> String
forall t. XPrompt t => t -> String -> String
commandToComplete   p
t
    completionToCommand :: XPType -> String -> String
completionToCommand (XPT p
t) = p -> String -> String
forall t. XPrompt t => t -> String -> String
completionToCommand p
t
    completionFunction :: XPType -> ComplFunction
completionFunction  (XPT p
t) = p -> ComplFunction
forall t. XPrompt t => t -> ComplFunction
completionFunction  p
t
    modeAction :: XPType -> String -> String -> X ()
modeAction          (XPT p
t) = p -> String -> String -> X ()
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 = t -> String -> [String] -> String
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 = IO [String] -> ComplFunction
forall a b. a -> b -> a
const (IO [String] -> ComplFunction) -> IO [String] -> ComplFunction
forall a b. (a -> b) -> a -> b
$ [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"Completions for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String
forall t. XPrompt t => t -> String
showXPrompt t
t String -> String -> String
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
_ = () -> X ()
forall a. a -> X a
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
(Int -> XPPosition -> String -> String)
-> (XPPosition -> String)
-> ([XPPosition] -> String -> String)
-> Show XPPosition
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> XPPosition -> String -> String
showsPrec :: Int -> XPPosition -> String -> String
$cshow :: XPPosition -> String
show :: XPPosition -> String
$cshowList :: [XPPosition] -> String -> String
showList :: [XPPosition] -> String -> String
Show,ReadPrec [XPPosition]
ReadPrec XPPosition
Int -> ReadS XPPosition
ReadS [XPPosition]
(Int -> ReadS XPPosition)
-> ReadS [XPPosition]
-> ReadPrec XPPosition
-> ReadPrec [XPPosition]
-> Read XPPosition
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS XPPosition
readsPrec :: Int -> ReadS XPPosition
$creadList :: ReadS [XPPosition]
readList :: ReadS [XPPosition]
$creadPrec :: ReadPrec XPPosition
readPrec :: ReadPrec XPPosition
$creadListPrec :: ReadPrec [XPPosition]
readListPrec :: ReadPrec [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 XPColor
forall a. Default a => a
def
        , fgColor :: String
fgColor               = XPColor -> String
fgNormal XPColor
forall a. Default a => a
def
        , bgHLight :: String
bgHLight              = XPColor -> String
bgHighlight XPColor
forall a. Default a => a
def
        , fgHLight :: String
fgHLight              = XPColor -> String
fgHighlight XPColor
forall a. Default a => a
def
        , borderColor :: String
borderColor           = XPColor -> String
border XPColor
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          = Maybe Dimension
forall a. Maybe a
Nothing
        , maxComplColumns :: Maybe Dimension
maxComplColumns       = Maybe Dimension
forall a. Maybe a
Nothing
        , historySize :: Int
historySize           = Int
256
        , historyFilter :: [String] -> [String]
historyFilter         = [String] -> [String]
forall a. a -> a
id
        , defaultText :: String
defaultText           = []
        , autoComplete :: Maybe Int
autoComplete          = Maybe Int
forall a. Maybe a
Nothing
        , showCompletionOnTab :: Bool
showCompletionOnTab   = Bool
False
        , complCaseSensitivity :: ComplCaseSensitivity
complCaseSensitivity  = ComplCaseSensitivity
CaseSensitive
        , searchPredicate :: String -> String -> Bool
searchPredicate       = String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf
        , alwaysHighlight :: Bool
alwaysHighlight       = Bool
False
        , defaultPrompter :: String -> String
defaultPrompter       = String -> String
forall a. a -> a
id
        , sorter :: String -> [String] -> [String]
sorter                = ([String] -> [String]) -> String -> [String] -> [String]
forall a b. a -> b -> a
const [String] -> [String]
forall a. a -> a
id
        }
greenXPConfig :: XPConfig
greenXPConfig = XPConfig
forall a. Default a => a
def { bgColor           = "black"
                    , fgColor           = "green"
                    , promptBorderWidth = 0
                    }
amberXPConfig :: XPConfig
amberXPConfig = XPConfig
forall a. Default a => a
def { bgColor   = "black"
                    , fgColor   = "#ca8f2d"
                    , fgHLight  = "#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           = Maybe ComplWindowDim
forall a. Maybe a
Nothing
        , complWin :: IORef (Maybe EventMask)
complWin              = IO (IORef (Maybe EventMask)) -> IORef (Maybe EventMask)
forall a. IO a -> a
unsafePerformIO (Maybe EventMask -> IO (IORef (Maybe EventMask))
forall a. a -> IO (IORef a)
newIORef Maybe EventMask
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      = Maybe String
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                = String -> Int
forall a. [a] -> Int
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    = Maybe [String]
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 -> Stack XPType -> XPType
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 Stack XPType -> [XPType]
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 = Stack XPType -> XPType
forall a. Stack a -> a
W.focus Stack XPType
modes
      in XPState
st { operationMode = XPMultipleModes W.Stack { W.up = [], W.focus = m, W.down = ms ++ [currentMode]}} --set next and move previous current mode to the of the stack
  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 -> Maybe String
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 :: [Position]
cwCols :: ComplWindowDim -> [Position]
cwCols, [Position]
cwRows :: [Position]
cwRows :: ComplWindowDim -> [Position]
cwRows } = ComplWindowDim
winDim
      complMatrix :: [[String]]
complMatrix = Int -> [String] -> [[String]]
forall a. Int -> [a] -> [[a]]
chunksOf ([Position] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Position]
cwRows) (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take ([Position] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Position]
cwCols Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Position] -> Int
forall a. [a] -> Int
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
      [] -> Maybe String
forall a. Maybe a
Nothing
      [String]
_  -> [[String]]
complMatrix [[String]] -> Int -> Maybe [String]
forall a. [a] -> Int -> Maybe a
!? Int
col_index Maybe [String] -> ([String] -> Maybe String) -> Maybe String
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([String] -> Int -> Maybe String
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) = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (XPState -> String
command XPState
st) (Maybe String -> String) -> Maybe String -> String
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 = Stack String -> String
forall a. Stack a -> a
W.focus (Stack String -> String)
-> (XPState -> Stack String) -> XPState -> String
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 = (commandHistory s) { W.focus = xs }}

-- | Sets the input string to the given value.
setInput :: String -> XP ()
setInput :: String -> XP ()
setInput = (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ())
-> (String -> XPState -> XPState) -> String -> XP ()
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 = (XPState -> String) -> XP String
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 = (XPState -> Int) -> XP Int
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 = (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { color = c $ color s }

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

-- | Reset the prompt colors to those from 'XPConfig'.
resetColor :: XP ()
resetColor :: XP ()
resetColor = (XPState -> XPColor) -> StateT XPState IO XPColor
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (XPConfig -> XPColor
defaultColor (XPConfig -> XPColor)
-> (XPState -> XPConfig) -> XPState -> XPColor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPConfig
config) StateT XPState IO XPColor -> (XPColor -> XP ()) -> XP ()
forall a b.
StateT XPState IO a
-> (a -> StateT XPState IO b) -> StateT XPState IO b
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 = 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 = (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { prompter = p $ prompter s }

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

-- | Reset the prompter to the one from 'XPConfig'.
resetPrompter :: XP ()
resetPrompter :: XP ()
resetPrompter = (XPState -> String -> String)
-> StateT XPState IO (String -> String)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (XPConfig -> String -> String
defaultPrompter (XPConfig -> String -> String)
-> (XPState -> XPConfig) -> XPState -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPConfig
config) StateT XPState IO (String -> String)
-> ((String -> String) -> XP ()) -> XP ()
forall a b.
StateT XPState IO a
-> (a -> StateT XPState IO b) -> StateT XPState IO b
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 = (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { currentCompletions = cs }

-- | Get the current completion list.
getCurrentCompletions :: XP (Maybe [String])
getCurrentCompletions :: XP (Maybe [String])
getCurrentCompletions = (XPState -> Maybe [String]) -> XP (Maybe [String])
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 (p -> String
forall t. XPrompt t => t -> String
showXPrompt p
t) XPConfig
conf (ComplFunction -> XPType -> XPOperationMode
XPSingleMode ComplFunction
compl (p -> XPType
forall p. XPrompt p => p -> XPType
XPT p
t))
  if XPState -> Bool
successful XPState
st'
    then a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> X a -> X (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> X a
action (XPState -> String
selectedCompletion XPState
st')
    else Maybe a -> X (Maybe a)
forall a. a -> X a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
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 = X (Maybe ()) -> X ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (X (Maybe ()) -> X ()) -> X (Maybe ()) -> X ()
forall a b. (a -> b) -> a -> b
$ p -> XPConfig -> ComplFunction -> (String -> X ()) -> X (Maybe ())
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
_ = () -> X ()
forall a. a -> X a
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 (XPType -> String
forall t. XPrompt t => t -> String
showXPrompt XPType
defaultMode) XPConfig
conf { alwaysHighlight = True } XPOperationMode
om
  Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (XPState -> Bool
successful XPState
st') (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$
    case XPState -> XPOperationMode
operationMode XPState
st' of
      XPMultipleModes Stack XPType
ms -> let
        action :: String -> String -> X ()
action = XPType -> String -> String -> X ()
forall t. XPrompt t => t -> String -> String -> X ()
modeAction (XPType -> String -> String -> X ())
-> XPType -> String -> String -> X ()
forall a b. (a -> b) -> a -> b
$ Stack XPType -> XPType
forall a. Stack a -> a
W.focus Stack XPType
ms
        in String -> String -> X ()
action (XPState -> String
command XPState
st') (String -> X ()) -> String -> X ()
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (XPState -> Maybe String
highlightedCompl XPState
st')
      XPOperationMode
_ -> String -> X ()
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 } <- X XConf
forall r (m :: * -> *). MonadReader r m => m r
ask
  Rectangle
s <- (XState -> Rectangle) -> X Rectangle
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XState -> Rectangle) -> X Rectangle)
-> (XState -> Rectangle) -> X Rectangle
forall a b. (a -> b) -> a -> b
$ ScreenDetail -> Rectangle
screenRect (ScreenDetail -> Rectangle)
-> (XState -> ScreenDetail) -> XState -> Rectangle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen String (Layout EventMask) EventMask ScreenId ScreenDetail
-> ScreenDetail
forall i l a sid sd. Screen i l a sid sd -> sd
W.screenDetail (Screen String (Layout EventMask) EventMask ScreenId ScreenDetail
 -> ScreenDetail)
-> (XState
    -> Screen
         String (Layout EventMask) EventMask ScreenId ScreenDetail)
-> XState
-> ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet String (Layout EventMask) EventMask ScreenId ScreenDetail
-> Screen String (Layout EventMask) EventMask ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (StackSet String (Layout EventMask) EventMask ScreenId ScreenDetail
 -> Screen
      String (Layout EventMask) EventMask ScreenId ScreenDetail)
-> (XState
    -> StackSet
         String (Layout EventMask) EventMask ScreenId ScreenDetail)
-> XState
-> Screen String (Layout EventMask) EventMask ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet
     String (Layout EventMask) EventMask ScreenId ScreenDetail
windowset
  KeyMask -> KeyMask
cleanMask <- X (KeyMask -> KeyMask)
cleanKeyMask
  String
cachedir <- (XConf -> String) -> X String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Directories' String -> String
forall a. Directories' a -> a
cacheDir (Directories' String -> String)
-> (XConf -> Directories' String) -> XConf -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> Directories' String
directories)
  Map String [String]
hist <- IO (Map String [String]) -> X (Map String [String])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Map String [String]) -> X (Map String [String]))
-> IO (Map String [String]) -> X (Map String [String])
forall a b. (a -> b) -> a -> b
$ String -> IO (Map String [String])
readHistory 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' <- IO XPState -> X XPState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO XPState -> X XPState) -> IO XPState -> X XPState
forall a b. (a -> b) -> a -> b
$
    IO EventMask
-> (EventMask -> IO ()) -> (EventMask -> IO XPState) -> IO XPState
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 ->
        IO GC -> (GC -> IO ()) -> (GC -> IO XPState) -> IO XPState
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 (EventMask -> IO ()) -> EventMask -> IO ()
forall a b. (a -> b) -> a -> b
$ EventMask
exposureMask EventMask -> EventMask -> EventMask
forall a. Bits a => a -> a -> a
.|. EventMask
keyPressMask
            Display -> GC -> Bool -> IO ()
setGraphicsExposures Display
d GC
gc Bool
False
            let hs :: [String]
hs = [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [String] -> [String]) -> Maybe [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Map String [String] -> Maybe [String]
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
  Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (XPState -> Bool
successful XPState
st') (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
    let prune :: [a] -> [a]
prune = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (XPConfig -> Int
historySize XPConfig
conf)
    IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ String -> Map String [String] -> IO ()
writeHistory String
cachedir (Map String [String] -> IO ()) -> Map String [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
      ([String] -> [String] -> [String])
-> String -> [String] -> Map String [String] -> Map String [String]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith
      (\[String]
xs [String]
ys -> [String] -> [String]
forall {a}. [a] -> [a]
prune ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPConfig -> [String] -> [String]
historyFilter XPConfig
conf ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
xs [String] -> [String] -> [String]
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
      ([String] -> [String]
forall {a}. [a] -> [a]
prune ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ XPConfig -> [String] -> [String]
historyFilter XPConfig
conf [XPState -> String
selectedCompletion XPState
st'])
      Map String [String]
hist
  XPState -> X XPState
forall a. a -> X a
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 :: XPPosition -> Rational
xpWidth :: Rational
xpWidth } -> Rational -> Dimension
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> Dimension) -> Rational -> Dimension
forall a b. (a -> b) -> a -> b
$ Dimension -> Rational
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
scr) Rational -> Rational -> Rational
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
  IO CInt -> (CInt -> IO ()) -> (CInt -> IO XPState) -> IO XPState
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 ->
      XP () -> XPState -> IO XPState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT
        (Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
status CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
grabSuccess) (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$ do
          Bool
ah <- (XPState -> Bool) -> StateT XPState IO Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (XPConfig -> Bool
alwaysHighlight (XPConfig -> Bool) -> (XPState -> XPConfig) -> XPState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPConfig
config)
          Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ah (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$ do
            Maybe String
compl <- [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> Maybe String)
-> StateT XPState IO [String] -> StateT XPState IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT XPState IO [String]
getCompletions
            (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
xpst -> XPState
xpst{ highlightedCompl = compl }
          XP ()
updateWindows
          (KeyStroke -> Event -> XP ()) -> StateT XPState IO Bool -> XP ()
eventLoop KeyStroke -> Event -> XP ()
handleMain StateT XPState IO Bool
evDefaultStop)
        XPState
st
      IO XPState -> IO () -> IO XPState
forall a b. IO a -> IO b -> IO a
`finally` ((EventMask -> IO ()) -> Maybe EventMask -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Display -> EventMask -> IO ()
destroyWindow Display
d) (Maybe EventMask -> IO ()) -> IO (Maybe EventMask) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Maybe EventMask) -> IO (Maybe EventMask)
forall a. IORef a -> IO a
readIORef (XPState -> IORef (Maybe EventMask)
complWin XPState
st))
      IO XPState -> IO () -> IO XPState
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) = String -> Bool
forall a. [a] -> Bool
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 ()) -> StateT XPState IO Bool -> XP ()
eventLoop KeyStroke -> Event -> XP ()
handle StateT XPState IO Bool
stopAction = do
    [(EventMask, String, Event)]
b <- (XPState -> [(EventMask, String, Event)])
-> StateT XPState IO [(EventMask, String, Event)]
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 <- (XPState -> Display) -> StateT XPState IO Display
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Display
dpy
                IO (EventMask, String, Event)
-> StateT XPState IO (EventMask, String, Event)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (EventMask, String, Event)
 -> StateT XPState IO (EventMask, String, Event))
-> IO (EventMask, String, Event)
-> StateT XPState IO (EventMask, String, Event)
forall a b. (a -> b) -> a -> b
$ (XEventPtr -> IO (EventMask, String, Event))
-> IO (EventMask, String, Event)
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO (EventMask, String, Event))
 -> IO (EventMask, String, Event))
-> (XEventPtr -> IO (EventMask, String, Event))
-> IO (EventMask, String, Event)
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 EventMask -> EventMask -> EventMask
forall a. Bits a => a -> a -> a
.|. EventMask
keyPressMask EventMask -> EventMask -> EventMask
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 Dimension -> Dimension -> Bool
forall a. Eq a => a -> a -> Bool
== Dimension
keyPress
                        then do (Maybe EventMask
_, String
s) <- XKeyEventPtr -> IO (Maybe EventMask, String)
lookupString (XKeyEventPtr -> IO (Maybe EventMask, String))
-> XKeyEventPtr -> IO (Maybe EventMask, String)
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
                                (EventMask, String, Event) -> IO (EventMask, String, Event)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (EventMask
ks, String
s, Event
ev)
                        else (EventMask, String, Event) -> IO (EventMask, String, Event)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (EventMask
noSymbol, String
"", Event
ev)
        ((EventMask, String, Event)
l : [(EventMask, String, Event)]
ls) -> do
                (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { eventBuffer = ls }
                (EventMask, String, Event)
-> StateT XPState IO (EventMask, String, Event)
forall a. a -> StateT XPState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (EventMask, String, Event)
l
    KeyStroke -> Event -> XP ()
handle (EventMask
keysym,String
keystr) Event
event
    StateT XPState IO Bool
stopAction StateT XPState IO Bool -> (Bool -> XP ()) -> XP ()
forall a b.
StateT XPState IO a
-> (a -> StateT XPState IO b) -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
stop -> Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
stop ((KeyStroke -> Event -> XP ()) -> StateT XPState IO Bool -> XP ()
eventLoop KeyStroke -> Event -> XP ()
handle StateT XPState IO Bool
stopAction)

-- | Default event loop stop condition.
evDefaultStop :: XP Bool
evDefaultStop :: StateT XPState IO Bool
evDefaultStop = (XPState -> Bool -> Bool) -> StateT XPState IO (Bool -> Bool)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool)
-> (XPState -> Bool) -> XPState -> Bool -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> Bool
modeDone) StateT XPState IO (Bool -> Bool)
-> StateT XPState IO Bool -> StateT XPState IO Bool
forall a b.
StateT XPState IO (a -> b)
-> StateT XPState IO a -> StateT XPState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (XPState -> Bool) -> StateT XPState IO Bool
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 <- StateT XPState IO XPState
forall s (m :: * -> *). MonadState s m => m s
get
    Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (XPState -> EventMask
win XPState
st EventMask -> EventMask -> Bool
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]
    Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Dimension
t Dimension -> Dimension -> Bool
forall a. Eq a => a -> a -> Bool
== Dimension
buttonPress) (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$ do
        Display
d <- (XPState -> Display) -> StateT XPState IO Display
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Display
dpy
        IO () -> XP ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> XP ()) -> IO () -> XP ()
forall a b. (a -> b) -> a -> b
$ Display -> CInt -> EventMask -> IO ()
allowEvents Display
d CInt
replayPointer EventMask
currentTime
handleOther KeyStroke
_ Event
_ = () -> XP ()
forall a. a -> StateT XPState IO a
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)) <- (XPState
 -> ((KeyMask, EventMask), ((KeyMask, EventMask), EventMask)))
-> StateT
     XPState
     IO
     ((KeyMask, EventMask), ((KeyMask, EventMask), EventMask))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XPState
  -> ((KeyMask, EventMask), ((KeyMask, EventMask), EventMask)))
 -> StateT
      XPState
      IO
      ((KeyMask, EventMask), ((KeyMask, EventMask), EventMask)))
-> (XPState
    -> ((KeyMask, EventMask), ((KeyMask, EventMask), EventMask)))
-> StateT
     XPState
     IO
     ((KeyMask, EventMask), ((KeyMask, EventMask), EventMask))
forall a b. (a -> b) -> a -> b
$
          (XPConfig -> (KeyMask, EventMask)
prevCompletionKey (XPConfig -> (KeyMask, EventMask))
-> (XPConfig -> ((KeyMask, EventMask), EventMask))
-> XPConfig
-> ((KeyMask, EventMask), ((KeyMask, EventMask), EventMask))
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPConfig -> (KeyMask, EventMask)
completionKey (XPConfig -> (KeyMask, EventMask))
-> (XPConfig -> EventMask)
-> XPConfig
-> ((KeyMask, EventMask), EventMask)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPConfig -> EventMask
changeModeKey) (XPConfig
 -> ((KeyMask, EventMask), ((KeyMask, EventMask), EventMask)))
-> (XPState -> XPConfig)
-> XPState
-> ((KeyMask, EventMask), ((KeyMask, EventMask), EventMask))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPConfig
config
      KeyMask
keymask <- (XPState -> KeyMask -> KeyMask)
-> StateT XPState IO (KeyMask -> KeyMask)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> KeyMask -> KeyMask
cleanMask StateT XPState IO (KeyMask -> KeyMask)
-> StateT XPState IO KeyMask -> StateT XPState IO KeyMask
forall a b.
StateT XPState IO (a -> b)
-> StateT XPState IO a -> StateT XPState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KeyMask -> StateT XPState IO KeyMask
forall a. a -> StateT XPState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyMask
m
      -- haven't subscribed to keyRelease, so just in case
      Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Dimension
t Dimension -> Dimension -> Bool
forall a. Eq a => a -> a -> Bool
== Dimension
keyPress) (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$ if
          | (KeyMask
keymask, EventMask
keysym) (KeyMask, EventMask) -> (KeyMask, EventMask) -> Bool
forall a. Eq a => a -> a -> Bool
== (KeyMask, EventMask)
compKey ->
               XP (Maybe [String])
getCurrentCompletions XP (Maybe [String]) -> (Maybe [String] -> XP ()) -> XP ()
forall a b.
StateT XPState IO a
-> (a -> StateT XPState IO b) -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Direction1D -> Maybe [String] -> XP ()
handleCompletionMain Direction1D
Next
          | (KeyMask
keymask, EventMask
keysym) (KeyMask, EventMask) -> (KeyMask, EventMask) -> Bool
forall a. Eq a => a -> a -> Bool
== (KeyMask, EventMask)
prevCompKey ->
               XP (Maybe [String])
getCurrentCompletions XP (Maybe [String]) -> (Maybe [String] -> XP ()) -> XP ()
forall a b.
StateT XPState IO a
-> (a -> StateT XPState IO b) -> StateT XPState IO b
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 <- (XPState -> Map (KeyMask, EventMask) (XP ()))
-> StateT XPState IO (Map (KeyMask, EventMask) (XP ()))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (XPConfig -> Map (KeyMask, EventMask) (XP ())
promptKeymap (XPConfig -> Map (KeyMask, EventMask) (XP ()))
-> (XPState -> XPConfig)
-> XPState
-> Map (KeyMask, EventMask) (XP ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPConfig
config)
               let mbAction :: Maybe (XP ())
mbAction = (KeyMask, EventMask)
-> Map (KeyMask, EventMask) (XP ()) -> Maybe (XP ())
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.
               Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (KeyStroke -> Bool
isModifier KeyStroke
stroke Bool -> Bool -> Bool
&& Maybe (XP ()) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (XP ())
mbAction) (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$ do
                   Maybe [String] -> XP ()
setCurrentCompletions Maybe [String]
forall a. Maybe a
Nothing
                   if EventMask
keysym EventMask -> EventMask -> Bool
forall a. Eq a => a -> a -> Bool
== EventMask
modeKey
                      then (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify XPState -> XPState
setNextMode XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
updateWindows
        Maybe (XP ())
Nothing     -> Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (KeyMask
keymask KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.&. KeyMask
controlMask KeyMask -> KeyMask -> Bool
forall a. Eq a => a -> a -> Bool
== KeyMask
0) (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$ do
            String -> XP ()
insertString (String -> XP ()) -> String -> XP ()
forall a b. (a -> b) -> a -> b
$ String -> String
utf8Decode String
keystr
            XP ()
updateWindows
            XP ()
updateHighlightedCompl
            Bool
complete <- StateT XPState IO Bool
tryAutoComplete
            Bool -> XP () -> XP ()
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 <- StateT XPState IO [String]
getCompletions
       Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
cs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$
           (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { showComplWin = True }
       Maybe [String] -> XP ()
setCurrentCompletions (Maybe [String] -> XP ()) -> Maybe [String] -> XP ()
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe [String]
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 <- (XPState -> Bool) -> StateT XPState IO Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XPState -> Bool) -> StateT XPState IO Bool)
-> (XPState -> Bool) -> StateT XPState IO Bool
forall a b. (a -> b) -> a -> b
$ XPConfig -> Bool
alwaysHighlight (XPConfig -> Bool) -> (XPState -> XPConfig) -> XPState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPConfig
config
    XPState
st <- StateT XPState IO XPState
forall s (m :: * -> *). MonadState s m => m s
get

    let updateWins :: [String] -> XP ()
updateWins    = XP () -> [String] -> XP ()
redrawWindows (() -> XP ()
forall a. a -> StateT XPState IO a
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 (String -> String) -> String -> String
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' <- StateT XPState IO [String]
getCompletions
                [String] -> XP ()
updateWins [String]
cs'
                Maybe [String] -> XP ()
setCurrentCompletions (Maybe [String] -> XP ()) -> Maybe [String] -> XP ()
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe [String]
forall a. a -> Maybe a
Just [String]
cs'
      [String]
l   -> [String] -> XP ()
updateState [String]
l   XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 = XPType -> String -> [String] -> String
forall t. XPrompt t => t -> String -> [String] -> String
nextCompletion (XPState -> XPType
currentXPMode XPState
st) (XPState -> String
command XPState
st) [String]
l
          (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> String -> XPState -> XPState
setCommand String
newCommand (XPState -> XPState) -> XPState -> XPState
forall a b. (a -> b) -> a -> b
$
                         XPState
s { offset = length newCommand
                           , highlightedCompl = Just 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 :| []) <- [String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [String]
cs =
              if XPState -> String
command XPState
st String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
hlCompl
              then XPState -> XP ()
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 (XPState -> XP ()) -> XPState -> XP ()
forall a b. (a -> b) -> a -> b
$ XPState
st{ complIndex = complIndex'
                                       , highlightedCompl = 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       = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (XPState -> String
command XPState
st) (Maybe String -> String) -> Maybe String -> String
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 = complIndex' } [String]
cs

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

          String -> XP ()
replaceCompletion :: String -> XP () = \String
str -> do
              XPState -> XP ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put XPState
st
              Int -> XP () -> XP ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> Int) -> [String] -> Int
forall a b. (a -> b) -> a -> b
$ String -> [String]
words String
str) (XP () -> XP ()) -> XP () -> XP ()
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 <- (XPState -> Bool) -> StateT XPState IO Bool
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 ()) -> StateT XPState IO Bool -> XP ()
eventLoop (XP ()
-> Map (KeyMask, EventMask) (XP ()) -> KeyStroke -> Event -> XP ()
handleSubmap XP ()
defaultAction Map (KeyMask, EventMask) (XP ())
keymap) StateT XPState IO 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 <- (XPState -> KeyMask -> KeyMask)
-> StateT XPState IO (KeyMask -> KeyMask)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> KeyMask -> KeyMask
cleanMask StateT XPState IO (KeyMask -> KeyMask)
-> StateT XPState IO KeyMask -> StateT XPState IO KeyMask
forall a b.
StateT XPState IO (a -> b)
-> StateT XPState IO a -> StateT XPState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KeyMask -> StateT XPState IO KeyMask
forall a. a -> StateT XPState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyMask
m
    Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Dimension
t Dimension -> Dimension -> Bool
forall a. Eq a => a -> a -> Bool
== Dimension
keyPress) (XP () -> XP ()) -> XP () -> XP ()
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 (KeyMask, EventMask)
-> Map (KeyMask, EventMask) (XP ()) -> Maybe (XP ())
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 XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
updateWindows
        Maybe (XP ())
Nothing     -> Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (KeyStroke -> Bool
isModifier KeyStroke
stroke) (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$ XP ()
defaultAction XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 <- (XPState -> Bool) -> StateT XPState IO Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Bool
modeDone
    Bool -> XP ()
setModeDone Bool
False
    (KeyStroke -> Event -> XP ()) -> StateT XPState IO Bool -> XP ()
eventLoop ((String -> String -> (Bool, Bool)) -> KeyStroke -> Event -> XP ()
handleBuffer String -> String -> (Bool, Bool)
f) StateT XPState IO Bool
evDefaultStop
    String
buff <- (XPState -> String) -> XP String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> String
inputBuffer
    (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { inputBuffer = "" }
    Bool -> XP ()
setModeDone Bool
md
    String -> XP String
forall a. a -> StateT XPState IO a
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 <- (XPState -> KeyMask -> KeyMask)
-> StateT XPState IO (KeyMask -> KeyMask)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> KeyMask -> KeyMask
cleanMask StateT XPState IO (KeyMask -> KeyMask)
-> StateT XPState IO KeyMask -> StateT XPState IO KeyMask
forall a b.
StateT XPState IO (a -> b)
-> StateT XPState IO a -> StateT XPState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KeyMask -> StateT XPState IO KeyMask
forall a. a -> StateT XPState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyMask
m
    Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Dimension
t Dimension -> Dimension -> Bool
forall a. Eq a => a -> a -> Bool
== Dimension
keyPress) (XP () -> XP ()) -> XP () -> XP ()
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 =
    Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (KeyStroke -> Bool
isModifier KeyStroke
stroke Bool -> Bool -> Bool
|| KeyMask
keymask KeyMask -> KeyMask -> KeyMask
forall a. Bits a => a -> a -> a
.&. KeyMask
controlMask KeyMask -> KeyMask -> Bool
forall a. Eq a => a -> a -> Bool
/= KeyMask
0) (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$ do
        ([(EventMask, String, Event)]
evB,String
inB) <- (XPState -> ([(EventMask, String, Event)], String))
-> StateT XPState IO ([(EventMask, String, Event)], String)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (XPState -> [(EventMask, String, Event)]
eventBuffer (XPState -> [(EventMask, String, Event)])
-> (XPState -> String)
-> XPState
-> ([(EventMask, String, Event)], String)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
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'
        Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
keep (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$
            (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { inputBuffer = inB ++ keystr' }
        Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
cont (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$
            Bool -> XP ()
setModeDone Bool
True
        Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
cont Bool -> Bool -> Bool
|| Bool
keep) (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$
            (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { eventBuffer = (keysym,keystr,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 = (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
xs Bool -> Bool -> Bool
&& String -> Bool
forall a. [a] -> 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 :: ComplWindowDim -> [Position]
cwCols :: [Position]
cwCols, [Position]
cwRows :: ComplWindowDim -> [Position]
cwRows :: [Position]
cwRows } ->
    if Int
rowm Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
currentrow Int -> Int -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
direction) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` [Position] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Position]
cwCols
      , (Int
currentrow Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
direction) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` [Position] -> Int
forall a. [a] -> Int
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 :: StateT XPState IO Bool
tryAutoComplete = do
    Maybe Int
ac <- (XPState -> Maybe Int) -> StateT XPState IO (Maybe Int)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (XPConfig -> Maybe Int
autoComplete (XPConfig -> Maybe Int)
-> (XPState -> XPConfig) -> XPState -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPConfig
config)
    case Maybe Int
ac of
        Just Int
d -> do [String]
cs <- StateT XPState IO [String]
getCompletions
                     case [String]
cs of
                         [String
c] -> String -> Int -> StateT XPState IO Bool
runCompleted String
c Int
d StateT XPState IO Bool
-> StateT XPState IO Bool -> StateT XPState IO Bool
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> StateT XPState IO Bool
forall a. a -> StateT XPState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                         [String]
_   -> Bool -> StateT XPState IO Bool
forall a. a -> StateT XPState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Maybe Int
Nothing    -> Bool -> StateT XPState IO Bool
forall a. a -> StateT XPState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where runCompleted :: String -> Int -> StateT XPState IO Bool
runCompleted String
cmd Int
delay = do
            XPState
st <- StateT XPState IO XPState
forall s (m :: * -> *). MonadState s m => m s
get
            let new_command :: String
new_command = XPType -> String -> [String] -> String
forall t. XPrompt t => t -> String -> [String] -> String
nextCompletion (XPState -> XPType
currentXPMode XPState
st) (XPState -> String
command XPState
st) [String
cmd]
            (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ String -> XPState -> XPState
setCommand String
"autocompleting..."
            XP ()
updateWindows
            IO () -> XP ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> XP ()) -> IO () -> XP ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
delay
            (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ String -> XPState -> XPState
setCommand String
new_command
            Bool -> StateT XPState IO Bool
forall a. a -> StateT XPState IO a
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 = [((KeyMask, EventMask), XP ())] -> Map (KeyMask, EventMask) (XP ())
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((KeyMask, EventMask), XP ())]
 -> Map (KeyMask, EventMask) (XP ()))
-> [((KeyMask, EventMask), XP ())]
-> Map (KeyMask, EventMask) (XP ())
forall a b. (a -> b) -> a -> b
$
  ((EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> [(EventMask, XP ())] -> [((KeyMask, EventMask), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((EventMask -> (KeyMask, EventMask))
-> (EventMask, XP ()) -> ((KeyMask, EventMask), XP ())
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((EventMask -> (KeyMask, EventMask))
 -> (EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> (EventMask -> (KeyMask, EventMask))
-> (EventMask, XP ())
-> ((KeyMask, EventMask), XP ())
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 XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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)
  ] [((KeyMask, EventMask), XP ())]
-> [((KeyMask, EventMask), XP ())]
-> [((KeyMask, EventMask), XP ())]
forall a. [a] -> [a] -> [a]
++
  ((EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> [(EventMask, XP ())] -> [((KeyMask, EventMask), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((EventMask -> (KeyMask, EventMask))
-> (EventMask, XP ()) -> ((KeyMask, EventMask), XP ())
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((EventMask -> (KeyMask, EventMask))
 -> (EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> (EventMask -> (KeyMask, EventMask))
-> (EventMask, XP ())
-> ((KeyMask, EventMask), XP ())
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 Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusUp')
  , (EventMask
xK_Up, (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
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 = [((KeyMask, EventMask), XP ())] -> Map (KeyMask, EventMask) (XP ())
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((KeyMask, EventMask), XP ())]
 -> Map (KeyMask, EventMask) (XP ()))
-> [((KeyMask, EventMask), XP ())]
-> Map (KeyMask, EventMask) (XP ())
forall a b. (a -> b) -> a -> b
$
  ((EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> [(EventMask, XP ())] -> [((KeyMask, EventMask), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((EventMask -> (KeyMask, EventMask))
-> (EventMask, XP ()) -> ((KeyMask, EventMask), XP ())
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((EventMask -> (KeyMask, EventMask))
 -> (EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> (EventMask -> (KeyMask, EventMask))
-> (EventMask, XP ())
-> ((KeyMask, EventMask), XP ())
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)
  ] [((KeyMask, EventMask), XP ())]
-> [((KeyMask, EventMask), XP ())]
-> [((KeyMask, EventMask), XP ())]
forall a. [a] -> [a] -> [a]
++
  ((EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> [(EventMask, XP ())] -> [((KeyMask, EventMask), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((EventMask -> (KeyMask, EventMask))
-> (EventMask, XP ()) -> ((KeyMask, EventMask), XP ())
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((EventMask -> (KeyMask, EventMask))
 -> (EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> (EventMask -> (KeyMask, EventMask))
-> (EventMask, XP ())
-> ((KeyMask, EventMask), XP ())
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 XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusUp')
  , (EventMask
xK_p, (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusDown')
  ]
  [((KeyMask, EventMask), XP ())]
-> [((KeyMask, EventMask), XP ())]
-> [((KeyMask, EventMask), XP ())]
forall a. [a] -> [a] -> [a]
++
  ((EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> [(EventMask, XP ())] -> [((KeyMask, EventMask), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((EventMask -> (KeyMask, EventMask))
-> (EventMask, XP ()) -> ((KeyMask, EventMask), XP ())
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((EventMask -> (KeyMask, EventMask))
 -> (EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> (EventMask -> (KeyMask, EventMask))
-> (EventMask, XP ())
-> ((KeyMask, EventMask), XP ())
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 Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusUp')
  , (EventMask
xK_Up, (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
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") String -> String
forall a. a -> a
id String -> String
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 = [((KeyMask, EventMask), XP ())] -> Map (KeyMask, EventMask) (XP ())
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((KeyMask, EventMask), XP ())]
 -> Map (KeyMask, EventMask) (XP ()))
-> [((KeyMask, EventMask), XP ())]
-> Map (KeyMask, EventMask) (XP ())
forall a b. (a -> b) -> a -> b
$
    ((EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> [(EventMask, XP ())] -> [((KeyMask, EventMask), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((EventMask -> (KeyMask, EventMask))
-> (EventMask, XP ()) -> ((KeyMask, EventMask), XP ())
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((EventMask -> (KeyMask, EventMask))
 -> (EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> (EventMask -> (KeyMask, EventMask))
-> (EventMask, XP ())
-> ((KeyMask, EventMask), XP ())
forall a b. (a -> b) -> a -> b
$ (,) KeyMask
controlMask) -- control + <key>
    [ (EventMask
xK_m, XP ()
acceptSelection)
    ] [((KeyMask, EventMask), XP ())]
-> [((KeyMask, EventMask), XP ())]
-> [((KeyMask, EventMask), XP ())]
forall a. [a] -> [a] -> [a]
++
    ((EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> [(EventMask, XP ())] -> [((KeyMask, EventMask), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((EventMask -> (KeyMask, EventMask))
-> (EventMask, XP ()) -> ((KeyMask, EventMask), XP ())
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((EventMask -> (KeyMask, EventMask))
 -> (EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> (EventMask -> (KeyMask, EventMask))
-> (EventMask, XP ())
-> ((KeyMask, EventMask), XP ())
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 Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusUp')
    , (EventMask
xK_Up,           (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusDown')
    , (EventMask
xK_Escape,       Direction1D -> XP ()
moveCursor Direction1D
Prev
                            XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (XPColor -> XPColor) -> XP ()
modifyColor XPColor -> XPColor
fromColor
                            XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (String -> String) -> XP ()
setPrompter String -> String
promptF
                            XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP () -> Map (KeyMask, EventMask) (XP ()) -> XP ()
promptSubmap (() -> XP ()
forall a. a -> StateT XPState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Map (KeyMask, EventMask) (XP ())
normalVimXPKeymap
                            XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
resetColor
                            XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
resetPrompter
      )
    ] where
    normalVimXPKeymap :: Map (KeyMask, EventMask) (XP ())
normalVimXPKeymap = [((KeyMask, EventMask), XP ())] -> Map (KeyMask, EventMask) (XP ())
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((KeyMask, EventMask), XP ())]
 -> Map (KeyMask, EventMask) (XP ()))
-> [((KeyMask, EventMask), XP ())]
-> Map (KeyMask, EventMask) (XP ())
forall a b. (a -> b) -> a -> b
$
        ((EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> [(EventMask, XP ())] -> [((KeyMask, EventMask), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((EventMask -> (KeyMask, EventMask))
-> (EventMask, XP ()) -> ((KeyMask, EventMask), XP ())
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((EventMask -> (KeyMask, EventMask))
 -> (EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> (EventMask -> (KeyMask, EventMask))
-> (EventMask, XP ())
-> ((KeyMask, EventMask), XP ())
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 XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
clipCursor)
        , (EventMask
xK_Delete,       Direction1D -> XP ()
deleteString Direction1D
Next XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
clipCursor)
        , (EventMask
xK_p,            Direction1D -> XP ()
moveCursor Direction1D
Next
                                XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (String -> String) -> XP ()
pasteString' String -> String
pasteFilter
                                XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusUp')
        , (EventMask
xK_j,            (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusUp')
        , (EventMask
xK_Up,           (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusDown')
        , (EventMask
xK_k,            (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
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 XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
notWord) Direction1D
Next XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 XP String -> (String -> XP ()) -> XP ()
forall a b.
StateT XPState IO a
-> (a -> StateT XPState IO b) -> StateT XPState IO b
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
                                XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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)
        ] [((KeyMask, EventMask), XP ())]
-> [((KeyMask, EventMask), XP ())]
-> [((KeyMask, EventMask), XP ())]
forall a. [a] -> [a] -> [a]
++
        ((EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> [(EventMask, XP ())] -> [((KeyMask, EventMask), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((EventMask -> (KeyMask, EventMask))
-> (EventMask, XP ()) -> ((KeyMask, EventMask), XP ())
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((EventMask -> (KeyMask, EventMask))
 -> (EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> (EventMask -> (KeyMask, EventMask))
-> (EventMask, XP ())
-> ((KeyMask, EventMask), XP ())
forall a b. (a -> b) -> a -> b
$ (,) KeyMask
shiftMask)
        [ (EventMask
xK_dollar,       XP ()
endOfLine XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursor Direction1D
Prev)
        , (EventMask
xK_D,            XP ()
killAfter XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursor Direction1D
Prev)
        , (EventMask
xK_C,            XP ()
killAfter XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursor Direction1D
Prev)
        , (EventMask
xK_A,            XP ()
endOfLine XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True)
        , (EventMask
xK_I,            XP ()
startOfLine XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 XP String -> (String -> XP ()) -> XP ()
forall a b.
StateT XPState IO a
-> (a -> StateT XPState IO b) -> StateT XPState IO b
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 = [((KeyMask, EventMask), XP ())] -> Map (KeyMask, EventMask) (XP ())
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((KeyMask, EventMask), XP ())]
 -> Map (KeyMask, EventMask) (XP ()))
-> [((KeyMask, EventMask), XP ())]
-> Map (KeyMask, EventMask) (XP ())
forall a b. (a -> b) -> a -> b
$
        ((EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> [(EventMask, XP ())] -> [((KeyMask, EventMask), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((EventMask -> (KeyMask, EventMask))
-> (XP () -> XP ())
-> (EventMask, XP ())
-> ((KeyMask, EventMask), XP ())
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (KeyMask
0 ,) (XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
notWord Direction1D
Next XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
notWord) Direction1D
Next XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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
"")
        ] [((KeyMask, EventMask), XP ())]
-> [((KeyMask, EventMask), XP ())]
-> [((KeyMask, EventMask), XP ())]
forall a. [a] -> [a] -> [a]
++
        ((EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> [(EventMask, XP ())] -> [((KeyMask, EventMask), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((EventMask -> (KeyMask, EventMask))
-> (XP () -> XP ())
-> (EventMask, XP ())
-> ((KeyMask, EventMask), XP ())
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (KeyMask
shiftMask ,) (XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True))
        [ (EventMask
xK_dollar,       XP ()
killAfter XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursor Direction1D
Prev)
        ]
    changeVimXPKeymap :: Map (KeyMask, EventMask) (XP ())
changeVimXPKeymap = [((KeyMask, EventMask), XP ())] -> Map (KeyMask, EventMask) (XP ())
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((KeyMask, EventMask), XP ())]
 -> Map (KeyMask, EventMask) (XP ()))
-> [((KeyMask, EventMask), XP ())]
-> Map (KeyMask, EventMask) (XP ())
forall a b. (a -> b) -> a -> b
$
        ((EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> [(EventMask, XP ())] -> [((KeyMask, EventMask), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((EventMask -> (KeyMask, EventMask))
-> (XP () -> XP ())
-> (EventMask, XP ())
-> ((KeyMask, EventMask), XP ())
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (KeyMask
0 ,) (XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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)
        ] [((KeyMask, EventMask), XP ())]
-> [((KeyMask, EventMask), XP ())]
-> [((KeyMask, EventMask), XP ())]
forall a. [a] -> [a] -> [a]
++
        ((EventMask, XP ()) -> ((KeyMask, EventMask), XP ()))
-> [(EventMask, XP ())] -> [((KeyMask, EventMask), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((EventMask -> (KeyMask, EventMask))
-> (XP () -> XP ())
-> (EventMask, XP ())
-> ((KeyMask, EventMask), XP ())
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (KeyMask
shiftMask, ) (XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 = (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { successful = b }

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

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

-- KeyPress and State

-- | Accept the current selection and exit.
acceptSelection :: StateT XPState IO ()
acceptSelection :: XP ()
acceptSelection = Bool -> XP ()
setSuccess Bool
True XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setSuccess Bool
False XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setDone Bool
True XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
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 =
  (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> String -> XPState -> XPState
setCommand (Int -> String -> String
forall a. Int -> [a] -> [a]
drop (XPState -> Int
offset XPState
s) (XPState -> String
command XPState
s)) (XPState -> XPState) -> XPState -> XPState
forall a b. (a -> b) -> a -> b
$ XPState
s { offset  = 0 }

-- | Kill the portion of the command including and after the cursor
killAfter :: XP ()
killAfter :: XP ()
killAfter =
  (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> String -> XPState -> XPState
setCommand (Int -> String -> String
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 <- (XPState -> Int) -> XP Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Int
offset
  String
c <- (XPState -> String) -> XP String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> String
command
  let (String
f,String
ss)        = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
o String
c
      delNextWord :: String -> String
delNextWord   = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
p) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
p
      delPrevWord :: String -> String
delPrevWord   = String -> String
forall {a}. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
delNextWord (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall {a}. [a] -> [a]
reverse
      (String
ncom,Int
noff)   =
          case Direction1D
d of
            Direction1D
Next -> (String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
delNextWord String
ss, Int
o)
            Direction1D
Prev -> (String -> String
delPrevWord String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ss, String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ String -> String
delPrevWord String
f) -- laziness!!
  (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> String -> XPState -> XPState
setCommand String
ncom (XPState -> XPState) -> XPState -> XPState
forall a b. (a -> b) -> a -> b
$ XPState
s { offset = 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 = StateT XPState IO (XP ()) -> XP ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (StateT XPState IO (XP ()) -> XP ())
-> StateT XPState IO (XP ()) -> XP ()
forall a b. (a -> b) -> a -> b
$ String -> Int -> (Char -> Bool) -> XP ()
f (String -> Int -> (Char -> Bool) -> XP ())
-> XP String -> StateT XPState IO (Int -> (Char -> Bool) -> XP ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XP String
getInput StateT XPState IO (Int -> (Char -> Bool) -> XP ())
-> XP Int -> StateT XPState IO ((Char -> Bool) -> XP ())
forall a b.
StateT XPState IO (a -> b)
-> StateT XPState IO a -> StateT XPState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> XP Int
getOffset StateT XPState IO ((Char -> Bool) -> XP ())
-> StateT XPState IO (Char -> Bool) -> StateT XPState IO (XP ())
forall a b.
StateT XPState IO (a -> b)
-> StateT XPState IO a -> StateT XPState IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Bool) -> StateT XPState IO (Char -> Bool)
forall a. a -> StateT XPState IO a
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
_ | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
off Bool -> Bool -> Bool
||
                      String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
str              = () -> XP ()
forall a. a -> StateT XPState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        f String
str Int
off Char -> Bool
p'| Char -> Bool
p' (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ String
str String -> Int -> Char
forall a. HasCallStack => [a] -> Int -> a
!! Int
off       = (Char -> Bool) -> Direction1D -> XP ()
killWord' (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
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 <- (XPState -> Int) -> XP Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Int
offset
  String
cmd <- (XPState -> String) -> XP String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> String
command
  let (String
beforeCursor, String
afterCursor) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
off String
cmd
      (String
ncom, Int
noff) = (String, Int) -> Maybe (String, Int) -> (String, Int)
forall a. a -> Maybe a -> a
fromMaybe (String
cmd, Int
off) (String -> String -> Int -> Maybe (String, Int)
forall a. [a] -> [a] -> Int -> Maybe ([a], Int)
go String
beforeCursor String
afterCursor Int
off)
  (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> String -> XPState -> XPState
setCommand String
ncom (XPState -> XPState) -> XPState -> XPState
forall a b. (a -> b) -> a -> b
$ XPState
s{ offset = noff }
 where
  go :: [a] -> [a] -> Int -> Maybe ([a], Int)
  go :: forall a. [a] -> [a] -> Int -> Maybe ([a], Int)
go ([a] -> [a]
forall {a}. [a] -> [a]
reverse -> (a
b1 : a
b2 : [a]
bs)) [] Int
offset =  -- end of line
    ([a], Int) -> Maybe ([a], Int)
forall a. a -> Maybe a
Just ([a] -> [a]
forall {a}. [a] -> [a]
reverse ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ a
b2 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a
b1 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
bs, Int
offset)
  go ([a] -> [a]
forall {a}. [a] -> [a]
reverse -> (a
b : [a]
bs)) (a
a : [a]
as) Int
offset =  -- middle of line
    ([a], Int) -> Maybe ([a], Int)
forall a. a -> Maybe a
Just ([a] -> [a]
forall {a}. [a] -> [a]
reverse (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
bs) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as, Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  go [a]
_ [a]
_ Int
_ = Maybe ([a], Int)
forall a. Maybe a
Nothing

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

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

-- |  Flush the command string and reset the offset
flushString :: XP ()
flushString :: XP ()
flushString = (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> String -> XPState -> XPState
setCommand String
"" (XPState -> XPState) -> XPState -> XPState
forall a b. (a -> b) -> a -> b
$ XPState
s { offset = 0}

--reset index if config has `alwaysHighlight`. The inserted char could imply fewer autocompletions.
--If the current index was column 2, row 1 and now there are only 4 autocompletion rows with 1 column, what should we highlight? Set it to the first and start navigation again
resetComplIndex :: XPState -> XPState
resetComplIndex :: XPState -> XPState
resetComplIndex XPState
st = if XPConfig -> Bool
alwaysHighlight (XPState -> XPConfig
config XPState
st) then XPState
st { complIndex = (0,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
  (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify XPState -> XPState
resetComplIndex

insertString' :: String -> XP ()
insertString' :: String -> XP ()
insertString' String
str =
  (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
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 = o (offset s)}
    in String -> XPState -> XPState
setCommand String
cmd XPState
st
  where o :: Int -> Int
o Int
oo = Int
oo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str
        c :: String -> Int -> String
c String
oc Int
oo | Int
oo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
oc = String
oc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str
                | Bool
otherwise = String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ss
                where (String
f,String
ss) = Int -> String -> (String, String)
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' String -> String
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 (String -> XP ()) -> (String -> String) -> String -> XP ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f (String -> XP ()) -> XP String -> XP ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< XP String
forall (m :: * -> *). MonadIO m => m String
getSelection

-- | Remove a character at the cursor position
deleteString :: Direction1D -> XP ()
deleteString :: Direction1D -> XP ()
deleteString Direction1D
d =
  (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> String -> XPState -> XPState
setCommand (String -> Int -> String
forall {a}. [a] -> Int -> [a]
c (XPState -> String
command XPState
s) (XPState -> Int
offset XPState
s)) (XPState -> XPState) -> XPState -> XPState
forall a b. (a -> b) -> a -> b
$ XPState
s { offset = o (offset s)}
  where o :: a -> a
o a
oo = if Direction1D
d Direction1D -> Direction1D -> Bool
forall a. Eq a => a -> a -> Bool
== Direction1D
Prev then a -> a -> a
forall a. Ord a => a -> a -> a
max a
0 (a
oo a -> a -> a
forall a. Num a => a -> a -> a
- a
1) else a
oo
        c :: [a] -> Int -> [a]
c [a]
oc Int
oo
            | Int
oo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
oc Bool -> Bool -> Bool
&& Direction1D
d Direction1D -> Direction1D -> Bool
forall a. Eq a => a -> a -> Bool
== Direction1D
Prev = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int
oo Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
oc
            | Int
oo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
oc Bool -> Bool -> Bool
&& Direction1D
d Direction1D -> Direction1D -> Bool
forall a. Eq a => a -> a -> Bool
== Direction1D
Prev = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int
oo Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
f [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
ss
            | Int
oo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
oc Bool -> Bool -> Bool
&& Direction1D
d Direction1D -> Direction1D -> Bool
forall a. Eq a => a -> a -> Bool
== Direction1D
Next = [a]
f [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
1 [a]
ss
            | Bool
otherwise = [a]
oc
            where ([a]
f,[a]
ss) = Int -> [a] -> ([a], [a])
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 = (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { offset = o (offset s) (command s)}
    where o :: Int -> t a -> Int
o Int
oo t a
c = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
c Int -> Int -> Int
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 =
  (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { offset = o (offset s) (command s)}
  where o :: Int -> t a -> Int
o Int
oo t a
c = if Direction1D
d Direction1D -> Direction1D -> Bool
forall a. Eq a => a -> a -> Bool
== Direction1D
Prev then Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
oo Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) else Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
c) (Int
oo Int -> Int -> Int
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 = (XP () -> XP () -> XP ()
forall a b.
StateT XPState IO a -> StateT XPState IO b -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
clipCursor) (XP () -> XP ()) -> (Direction1D -> XP ()) -> Direction1D -> XP ()
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 <- (XPState -> String) -> XP String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> String
command
  Int
o <- (XPState -> Int) -> XP Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Int
offset
  let (String
f,String
ss) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitOn Int
o String
c
      splitOn :: Int -> [a] -> ([a], [a])
splitOn Int
n [a]
xs = (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [a]
xs, Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
n [a]
xs)
      gap :: Int
gap = case Direction1D
d of
                Direction1D
Prev -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
c
                Direction1D
Next -> Int
0
      len :: String -> Int
len = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> (String -> Int) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int) -> Int -> Int -> Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip (-) Int
1 (Int -> Int) -> (String -> Int) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
gap Int -> Int -> Int
forall a. Num a => a -> a -> a
+)
          (Int -> Int) -> (String -> Int) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int) -> (Int, Int) -> Int
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> Int
forall a. Num a => a -> a -> a
(+)
          ((Int, Int) -> Int) -> (String -> (Int, Int)) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> (String -> Int) -> (String, String) -> (Int, Int)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> (String -> String) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
p)))
          ((String, String) -> (Int, Int))
-> (String -> (String, String)) -> String -> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
p
      newoff :: Int
newoff = case Direction1D
d of
                Direction1D
Prev -> Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
len (String -> String
forall {a}. [a] -> [a]
reverse String
f)
                Direction1D
Next -> Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
len String
ss
  (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { offset = 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
  (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> let ch :: Stack String
ch = Stack String -> Stack String
f (Stack String -> Stack String) -> Stack String -> Stack String
forall a b. (a -> b) -> a -> b
$ XPState -> Stack String
commandHistory XPState
s
                 in XPState
s { commandHistory = ch
                      , offset         = length $ W.focus ch
                      , complIndex     = (0,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
""      = () -> XP ()
forall a. a -> StateT XPState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
toHeadChar Direction1D
d (Char
c : String
_) = do
    String
cmd <- (XPState -> String) -> XP String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> String
command
    Int
off <- (XPState -> Int) -> XP Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Int
offset
    let off' :: Int
off' = (if Direction1D
d Direction1D -> Direction1D -> Bool
forall a. Eq a => a -> a -> Bool
== Direction1D
Prev then Int -> Int
forall a. Num a => a -> a
negate (Int -> Int) -> ((Int, Int) -> Int) -> (Int, Int) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> a
fst else (Int, Int) -> Int
forall a b. (a, b) -> b
snd)
             ((Int, Int) -> Int)
-> ((String, String) -> (Int, Int)) -> (String, String) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String -> Int)
 -> (String -> Int) -> (String, String) -> (Int, Int))
-> (String -> Int) -> (String, String) -> (Int, Int)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (String -> Int)
-> (String -> Int) -> (String, String) -> (Int, Int)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
(***) (Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Maybe Int -> Int) -> (String -> Maybe Int) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Char
c)
             ((String, String) -> (Int, Int))
-> ((String, String) -> (String, String))
-> (String, String)
-> (Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String
forall {a}. [a] -> [a]
reverse (String -> String)
-> (String -> String) -> (String, String) -> (String, String)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1)
             ((String, String) -> Int) -> (String, String) -> Int
forall a b. (a -> b) -> a -> b
$ Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
off String
cmd
    (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
st -> XPState
st { offset = offset st + off' }

updateHighlightedCompl :: XP ()
updateHighlightedCompl :: XP ()
updateHighlightedCompl = do
  XPState
st <- StateT XPState IO XPState
forall s (m :: * -> *). MonadState s m => m s
get
  [String]
cs <- StateT XPState IO [String]
getCompletions
  Bool
alwaysHighlight' <- (XPState -> Bool) -> StateT XPState IO Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XPState -> Bool) -> StateT XPState IO Bool)
-> (XPState -> Bool) -> StateT XPState IO Bool
forall a b. (a -> b) -> a -> b
$ XPConfig -> Bool
alwaysHighlight (XPConfig -> Bool) -> (XPState -> XPConfig) -> XPState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPConfig
config
  Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
alwaysHighlight' (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$ (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s {highlightedCompl = highlightedItem st 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
(ComplWindowDim -> ComplWindowDim -> Bool)
-> (ComplWindowDim -> ComplWindowDim -> Bool) -> Eq ComplWindowDim
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ComplWindowDim -> ComplWindowDim -> Bool
== :: ComplWindowDim -> ComplWindowDim -> Bool
$c/= :: ComplWindowDim -> ComplWindowDim -> Bool
/= :: 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 :: XPConfig -> XPPosition
position :: XPPosition
position, Dimension
height :: XPConfig -> Dimension
height :: 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 Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
x) (Rectangle -> Position
rect_y Rectangle
scn Position -> Position -> Position
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
  EventMask -> IO EventMask
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return EventMask
w
 where
  (Position
x, Position
y) :: (Position, Position) = Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi (Dimension -> Position)
-> (Position, Dimension) -> (Position, Position)
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 Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
height)
    CenteredAt Rational
py Rational
w ->
      ( Rational -> Position
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> Position) -> Rational -> Position
forall a b. (a -> b) -> a -> b
$ Dimension -> Rational
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
scn) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* ((Rational
1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
w) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
2)
      , Rational -> Dimension
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> Dimension) -> Rational -> Dimension
forall a b. (a -> b) -> a -> b
$ Rational
py Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Dimension -> Rational
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_height Rectangle
scn) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- (Dimension -> Rational
forall a b. (Integral a, Num b) => a -> b
fi Dimension
height Rational -> Rational -> Rational
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 <- (XPState -> IORef (Maybe EventMask))
-> StateT XPState IO (IORef (Maybe EventMask))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> IORef (Maybe EventMask)
complWin
  IO () -> XP ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> XP ()) -> IO () -> XP ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe EventMask) -> Maybe EventMask -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe EventMask)
cwr Maybe EventMask
win
  (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\XPState
s -> XPState
s { complWinDim = winDim })

--- | Update all prompt windows.
updateWindows :: XP ()
updateWindows :: XP ()
updateWindows = XP () -> [String] -> XP ()
redrawWindows (XP () -> XP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void XP ()
destroyComplWin) ([String] -> XP ()) -> StateT XPState IO [String] -> XP ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT XPState IO [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 <- (XPState -> Display) -> StateT XPState IO Display
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Display
dpy
  XP ()
drawWin
  XP ()
-> (NonEmpty String -> XP ()) -> Maybe (NonEmpty String) -> XP ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe XP ()
emptyAction NonEmpty String -> XP ()
redrawComplWin ([String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [String]
compls)
  IO () -> XP ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> XP ()) -> IO () -> XP ()
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 :: XPState -> XPColor
color :: XPColor
color, Display
dpy :: XPState -> Display
dpy :: Display
dpy, EventMask
win :: XPState -> EventMask
win :: EventMask
win, GC
gcon :: XPState -> GC
gcon :: GC
gcon, Dimension
winWidth :: XPState -> Dimension
winWidth :: Dimension
winWidth } <- StateT XPState IO XPState
forall s (m :: * -> *). MonadState s m => m s
get
    XPC{ Dimension
height :: XPConfig -> Dimension
height :: Dimension
height, Dimension
promptBorderWidth :: XPConfig -> Dimension
promptBorderWidth :: Dimension
promptBorderWidth } <- (XPState -> XPConfig) -> StateT XPState IO XPConfig
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 <- IO (Maybe EventMask) -> StateT XPState IO (Maybe EventMask)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe EventMask) -> StateT XPState IO (Maybe EventMask))
-> IO (Maybe EventMask) -> StateT XPState IO (Maybe EventMask)
forall a b. (a -> b) -> a -> b
$ Display -> String -> IO (Maybe EventMask)
initColor Display
dpy (XPColor -> String
bgNormal XPColor
color)
    Just EventMask
borderC <- IO (Maybe EventMask) -> StateT XPState IO (Maybe EventMask)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe EventMask) -> StateT XPState IO (Maybe EventMask))
-> IO (Maybe EventMask) -> StateT XPState IO (Maybe EventMask)
forall a b. (a -> b) -> a -> b
$ Display -> String -> IO (Maybe EventMask)
initColor Display
dpy (XPColor -> String
border XPColor
color)
    EventMask
pm <- IO EventMask -> StateT XPState IO EventMask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO EventMask -> StateT XPState IO EventMask)
-> IO EventMask -> StateT XPState IO EventMask
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)
    IO () -> XP ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> XP ()) -> IO () -> XP ()
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 (Dimension -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Dimension
bw) Dimension
winWidth Dimension
ht
    EventMask -> XP ()
printPrompt EventMask
pm
    IO () -> XP ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> XP ()) -> IO () -> XP ()
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
    IO () -> XP ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> XP ()) -> IO () -> XP ()
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 :: XPState -> Bool
showComplWin :: Bool
showComplWin, Maybe ComplWindowDim
complWinDim :: XPState -> Maybe ComplWindowDim
complWinDim :: Maybe ComplWindowDim
complWinDim, IORef (Maybe EventMask)
complWin :: XPState -> IORef (Maybe EventMask)
complWin :: IORef (Maybe EventMask)
complWin } <- StateT XPState IO XPState
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 IO (Maybe EventMask) -> StateT XPState IO (Maybe EventMask)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IORef (Maybe EventMask) -> IO (Maybe EventMask)
forall a. IORef a -> IO a
readIORef IORef (Maybe EventMask)
complWin) StateT XPState IO (Maybe EventMask)
-> (Maybe EventMask -> XP ()) -> XP ()
forall a b.
StateT XPState IO a
-> (a -> StateT XPState IO b) -> StateT XPState IO b
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 ComplWindowDim -> ComplWindowDim -> Bool
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 :: ComplWindowDim -> Position
cwX :: Position
cwX, Position
cwY :: ComplWindowDim -> Position
cwY :: Position
cwY, Dimension
cwWidth :: ComplWindowDim -> Dimension
cwWidth :: Dimension
cwWidth, Dimension
cwRowHeight :: ComplWindowDim -> Dimension
cwRowHeight :: Dimension
cwRowHeight } = do
    XPS{ Display
dpy :: XPState -> Display
dpy :: Display
dpy, EventMask
rootw :: XPState -> EventMask
rootw :: EventMask
rootw } <- StateT XPState IO XPState
forall s (m :: * -> *). MonadState s m => m s
get
    let scr :: Screen
scr = Display -> Screen
defaultScreenOfDisplay Display
dpy
    EventMask
w <- IO EventMask -> StateT XPState IO EventMask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO EventMask -> StateT XPState IO EventMask)
-> IO EventMask -> StateT XPState IO EventMask
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
    IO () -> XP ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> XP ()) -> IO () -> XP ()
forall a b. (a -> b) -> a -> b
$ Display -> EventMask -> IO ()
mapWindow Display
dpy EventMask
w
    Maybe EventMask -> Maybe ComplWindowDim -> XP ()
updateComplWin (EventMask -> Maybe EventMask
forall a. a -> Maybe a
Just EventMask
w) (ComplWindowDim -> Maybe ComplWindowDim
forall a. a -> Maybe a
Just ComplWindowDim
wi)
    EventMask -> StateT XPState IO EventMask
forall a. a -> StateT XPState IO a
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 :: XPState -> String -> String
prompter :: String -> String
prompter, XPColor
color :: XPState -> XPColor
color :: XPColor
color, GC
gcon :: XPState -> GC
gcon :: GC
gcon, XPConfig
config :: XPState -> XPConfig
config :: XPConfig
config, Display
dpy :: XPState -> Display
dpy :: Display
dpy, XMonadFont
fontS :: XPState -> XMonadFont
fontS :: XMonadFont
fontS, Int
offset :: XPState -> Int
offset :: Int
offset } <- StateT XPState IO XPState
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 (String -> String) -> (XPState -> String) -> XPState -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPType -> String
forall a. Show a => a -> String
show (XPType -> String) -> (XPState -> XPType) -> XPState -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPType
currentXPMode (XPState -> String)
-> (XPState -> String) -> XPState -> (String, String)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
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 String -> String -> String
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= String -> Int
forall a. [a] -> Int
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) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
offset String
com
                      in (String
prt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a, Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1 String
b, Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 String
b)

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

  Int
pcFont <- IO Int -> XP Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Int -> XP Int) -> IO Int -> XP Int
forall a b. (a -> b) -> a -> b
$ Display -> XMonadFont -> String -> IO Int
forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF Display
dpy XMonadFont
fontS String
preCursor
  Int
cFont  <- IO Int -> XP Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Int -> XP Int) -> IO Int -> XP Int
forall a b. (a -> b) -> a -> b
$ Display -> XMonadFont -> String -> IO Int
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 = Display
-> EventMask
-> XMonadFont
-> GC
-> String
-> String
-> Position
-> Position
-> String
-> XP ()
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 Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Int -> Position
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 Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Int -> Position
forall a b. (Integral a, Num b) => a -> b
fi (Int
pcFont Int -> Int -> Int
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 :: StateT XPState IO [String]
getCompletions = do
  st :: XPState
st@XPS{ XPConfig
config :: XPState -> XPConfig
config :: XPConfig
config } <- StateT XPState IO XPState
forall s (m :: * -> *). MonadState s m => m s
get
  let cmd :: String
cmd   = XPType -> String -> String
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
  IO [String] -> StateT XPState IO [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [String] -> StateT XPState IO [String])
-> IO [String] -> StateT XPState IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> [String] -> [String]
srt String
cmd ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ComplFunction
compl String
cmd) IO [String] -> (SomeException -> IO [String]) -> IO [String]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(SomeException e
_) -> [String] -> IO [String]
forall a. a -> IO a
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 -> XPType -> ComplFunction
forall t. XPrompt t => t -> ComplFunction
completionFunction (XPType -> ComplFunction) -> XPType -> ComplFunction
forall a b. (a -> b) -> a -> b
$ Stack XPType -> XPType
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 :: XPState -> Display
dpy :: Display
dpy, IORef (Maybe EventMask)
complWin :: XPState -> IORef (Maybe EventMask)
complWin :: IORef (Maybe EventMask)
complWin } <- StateT XPState IO XPState
forall s (m :: * -> *). MonadState s m => m s
get
  IO (Maybe EventMask) -> StateT XPState IO (Maybe EventMask)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IORef (Maybe EventMask) -> IO (Maybe EventMask)
forall a. IORef a -> IO a
readIORef IORef (Maybe EventMask)
complWin) StateT XPState IO (Maybe EventMask)
-> (Maybe EventMask -> XP ()) -> XP ()
forall a b.
StateT XPState IO a
-> (a -> StateT XPState IO b) -> StateT XPState IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just EventMask
w -> do IO () -> XP ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> XP ()) -> IO () -> XP ()
forall a b. (a -> b) -> a -> b
$ Display -> EventMask -> IO ()
destroyWindow Display
dpy EventMask
w
                 Maybe EventMask -> Maybe ComplWindowDim -> XP ()
updateComplWin Maybe EventMask
forall a. Maybe a
Nothing Maybe ComplWindowDim
forall a. Maybe a
Nothing
    Maybe EventMask
Nothing -> () -> XP ()
forall a. a -> StateT XPState IO a
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 :: XPState -> Display
dpy :: Display
dpy, Dimension
winWidth :: XPState -> Dimension
winWidth :: Dimension
winWidth } <- StateT XPState IO XPState
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 <- (String -> XP Int)
-> NonEmpty String -> StateT XPState IO (NonEmpty Int)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (Display -> XMonadFont -> String -> XP Int
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 = (Dimension -> Int
forall a b. (Integral a, Num b) => a -> b
fi Dimension
ht Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ NonEmpty Int -> Int
forall a. Ord a => NonEmpty 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 Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
ht

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

      (Int
fullRows, Int
lastRow) = NonEmpty String -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NonEmpty String
compl Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Dimension -> Int
forall a b. (Integral a, Num b) => a -> b
fi Dimension
columns
      allRows :: Int
allRows   = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
fullRows Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if Int
lastRow Int -> Int -> Bool
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   = (Dimension -> Dimension)
-> (Dimension -> Dimension -> Dimension)
-> Maybe Dimension
-> Dimension
-> Dimension
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Dimension -> Dimension
forall a. a -> a
id Dimension -> Dimension -> Dimension
forall a. Ord a => a -> a -> a
min (XPConfig -> Maybe Dimension
maxComplRows XPConfig
cfg) (Dimension
remHeight Dimension -> Dimension -> Dimension
forall a. Integral a => a -> a -> a
`div` Dimension
ht)
      -- Actual number of rows to be drawn
      rows :: Dimension
rows      = Dimension -> Dimension -> Dimension
forall a. Ord a => a -> a -> a
min Dimension
maxRows (Int -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Int
allRows)
      rowHeight :: Dimension
rowHeight = Dimension
rows Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
* Dimension
ht

      -- Starting x and y position of the completion windows.
      (Position
x, Position
y) = (Position -> Position)
-> (Dimension -> Position)
-> (Position, Dimension)
-> (Position, Position)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
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 Position -> Position -> Position
forall a. Num a => a -> a -> a
+) ((Rectangle -> Position
rect_y Rectangle
scr Position -> Position -> Position
forall a. Num a => a -> a -> a
+) (Position -> Position)
-> (Dimension -> Position) -> Dimension -> Position
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi) ((Position, Dimension) -> (Position, Position))
-> (Position, Dimension) -> (Position, Position)
forall a b. (a -> b) -> a -> b
$ case XPConfig -> XPPosition
position XPConfig
cfg of
        XPPosition
Top    -> (Position
0, Dimension
ht Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
bw)
        XPPosition
Bottom -> (Position
0, Dimension
remHeight Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
rowHeight Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+ Dimension
bw)
        CenteredAt Rational
py Rational
w
          | Rational
py Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational
1Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/Rational
2 ->
              ( Rational -> Position
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> Position) -> Rational -> Position
forall a b. (a -> b) -> a -> b
$ Dimension -> Rational
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
scr) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* ((Rational
1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
w) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
2)
              , Rational -> Dimension
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational
py Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Dimension -> Rational
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_height Rectangle
scr) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ (Dimension -> Rational
forall a b. (Integral a, Num b) => a -> b
fi Dimension
ht Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
2)) Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
bw
              )
          | Bool
otherwise ->
              ( Rational -> Position
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> Position) -> Rational -> Position
forall a b. (a -> b) -> a -> b
$ Dimension -> Rational
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_width Rectangle
scr) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* ((Rational
1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
w) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
2)
              , Rational -> Dimension
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational
py Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Dimension -> Rational
forall a b. (Integral a, Num b) => a -> b
fi (Rectangle -> Dimension
rect_height Rectangle
scr) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- (Dimension -> Rational
forall a b. (Integral a, Num b) => a -> b
fi Dimension
ht Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Rational
2)) Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
rowHeight Dimension -> Dimension -> Dimension
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) <- IO (Position, Position) -> StateT XPState IO (Position, Position)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Position, Position) -> StateT XPState IO (Position, Position))
-> IO (Position, Position)
-> StateT XPState IO (Position, Position)
forall a b. (a -> b) -> a -> b
$ XMonadFont -> String -> IO (Position, Position)
forall (m :: * -> *).
MonadIO m =>
XMonadFont -> String -> m (Position, Position)
textExtentsXMF XMonadFont
fs (String -> IO (Position, Position))
-> String -> IO (Position, Position)
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> String
forall a. NonEmpty a -> a
NE.head NonEmpty String
compl
  let yp :: Position
yp    = Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi (Dimension -> Position) -> Dimension -> Position
forall a b. (a -> b) -> a -> b
$ (Dimension
ht Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+ Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (Position
asc Position -> Position -> Position
forall a. Num a => a -> a -> a
- Position
desc)) Dimension -> Dimension -> Dimension
forall a. Integral a => a -> a -> a
`div` Dimension
2 -- y position of the first row
      yRows :: [Position]
yRows = Int -> [Position] -> [Position]
forall a. Int -> [a] -> [a]
take (Dimension -> Int
forall a b. (Integral a, Num b) => a -> b
fi Dimension
rows) [Position
yp, Position
yp Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
ht ..]  -- y positions of all rows

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

  ComplWindowDim -> XP ComplWindowDim
forall a. a -> StateT XPState IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComplWindowDim -> XP ComplWindowDim)
-> ComplWindowDim -> XP ComplWindowDim
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 :: XPState -> XPConfig
config :: XPConfig
config, XPColor
color :: XPState -> XPColor
color :: XPColor
color, Display
dpy :: XPState -> Display
dpy :: Display
dpy, GC
gcon :: XPState -> GC
gcon :: GC
gcon } <- StateT XPState IO XPState
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 <- IO (Maybe EventMask) -> StateT XPState IO (Maybe EventMask)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe EventMask) -> StateT XPState IO (Maybe EventMask))
-> IO (Maybe EventMask) -> StateT XPState IO (Maybe EventMask)
forall a b. (a -> b) -> a -> b
$ Display -> String -> IO (Maybe EventMask)
initColor Display
dpy (XPColor -> String
bgNormal XPColor
color)
  Just EventMask
borderC <- IO (Maybe EventMask) -> StateT XPState IO (Maybe EventMask)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe EventMask) -> StateT XPState IO (Maybe EventMask))
-> IO (Maybe EventMask) -> StateT XPState IO (Maybe EventMask)
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 :: ComplWindowDim -> Dimension
cwWidth :: Dimension
cwWidth, Dimension
cwRowHeight :: ComplWindowDim -> Dimension
cwRowHeight :: Dimension
cwRowHeight } <- NonEmpty String -> XP ComplWindowDim
getComplWinDim NonEmpty String
entries

  EventMask
p <- IO EventMask -> StateT XPState IO EventMask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO EventMask -> StateT XPState IO EventMask)
-> IO EventMask -> StateT XPState IO EventMask
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)
  IO () -> XP ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> XP ()) -> IO () -> XP ()
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 (Dimension -> Dimension
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)
  IO () -> XP ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> XP ()) -> IO () -> XP ()
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
  IO () -> XP ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> XP ()) -> IO () -> XP ()
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 :: ComplWindowDim -> [Position]
cwCols :: [Position]
cwCols, [Position]
cwRows :: ComplWindowDim -> [Position]
cwRows :: [Position]
cwRows } = do
  st :: XPState
st@XPS{ XPColor
color :: XPState -> XPColor
color :: XPColor
color, (Int, Int)
complIndex :: XPState -> (Int, Int)
complIndex :: (Int, Int)
complIndex, config :: XPState -> XPConfig
config = XPC{ Bool
alwaysHighlight :: XPConfig -> Bool
alwaysHighlight :: Bool
alwaysHighlight } } <- StateT XPState IO XPState
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 =
        Display
-> EventMask
-> XMonadFont
-> GC
-> String
-> String
-> Position
-> Position
-> String
-> XP ()
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 (Int, Int) -> (Int, Int) -> Bool
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
            XPType -> String -> String
forall t. XPrompt t => t -> String -> String
completionToCommand (XPState -> XPType
currentXPMode XPState
st) String
item String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== XPType -> String -> String
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)
  (Position -> [String] -> XP ())
-> [Position] -> [[String]] -> XP ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (\Position
x -> (Position -> String -> XP ()) -> [Position] -> [String] -> XP ()
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]]
    = Int -> [String] -> [[String]]
forall a. Int -> [a] -> [[a]]
chunksOf ([Position] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Position]
cwRows) (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take ([Position] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Position]
cwCols Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Position] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Position]
cwRows) (NonEmpty String -> [String]
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 = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ ([String] -> Bool) -> [[String]] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (\[String]
cols -> String
item String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
cols) [[String]]
complMat
    rowIndex :: Int
rowIndex = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex String
item ([String] -> Maybe Int) -> Maybe [String] -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [[String]]
complMat [[String]] -> Int -> Maybe [String]
forall a. [a] -> Int -> Maybe a
!? Int
colIndex

-- History

type History = M.Map String [String]

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

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

readHistory :: FilePath -> IO History
readHistory :: String -> IO (Map String [String])
readHistory String
cachedir = IO (Map String [String])
readHist IO (Map String [String])
-> (SomeException -> IO (Map String [String]))
-> IO (Map String [String])
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(SomeException e
_) -> Map String [String] -> IO (Map String [String])
forall a. a -> IO a
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 <- String -> IOMode -> (Handle -> IO String) -> IO String
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
ReadMode Handle -> IO String
hGetLine
        String -> IO (Map String [String])
forall a. Read a => String -> IO a
readIO String
xs

writeHistory :: FilePath -> History -> IO ()
writeHistory :: String -> Map String [String] -> IO ()
writeHistory String
cachedir Map String [String]
hist = do
  let path :: String
path = String -> String
getHistoryFile String
cachedir
      filtered :: Map String [String]
filtered = ([String] -> Bool) -> Map String [String] -> Map String [String]
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Bool -> Bool
not (Bool -> Bool) -> ([String] -> Bool) -> [String] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) Map String [String]
hist
  String -> String -> IO ()
writeFile String
path (Map String [String] -> String
forall a. Show a => a -> String
show Map String [String]
filtered) IO () -> (SomeException -> IO ()) -> IO ()
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: "String -> String -> String
forall a. [a] -> [a] -> [a]
++e -> String
forall a. Show a => a -> String
show e
e)
  String -> FileMode -> IO ()
setFileMode String
path FileMode
mode
    where mode :: FileMode
mode = FileMode
ownerReadMode FileMode -> FileMode -> FileMode
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 (Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
bw) (Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
bw) (Dimension
wh Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- (Dimension
bw Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
* Dimension
2)) (Dimension
ht Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- (Dimension
bw Dimension -> Dimension -> Dimension
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
  (Ptr SetWindowAttributes -> IO EventMask) -> IO EventMask
forall a. (Ptr SetWindowAttributes -> IO a) -> IO a
allocaSetWindowAttributes ((Ptr SetWindowAttributes -> IO EventMask) -> IO EventMask)
-> (Ptr SetWindowAttributes -> IO EventMask) -> IO EventMask
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]
_ [] = [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
mkComplFunFromList XPConfig
c [String]
l String
s =
  [String] -> IO [String]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
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 [] = [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
l
mkComplFunFromList' XPConfig
c [String]
l String
s =
  [String] -> IO [String]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ t -> String -> String
forall t. XPrompt t => t -> String -> String
completionToCommand t
t ([String]
l [String] -> Int -> String
forall a. HasCallStack => [a] -> Int -> a
!! Int
ni)
    where ni :: Int
ni = case t -> String -> String
forall t. XPrompt t => t -> String -> String
commandToComplete t
t String
c String -> [String] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (t -> String -> String
forall t. XPrompt t => t -> String -> String
completionToCommand t
t) [String]
l of
                 Just Int
i -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 then Int
0 else Int
i Int -> Int -> Int
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 [String] -> Int -> String
forall a. HasCallStack => [a] -> Int -> a
!! Int
idx
    where idx :: Int
idx = case String
c String -> [String] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` [String]
l of
                  Just Int
i  -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 then Int
0 else Int
i Int -> Int -> Int
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 = Int -> [a] -> [[a]]
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 = String -> String
forall {a}. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst ((String, String) -> String)
-> (String -> (String, String)) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String, String)
breakAtSpace (String -> (String, String))
-> (String -> String) -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
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 = String -> String
forall {a}. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> b
snd ((String, String) -> String)
-> (String -> (String, String)) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (String, String)
breakAtSpace (String -> (String, String))
-> (String -> String) -> String -> (String, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall {a}. [a] -> [a]
reverse

breakAtSpace :: String -> (String, String)
breakAtSpace :: String -> (String, String)
breakAtSpace String
s
    | String
" \\" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s2 = (String
s1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s1', String
s2')
    | Bool
otherwise = (String
s1, String
s2)
      where (String
s1, String
s2 ) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace String
s
            (String
s1',String
s2') = String -> (String, String)
breakAtSpace (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
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 :: X ComplFunction
historyCompletion :: X ComplFunction
historyCompletion = (String -> Bool) -> X ComplFunction
historyCompletionP (Bool -> String -> Bool
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 :: (String -> Bool) -> X ComplFunction
historyCompletionP :: (String -> Bool) -> X ComplFunction
historyCompletionP String -> Bool
p = do
    String
cd <- (XConf -> String) -> X String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Directories' String -> String
forall a. Directories' a -> a
cacheDir (Directories' String -> String)
-> (XConf -> Directories' String) -> XConf -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XConf -> Directories' String
directories)
    ComplFunction -> X ComplFunction
forall a. a -> X a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ComplFunction -> X ComplFunction)
-> ComplFunction -> X ComplFunction
forall a b. (a -> b) -> a -> b
$ \String
x ->
        let toComplList :: Map k [String] -> [String]
toComplList = [String] -> [String]
deleteConsecutive ([String] -> [String])
-> (Map k [String] -> [String]) -> Map k [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf String
x) ([String] -> [String])
-> (Map k [String] -> [String]) -> Map k [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> [String] -> [String])
-> [String] -> Map k [String] -> [String]
forall a b k. (a -> b -> b) -> b -> Map k a -> b
M.foldr [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
(++) []
         in Map String [String] -> [String]
forall {k}. Map k [String] -> [String]
toComplList (Map String [String] -> [String])
-> (Map String [String] -> Map String [String])
-> Map String [String]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> Bool)
-> Map String [String] -> Map String [String]
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (Bool -> [String] -> Bool
forall a b. a -> b -> a
const (Bool -> [String] -> Bool)
-> (String -> Bool) -> String -> [String] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
p) (Map String [String] -> [String])
-> IO (Map String [String]) -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Map String [String])
readHistory 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 = Set a -> [a]
forall a. Set a -> [a]
toList (Set a -> [a]) -> ([a] -> Set a) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Set a
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 = [String] -> [String]
forall a. Eq a => [a] -> [a]
nub
deleteConsecutive :: [String] -> [String]
deleteConsecutive = ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (NonEmpty String -> String
forall a. NonEmpty a -> a
NE.head (NonEmpty String -> String)
-> ([String] -> NonEmpty String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> NonEmpty String
forall a. HasCallStack => [a] -> NonEmpty a
notEmpty) ([[String]] -> [String])
-> ([String] -> [[String]]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [[String]]
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 (IORef ([String], Maybe (Stack String)) -> HistoryMatches)
-> m (IORef ([String], Maybe (Stack String))) -> m HistoryMatches
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (IORef ([String], Maybe (Stack String)))
-> m (IORef ([String], Maybe (Stack String)))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (([String], Maybe (Stack String))
-> IO (IORef ([String], Maybe (Stack String)))
forall a. a -> IO (IORef a)
newIORef ([],Maybe (Stack String)
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) <- IO ([String], Maybe (Stack String))
-> StateT XPState IO ([String], Maybe (Stack String))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO ([String], Maybe (Stack String))
 -> StateT XPState IO ([String], Maybe (Stack String)))
-> IO ([String], Maybe (Stack String))
-> StateT XPState IO ([String], Maybe (Stack String))
forall a b. (a -> b) -> a -> b
$ IORef ([String], Maybe (Stack String))
-> IO ([String], Maybe (Stack String))
forall a. IORef a -> IO a
readIORef IORef ([String], Maybe (Stack String))
ref
  String
input <- XP String
getInput
  if String
input String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 = Stack String -> String
forall a. Stack a -> a
W.focus Stack String
cs
                (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ String -> XPState -> XPState
setCommand String
cmd
                (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((XPState -> XPState) -> XP ()) -> (XPState -> XPState) -> XP ()
forall a b. (a -> b) -> a -> b
$ \XPState
s -> XPState
s { offset = length cmd }
                IO () -> XP ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> XP ()) -> IO () -> XP ()
forall a b. (a -> b) -> a -> b
$ IORef ([String], Maybe (Stack String))
-> ([String], Maybe (Stack String)) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ([String], Maybe (Stack String))
ref (String
cmdString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
completed,Stack String -> Maybe (Stack String)
forall a. a -> Maybe a
Just (Stack String -> Maybe (Stack String))
-> Stack String -> Maybe (Stack String)
forall a b. (a -> b) -> a -> b
$ Stack String -> Stack String
next Stack String
cs)
            Maybe (Stack String)
Nothing -> () -> XP ()
forall a. a -> StateT XPState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     else do -- the user typed something new, recompute completions
       IO () -> XP ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> XP ())
-> (Stack String -> IO ()) -> Stack String -> XP ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef ([String], Maybe (Stack String))
-> ([String], Maybe (Stack String)) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ([String], Maybe (Stack String))
ref (([String], Maybe (Stack String)) -> IO ())
-> (Stack String -> ([String], Maybe (Stack String)))
-> Stack String
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String
input] ,) (Maybe (Stack String) -> ([String], Maybe (Stack String)))
-> (Stack String -> Maybe (Stack String))
-> Stack String
-> ([String], Maybe (Stack String))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Stack String -> Maybe (Stack String)
filterMatching String
input (Stack String -> XP ())
-> StateT XPState IO (Stack String) -> XP ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (XPState -> Stack String) -> StateT XPState IO (Stack String)
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 = (String -> Bool) -> Stack String -> Maybe (Stack String)
forall a. (a -> Bool) -> Stack a -> Maybe (Stack a)
W.filter (String
prefix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) (Stack String -> Maybe (Stack String))
-> (Stack String -> Stack String)
-> Stack String
-> Maybe (Stack String)
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 Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusDown'
historyDownMatching :: HistoryMatches -> XP ()
historyDownMatching HistoryMatches
hm = HistoryMatches -> (Stack String -> Stack String) -> XP ()
historyNextMatching HistoryMatches
hm Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusUp'