{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ExistentialQuantification #-}
-----------------------------------------------------------------------------
-- |
-- 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
    , defaultXPConfig
    , 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
    , moveWord, moveWord', killWord, killWord'
    , changeWord, deleteString
    , moveHistory, setSuccess, setDone, setModeDone
    , Direction1D(..)
    , ComplFunction
    -- * X Utilities
    -- $xutils
    , mkUnmanagedWindow
    , fillDrawable
    -- * Other Utilities
    -- $utils
    , mkComplFunFromList
    , mkComplFunFromList'
    -- * @nextCompletion@ implementations
    , getNextOfLastWord
    , getNextCompletion
    -- * List utilities
    , getLastWord
    , skipLastWord
    , splitInSubListsAt
    , breakAtSpace
    , uniqSort
    , historyCompletion
    , historyCompletionP
    -- * History filters
    , deleteAllDuplicates
    , deleteConsecutive
    , HistoryMatches
    , initMatches
    , historyUpMatching
    , historyDownMatching
    -- * Types
    , XPState
    ) where

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

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

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

type XP = StateT XPState IO

data XPState =
    XPS { XPState -> Display
dpy                   :: Display
        , XPState -> Window
rootw                 :: !Window
        , XPState -> Window
win                   :: !Window
        , XPState -> Rectangle
screen                :: !Rectangle
        , XPState -> Maybe Window
complWin              :: Maybe Window
        , XPState -> Maybe ComplWindowDim
complWinDim           :: Maybe ComplWindowDim
        , XPState -> (Int, Int)
complIndex            :: !(Int,Int)
        -- | This IORef should always have the same value as
        -- complWin. Its purpose is to enable removal of the
        -- completion window if an exception occurs, since the most
        -- recent value of complWin is not available when handling
        -- exceptions.
        , XPState -> IORef (Maybe Window)
complWinRef           :: IORef (Maybe Window)
        , 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
numlockMask           :: KeyMask
        , XPState -> Bool
done                  :: Bool
        , XPState -> Bool
modeDone              :: Bool
        , XPState -> XPColor
color                 :: XPColor
        , XPState -> String -> String
prompter              :: String -> String
        , XPState -> [(Window, 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. This implies having *one* column of autocompletions only.
        , XPConfig -> Dimension
height                :: !Dimension   -- ^ Window height
        , XPConfig -> Maybe Dimension
maxComplRows          :: Maybe Dimension
                                                -- ^ Just x: maximum number of rows 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, Window) (XP ())
promptKeymap          :: M.Map (KeyMask,KeySym) (XP ())
                                                -- ^ Mapping from key combinations to actions
        , XPConfig -> (KeyMask, Window)
completionKey         :: (KeyMask, KeySym)     -- ^ Key that should trigger completion
        , XPConfig -> Window
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 -> 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)

instance Show XPType where
    show :: XPType -> String
show (XPT p :: 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 t :: p
t) = p -> String -> [String] -> String
forall t. XPrompt t => t -> String -> [String] -> String
nextCompletion      p
t
    commandToComplete :: XPType -> String -> String
commandToComplete   (XPT t :: p
t) = p -> String -> String
forall t. XPrompt t => t -> String -> String
commandToComplete   p
t
    completionToCommand :: XPType -> String -> String
completionToCommand (XPT t :: p
t) = p -> String -> String
forall t. XPrompt t => t -> String -> String
completionToCommand p
t
    completionFunction :: XPType -> ComplFunction
completionFunction  (XPT t :: p
t) = p -> ComplFunction
forall t. XPrompt t => t -> ComplFunction
completionFunction  p
t
    modeAction :: XPType -> String -> String -> X ()
modeAction          (XPT t :: p
t) = p -> String -> String -> X ()
forall t. XPrompt t => t -> String -> String -> X ()
modeAction          p
t

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

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

    -- | This method is used to generate the next completion to be
    -- printed in the command line when tab is pressed, given the
    -- string presently in the command line and the list of
    -- completion.
    -- This function is not used when in multiple modes (because alwaysHighlight in XPConfig is True)
    nextCompletion :: t -> String -> [String] -> String
    nextCompletion = 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 _ = 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 _ c :: 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
t = \_ -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ["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]
++ " 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 _ _ _ = () -> X ()
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 relatave 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
showList :: [XPPosition] -> String -> String
$cshowList :: [XPPosition] -> String -> String
show :: XPPosition -> String
$cshow :: XPPosition -> String
showsPrec :: Int -> XPPosition -> String -> String
$cshowsPrec :: Int -> XPPosition -> String -> String
Show,ReadPrec [XPPosition]
ReadPrec XPPosition
Int -> ReadS XPPosition
ReadS [XPPosition]
(Int -> ReadS XPPosition)
-> ReadS [XPPosition]
-> ReadPrec XPPosition
-> ReadPrec [XPPosition]
-> Read XPPosition
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [XPPosition]
$creadListPrec :: ReadPrec [XPPosition]
readPrec :: ReadPrec XPPosition
$creadPrec :: ReadPrec XPPosition
readList :: ReadS [XPPosition]
$creadList :: ReadS [XPPosition]
readsPrec :: Int -> ReadS XPPosition
$creadsPrec :: Int -> ReadS XPPosition
Read)

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

amberXPConfig, defaultXPConfig, greenXPConfig :: XPConfig

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

instance Default XPConfig where
  def :: XPConfig
def =
    $WXPC :: String
-> String
-> String
-> String
-> String
-> String
-> Dimension
-> XPPosition
-> Bool
-> Dimension
-> Maybe Dimension
-> Int
-> ([String] -> [String])
-> Map (KeyMask, Window) (XP ())
-> (KeyMask, Window)
-> Window
-> String
-> Maybe Int
-> Bool
-> (String -> String -> Bool)
-> (String -> String)
-> (String -> [String] -> [String])
-> XPConfig
XPC { font :: String
font                  = "-misc-fixed-*-*-*-*-12-*-*-*-*-*-*-*"
        , 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     = 1
        , promptKeymap :: Map (KeyMask, Window) (XP ())
promptKeymap          = Map (KeyMask, Window) (XP ())
defaultXPKeymap
        , completionKey :: (KeyMask, Window)
completionKey         = (0,Window
xK_Tab)
        , changeModeKey :: Window
changeModeKey         = Window
xK_grave
        , position :: XPPosition
position              = XPPosition
Bottom
        , height :: Dimension
height                = 18
        , maxComplRows :: Maybe Dimension
maxComplRows          = Maybe Dimension
forall a. Maybe a
Nothing
        , historySize :: Int
historySize           = 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
        , 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
        }
{-# DEPRECATED defaultXPConfig "Use def (from Data.Default, and re-exported from XMonad.Prompt) instead." #-}
defaultXPConfig :: XPConfig
defaultXPConfig = XPConfig
forall a. Default a => a
def
greenXPConfig :: XPConfig
greenXPConfig = XPConfig
forall a. Default a => a
def { bgColor :: String
bgColor           = "black"
                    , fgColor :: String
fgColor           = "green"
                    , promptBorderWidth :: Dimension
promptBorderWidth = 0
                    }
amberXPConfig :: XPConfig
amberXPConfig = XPConfig
forall a. Default a => a
def { bgColor :: String
bgColor   = "black"
                    , fgColor :: String
fgColor   = "#ca8f2d"
                    , fgHLight :: String
fgHLight  = "#eaaf4c"
                    }

initState :: Display -> Window -> Window -> Rectangle -> XPOperationMode
          -> GC -> XMonadFont -> [String] -> XPConfig -> KeyMask -> XPState
initState :: Display
-> Window
-> Window
-> Rectangle
-> XPOperationMode
-> GC
-> XMonadFont
-> [String]
-> XPConfig
-> KeyMask
-> XPState
initState d :: Display
d rw :: Window
rw w :: Window
w s :: Rectangle
s opMode :: XPOperationMode
opMode gc :: GC
gc fonts :: XMonadFont
fonts h :: [String]
h c :: XPConfig
c nm :: KeyMask
nm =
    $WXPS :: Display
-> Window
-> Window
-> Rectangle
-> Maybe Window
-> Maybe ComplWindowDim
-> (Int, Int)
-> IORef (Maybe Window)
-> Bool
-> XPOperationMode
-> Maybe String
-> GC
-> XMonadFont
-> Stack String
-> Int
-> XPConfig
-> Bool
-> KeyMask
-> Bool
-> Bool
-> XPColor
-> (String -> String)
-> [(Window, String, Event)]
-> String
-> Maybe [String]
-> XPState
XPS { dpy :: Display
dpy                   = Display
d
        , rootw :: Window
rootw                 = Window
rw
        , win :: Window
win                   = Window
w
        , screen :: Rectangle
screen                = Rectangle
s
        , complWin :: Maybe Window
complWin              = Maybe Window
forall a. Maybe a
Nothing
        , complWinDim :: Maybe ComplWindowDim
complWinDim           = Maybe ComplWindowDim
forall a. Maybe a
Nothing
        , complWinRef :: IORef (Maybe Window)
complWinRef        = IO (IORef (Maybe Window)) -> IORef (Maybe Window)
forall a. IO a -> a
unsafePerformIO (Maybe Window -> IO (IORef (Maybe Window))
forall a. a -> IO (IORef a)
newIORef Maybe Window
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        = $WStack :: forall a. a -> [a] -> [a] -> Stack a
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            = (0,0) --(column index, row index), used when `alwaysHighlight` in XPConfig is True
        , offset :: Int
offset                = String -> 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
        , numlockMask :: KeyMask
numlockMask           = KeyMask
nm
        , prompter :: String -> String
prompter              = XPConfig -> String -> String
defaultPrompter XPConfig
c
        , color :: XPColor
color                 = XPConfig -> XPColor
defaultColor XPConfig
c
        , eventBuffer :: [(Window, String, Event)]
eventBuffer           = []
        , inputBuffer :: String
inputBuffer           = ""
        , currentCompletions :: Maybe [String]
currentCompletions    = Maybe [String]
forall a. Maybe a
Nothing
        }

-- Returns the current XPType
currentXPMode :: XPState -> XPType
currentXPMode :: XPState -> XPType
currentXPMode st :: XPState
st = case XPState -> XPOperationMode
operationMode XPState
st of
  XPMultipleModes modes :: Stack XPType
modes -> Stack XPType -> XPType
forall a. Stack a -> a
W.focus Stack XPType
modes
  XPSingleMode _ xptype :: 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 st :: XPState
st = case XPState -> XPOperationMode
operationMode XPState
st of
  XPMultipleModes modes :: 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
    (m :: XPType
m:ms :: [XPType]
ms) -> let
      currentMode :: XPType
currentMode = Stack XPType -> XPType
forall a. Stack a -> a
W.focus Stack XPType
modes
      in XPState
st { operationMode :: XPOperationMode
operationMode = Stack XPType -> XPOperationMode
XPMultipleModes $WStack :: forall a. a -> [a] -> [a] -> Stack a
W.Stack { up :: [XPType]
W.up = [], focus :: XPType
W.focus = XPType
m, down :: [XPType]
W.down = [XPType]
ms [XPType] -> [XPType] -> [XPType]
forall a. [a] -> [a] -> [a]
++ [XPType
currentMode]}} --set next and move previous current mode to the of the stack
  _ -> 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 st' :: XPState
st' completions :: [String]
completions = case XPState -> Maybe ComplWindowDim
complWinDim XPState
st' of
  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 winDim :: ComplWindowDim
winDim ->
    let
      (_,_,_,_,xx :: Columns
xx,yy :: Columns
yy) = ComplWindowDim
winDim
      complMatrix :: [[String]]
complMatrix = Int -> [String] -> [[String]]
forall a. Int -> [a] -> [[a]]
splitInSubListsAt (Columns -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Columns
yy) (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take (Columns -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Columns
xx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Columns -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Columns
yy) [String]
completions)
      (col_index :: Int
col_index,row_index :: Int
row_index) = (XPState -> (Int, Int)
complIndex XPState
st')
    in case [String]
completions of
      [] -> Maybe String
forall a. Maybe a
Nothing
      _ -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ [[String]]
complMatrix [[String]] -> Int -> [String]
forall a. [a] -> Int -> a
!! Int
col_index [String] -> Int -> String
forall a. [a] -> Int -> a
!! Int
row_index

-- 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 xs :: String
xs s :: XPState
s = XPState
s { commandHistory :: Stack String
commandHistory = (XPState -> Stack String
commandHistory XPState
s) { focus :: String
W.focus = String
xs }}

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

-- | 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. Intented 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 c :: XPConfig
c = XPColor :: String -> String -> String -> String -> String -> XPColor
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 c :: 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
$ \s :: XPState
s -> XPState
s { color :: XPColor
color = XPColor -> XPColor
c (XPColor -> XPColor) -> XPColor -> XPColor
forall a b. (a -> b) -> a -> b
$ XPState -> XPColor
color XPState
s }

-- | Set the prompt colors.
setColor :: XPColor -> XP ()
setColor :: XPColor -> XP ()
setColor = (XPColor -> XPColor) -> XP ()
modifyColor ((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 (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 bc :: String
bc xpc :: XPColor
xpc = XPColor
xpc { border :: String
border = String
bc }

-- | Modify the prompter, i.e. for chaining prompters.
modifyPrompter :: ((String -> String) -> (String -> String)) -> XP ()
modifyPrompter :: ((String -> String) -> String -> String) -> XP ()
modifyPrompter p :: (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
$ \s :: XPState
s -> XPState
s { prompter :: String -> String
prompter = (String -> String) -> String -> String
p ((String -> String) -> String -> String)
-> (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ XPState -> String -> String
prompter XPState
s }

-- | Set the prompter.
setPrompter :: (String -> String) -> XP ()
setPrompter :: (String -> String) -> XP ()
setPrompter = ((String -> String) -> String -> String) -> XP ()
modifyPrompter (((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 (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 cs :: 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
$ \s :: XPState
s -> XPState
s { currentCompletions :: Maybe [String]
currentCompletions = Maybe [String]
cs }

-- | Get the current completion list.
getCurrentCompletions :: XP (Maybe [String])
getCurrentCompletions :: XP (Maybe [String])
getCurrentCompletions = (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 :: p -> XPConfig -> ComplFunction -> (String -> X a) -> X (Maybe a)
mkXPromptWithReturn t :: p
t conf :: XPConfig
conf compl :: ComplFunction
compl action :: 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 do
      let selectedCompletion :: String
selectedCompletion =
            case XPConfig -> Bool
alwaysHighlight (XPState -> XPConfig
config XPState
st') of
              -- When alwaysHighlight is True, autocompletion is
              -- handled with indexes.
              False -> XPState -> String
command XPState
st'
              -- When it is false, it is handled depending on the
              -- prompt buffer's value.
              True -> 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'
      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 String
selectedCompletion
    else Maybe a -> X (Maybe 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 :: p -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
mkXPrompt t :: p
t conf :: XPConfig
conf compl :: ComplFunction
compl action :: String -> X ()
action = 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 X (Maybe ()) -> X () -> X ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Creates a prompt with multiple modes given:
--
-- * A non-empty list of modes
-- * A prompt configuration
--
-- The created prompt allows to switch between modes with `changeModeKey` in `conf`. The modes are
-- instances of XPrompt. See XMonad.Actions.Launcher for more details
--
-- The argument supplied to the action to execute is always the current highlighted item,
-- that means that this prompt overrides the value `alwaysHighlight` for its configuration to True.
mkXPromptWithModes :: [XPType] -> XPConfig -> X ()
mkXPromptWithModes :: [XPType] -> XPConfig -> X ()
mkXPromptWithModes modes :: [XPType]
modes conf :: XPConfig
conf = do
  let defaultMode :: XPType
defaultMode = [XPType] -> XPType
forall a. [a] -> a
head [XPType]
modes
      modeStack :: Stack XPType
modeStack = $WStack :: forall a. a -> [a] -> [a] -> Stack a
W.Stack { focus :: XPType
W.focus = XPType
defaultMode -- Current mode
                          , up :: [XPType]
W.up = []
                          , down :: [XPType]
W.down = [XPType] -> [XPType]
forall a. [a] -> [a]
tail [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 :: Bool
alwaysHighlight = Bool
True } XPOperationMode
om
  if XPState -> Bool
successful XPState
st'
    then do
      case XPState -> XPOperationMode
operationMode XPState
st' of
        XPMultipleModes ms :: 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 "" (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ XPState -> Maybe String
highlightedCompl XPState
st')
        _ -> String -> X ()
forall a. HasCallStack => String -> a
error "The impossible occurred: This prompt runs with multiple modes but they could not be found." --we are creating a prompt with multiple modes, so its operationMode should have been constructed with XPMultipleMode
    else () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Internal function used to implement 'mkXPromptWithReturn' and
-- 'mkXPromptWithModes'.
mkXPromptImplementation :: String -> XPConfig -> XPOperationMode -> X XPState
mkXPromptImplementation :: String -> XPConfig -> XPOperationMode -> X XPState
mkXPromptImplementation historyKey :: String
historyKey conf :: XPConfig
conf om :: XPOperationMode
om = do
  XConf { display :: XConf -> Display
display = Display
d, theRoot :: XConf -> Window
theRoot = Window
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 Window) Window ScreenId ScreenDetail
-> ScreenDetail
forall i l a sid sd. Screen i l a sid sd -> sd
W.screenDetail (Screen String (Layout Window) Window ScreenId ScreenDetail
 -> ScreenDetail)
-> (XState
    -> Screen String (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet String (Layout Window) Window ScreenId ScreenDetail
-> Screen String (Layout Window) Window 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 Window) Window ScreenId ScreenDetail
 -> Screen String (Layout Window) Window ScreenId ScreenDetail)
-> (XState
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Screen String (Layout Window) Window ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
windowset
  KeyMask
numlock <- (XState -> KeyMask) -> X KeyMask
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XState -> KeyMask
X.numberlockMask
  History
hist <- IO History -> X History
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io IO History
readHistory
  XMonadFont
fs <- String -> X XMonadFont
initXMF (XPConfig -> String
font 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 Window
-> (Window -> IO ()) -> (Window -> IO XPState) -> IO XPState
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
      (Display -> Window -> XPConfig -> Rectangle -> IO Window
createWin Display
d Window
rw XPConfig
conf Rectangle
s)
      (Display -> Window -> IO ()
destroyWindow Display
d)
      (\w :: Window
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 -> Window -> IO GC
createGC Display
d Window
w)
          (Display -> GC -> IO ()
freeGC Display
d)
          (\gc :: GC
gc -> do
            Display -> Window -> Window -> IO ()
selectInput Display
d Window
w (Window -> IO ()) -> Window -> IO ()
forall a b. (a -> b) -> a -> b
$ Window
exposureMask Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
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 -> History -> Maybe [String]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
historyKey History
hist
                st :: XPState
st = Display
-> Window
-> Window
-> Rectangle
-> XPOperationMode
-> GC
-> XMonadFont
-> [String]
-> XPConfig
-> KeyMask
-> XPState
initState Display
d Window
rw Window
w Rectangle
s XPOperationMode
om GC
gc XMonadFont
fs [String]
hs XPConfig
conf KeyMask
numlock
            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
$ History -> IO ()
writeHistory (History -> IO ()) -> History -> IO ()
forall a b. (a -> b) -> a -> b
$
      ([String] -> [String] -> [String])
-> String -> [String] -> History -> History
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith
      (\xs :: [String]
xs ys :: [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
command XPState
st'])
      History
hist
  XPState -> X XPState
forall (m :: * -> *) a. Monad m => a -> m a
return XPState
st'

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

-- | 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 str :: 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 st :: XPState
st = do
  let d :: Display
d = XPState -> Display
dpy XPState
st
      w :: Window
w = XPState -> Window
win XPState
st
  XPState
st' <- IO GrabStatus
-> (GrabStatus -> IO ())
-> (GrabStatus -> IO XPState)
-> IO XPState
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
    (Display
-> Window
-> Bool
-> GrabStatus
-> GrabStatus
-> Window
-> IO GrabStatus
grabKeyboard Display
d Window
w Bool
True GrabStatus
grabModeAsync GrabStatus
grabModeAsync Window
currentTime)
    (\_ -> Display -> Window -> IO ()
ungrabKeyboard Display
d Window
currentTime)
    (\status :: GrabStatus
status ->
      ((XP () -> XPState -> IO XPState) -> XPState -> XP () -> IO XPState
forall a b c. (a -> b -> c) -> b -> a -> c
flip XP () -> XPState -> IO XPState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT XPState
st (XP () -> IO XPState) -> XP () -> IO XPState
forall a b. (a -> b) -> a -> b
$ do
        Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GrabStatus
status GrabStatus -> GrabStatus -> Bool
forall a. Eq a => a -> a -> Bool
== GrabStatus
grabSuccess) (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$ do
          XP ()
updateWindows
          (KeyStroke -> Event -> XP ()) -> XP Bool -> XP ()
eventLoop KeyStroke -> Event -> XP ()
handleMain XP Bool
evDefaultStop)
      IO XPState -> IO () -> IO XPState
forall a b. IO a -> IO b -> IO a
`finally` ((Window -> IO ()) -> Maybe Window -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Display -> Window -> IO ()
destroyWindow Display
d) (Maybe Window -> IO ()) -> IO (Maybe Window) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (Maybe Window) -> IO (Maybe Window)
forall a. IORef a -> IO a
readIORef (XPState -> IORef (Maybe Window)
complWinRef 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)
  XPState -> IO XPState
forall (m :: * -> *) a. Monad m => a -> m a
return XPState
st'

type KeyStroke = (KeySym, String)

-- | Main event "loop". Gives priority to events from the state's event buffer.
eventLoop :: (KeyStroke -> Event -> XP ())
          -> XP Bool
          -> XP ()
eventLoop :: (KeyStroke -> Event -> XP ()) -> XP Bool -> XP ()
eventLoop handle :: KeyStroke -> Event -> XP ()
handle stopAction :: XP Bool
stopAction = do
    [(Window, String, Event)]
b <- (XPState -> [(Window, String, Event)])
-> StateT XPState IO [(Window, String, Event)]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> [(Window, String, Event)]
eventBuffer
    (keysym :: Window
keysym,keystr :: String
keystr,event :: Event
event) <- case [(Window, 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 (Window, String, Event)
-> StateT XPState IO (Window, String, Event)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Window, String, Event)
 -> StateT XPState IO (Window, String, Event))
-> IO (Window, String, Event)
-> StateT XPState IO (Window, String, Event)
forall a b. (a -> b) -> a -> b
$ (XEventPtr -> IO (Window, String, Event))
-> IO (Window, String, Event)
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO (Window, String, Event))
 -> IO (Window, String, Event))
-> (XEventPtr -> IO (Window, String, Event))
-> IO (Window, String, Event)
forall a b. (a -> b) -> a -> b
$ \e :: XEventPtr
e -> do
                    Display -> Window -> XEventPtr -> IO ()
maskEvent Display
d (Window
exposureMask Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
keyPressMask) XEventPtr
e
                    Event
ev <- XEventPtr -> IO Event
getEvent XEventPtr
e
                    (ks :: Maybe Window
ks,s :: String
s) <- if Event -> Dimension
ev_event_type Event
ev Dimension -> Dimension -> Bool
forall a. Eq a => a -> a -> Bool
== Dimension
keyPress
                              then XKeyEventPtr -> IO (Maybe Window, String)
lookupString (XKeyEventPtr -> IO (Maybe Window, String))
-> XKeyEventPtr -> IO (Maybe Window, String)
forall a b. (a -> b) -> a -> b
$ XEventPtr -> XKeyEventPtr
asKeyEvent XEventPtr
e
                              else (Maybe Window, String) -> IO (Maybe Window, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Window
forall a. Maybe a
Nothing, "")
                    (Window, String, Event) -> IO (Window, String, Event)
forall (m :: * -> *) a. Monad m => a -> m a
return (Window -> Maybe Window -> Window
forall a. a -> Maybe a -> a
fromMaybe Window
xK_VoidSymbol Maybe Window
ks,String
s,Event
ev)
        l :: [(Window, String, Event)]
l   -> 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
$ \s :: XPState
s -> XPState
s { eventBuffer :: [(Window, String, Event)]
eventBuffer = [(Window, String, Event)] -> [(Window, String, Event)]
forall a. [a] -> [a]
tail [(Window, String, Event)]
l }
                (Window, String, Event)
-> StateT XPState IO (Window, String, Event)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Window, String, Event)
 -> StateT XPState IO (Window, String, Event))
-> (Window, String, Event)
-> StateT XPState IO (Window, String, Event)
forall a b. (a -> b) -> a -> b
$ [(Window, String, Event)] -> (Window, String, Event)
forall a. [a] -> a
head [(Window, String, Event)]
l
    KeyStroke -> Event -> XP ()
handle (Window
keysym,String
keystr) Event
event
    XP Bool
stopAction XP Bool -> (Bool -> XP ()) -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> XP () -> XP ()) -> XP () -> Bool -> XP ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((KeyStroke -> Event -> XP ()) -> XP Bool -> XP ()
eventLoop KeyStroke -> Event -> XP ()
handle XP Bool
stopAction)

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

-- | Common patterns shared by all event handlers. Expose events can be
-- triggered by switching virtual consoles.
handleOther :: KeyStroke -> Event -> XP ()
handleOther :: KeyStroke -> Event -> XP ()
handleOther _ (ExposeEvent {ev_window :: Event -> Window
ev_window = Window
w}) = do
    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 -> Window
win XPState
st Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
w) XP ()
updateWindows
handleOther _ _ = () -> XP ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | 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@(keysym :: Window
keysym,_) (KeyEvent {ev_event_type :: Event -> Dimension
ev_event_type = Dimension
t, ev_state :: Event -> KeyMask
ev_state = KeyMask
m}) = do
    (compKey :: (KeyMask, Window)
compKey,modeKey :: Window
modeKey) <- (XPState -> ((KeyMask, Window), Window))
-> StateT XPState IO ((KeyMask, Window), Window)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XPState -> ((KeyMask, Window), Window))
 -> StateT XPState IO ((KeyMask, Window), Window))
-> (XPState -> ((KeyMask, Window), Window))
-> StateT XPState IO ((KeyMask, Window), Window)
forall a b. (a -> b) -> a -> b
$ (XPConfig -> (KeyMask, Window)
completionKey (XPConfig -> (KeyMask, Window))
-> (XPConfig -> Window) -> XPConfig -> ((KeyMask, Window), Window)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPConfig -> Window
changeModeKey) (XPConfig -> ((KeyMask, Window), Window))
-> (XPState -> XPConfig) -> XPState -> ((KeyMask, Window), Window)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPConfig
config
    KeyMask
keymask <- KeyMask -> XP KeyMask
cleanMask 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,Window
keysym) (KeyMask, Window) -> (KeyMask, Window) -> Bool
forall a. Eq a => a -> a -> Bool
== (KeyMask, Window)
compKey
           then XP (Maybe [String])
getCurrentCompletions XP (Maybe [String]) -> (Maybe [String] -> XP ()) -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe [String] -> XP ()
handleCompletionMain
           else do
                Maybe [String] -> XP ()
setCurrentCompletions Maybe [String]
forall a. Maybe a
Nothing
                if (Window
keysym Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== Window
modeKey)
                   then (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify XPState -> XPState
setNextMode XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
updateWindows
                   else KeyMask -> KeyStroke -> XP ()
handleInputMain KeyMask
keymask KeyStroke
stroke
handleMain stroke :: KeyStroke
stroke event :: Event
event = KeyStroke -> Event -> XP ()
handleOther KeyStroke
stroke Event
event

-- | Prompt input handler for the main loop.
handleInputMain :: KeyMask -> KeyStroke -> XP ()
handleInputMain :: KeyMask -> KeyStroke -> XP ()
handleInputMain keymask :: KeyMask
keymask (keysym :: Window
keysym,keystr :: String
keystr) = do
    Map (KeyMask, Window) (XP ())
keymap <- (XPState -> Map (KeyMask, Window) (XP ()))
-> StateT XPState IO (Map (KeyMask, Window) (XP ()))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (XPConfig -> Map (KeyMask, Window) (XP ())
promptKeymap (XPConfig -> Map (KeyMask, Window) (XP ()))
-> (XPState -> XPConfig)
-> XPState
-> Map (KeyMask, Window) (XP ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPState -> XPConfig
config)
    case (KeyMask, Window) -> Map (KeyMask, Window) (XP ()) -> Maybe (XP ())
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (KeyMask
keymask,Window
keysym) Map (KeyMask, Window) (XP ())
keymap of
        -- 'null keystr' i.e. when only a modifier was pressed
        Just action :: XP ()
action -> XP ()
action XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
updateWindows
        Nothing     -> Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
keystr) (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$
            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
== 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 <- XP Bool
tryAutoComplete
                Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
complete (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$ Bool -> XP ()
setSuccess Bool
True XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setDone Bool
True

-- 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 :: Maybe [String] -> XP ()
handleCompletionMain :: Maybe [String] -> XP ()
handleCompletionMain Nothing   = do
    [String]
cs <- XP [String]
getCompletions
    Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
cs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 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
$ \s :: XPState
s -> XPState
s { showComplWin :: Bool
showComplWin = Bool
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
    [String] -> XP ()
handleCompletion [String]
cs
handleCompletionMain (Just cs :: [String]
cs) = [String] -> XP ()
handleCompletion [String]
cs

handleCompletion :: [String] -> XP ()
handleCompletion :: [String] -> XP ()
handleCompletion cs :: [String]
cs = do
    Bool
alwaysHlight <- (XPState -> Bool) -> XP Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XPState -> Bool) -> XP Bool) -> (XPState -> Bool) -> XP 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  l :: [String]
l = [String] -> XP ()
redrawWindows [String]
l
        updateState :: [String] -> XP ()
updateState l :: [String]
l = case Bool
alwaysHlight of
            False                                           -> [String] -> XPState -> XP ()
simpleComplete [String]
l XPState
st
            True | String -> Maybe String
forall a. a -> Maybe a
Just (XPState -> String
command XPState
st) Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
/= XPState -> Maybe String
highlightedCompl XPState
st -> XPState -> XP ()
alwaysHighlightCurrent XPState
st
                 | Bool
otherwise                                -> [String] -> XPState -> XP ()
alwaysHighlightNext [String]
l XPState
st

    case [String]
cs of
      []  -> XP ()
updateWindows
      [x :: String
x] -> do [String] -> XP ()
updateState [String
x]
                [String]
cs' <- XP [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'
      l :: [String]
l   -> [String] -> XP ()
updateState [String]
l   XP () -> XP () -> XP ()
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 l :: [String]
l st :: 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
$ \s :: XPState
s -> String -> XPState -> XPState
setCommand String
newCommand (XPState -> XPState) -> XPState -> XPState
forall a b. (a -> b) -> a -> b
$
                         XPState
s { offset :: Int
offset = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
newCommand
                           , highlightedCompl :: Maybe String
highlightedCompl = String -> Maybe String
forall a. a -> Maybe a
Just String
newCommand
                           }

        -- If alwaysHighlight is on, and this is the first use of the
        -- completion key, update the buffer so that it contains the
        -- current completion item.
        alwaysHighlightCurrent :: XPState -> XP ()
        alwaysHighlightCurrent :: XPState -> XP ()
alwaysHighlightCurrent st :: XPState
st = do
          let newCommand :: String
newCommand = 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]
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
$ \s :: XPState
s -> String -> XPState -> XPState
setCommand String
newCommand (XPState -> XPState) -> XPState -> XPState
forall a b. (a -> b) -> a -> b
$
                         Maybe String -> XPState -> XPState
setHighlightedCompl (String -> Maybe String
forall a. a -> Maybe a
Just String
newCommand) (XPState -> XPState) -> XPState -> XPState
forall a b. (a -> b) -> a -> b
$
                         XPState
s { offset :: Int
offset = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
newCommand
                           }

        -- If alwaysHighlight is on, and the user wants the next
        -- completion, move to the next completion item and update the
        -- buffer to reflect that.
        --
        --TODO: Scroll or paginate results
        alwaysHighlightNext :: [String] -> XPState -> XP ()
        alwaysHighlightNext :: [String] -> XPState -> XP ()
alwaysHighlightNext l :: [String]
l st :: XPState
st = do
          let complIndex' :: (Int, Int)
complIndex' = XPState -> Int -> (Int, Int)
nextComplIndex XPState
st ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
l)
              highlightedCompl' :: Maybe String
highlightedCompl' = XPState -> [String] -> Maybe String
highlightedItem XPState
st { complIndex :: (Int, Int)
complIndex = (Int, Int)
complIndex'} [String]
cs
              newCommand :: String
newCommand = 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
$ Maybe String
highlightedCompl'
          (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
$ \s :: XPState
s -> Maybe String -> XPState -> XPState
setHighlightedCompl Maybe String
highlightedCompl' (XPState -> XPState) -> XPState -> XPState
forall a b. (a -> b) -> a -> b
$
                         String -> XPState -> XPState
setCommand String
newCommand (XPState -> XPState) -> XPState -> XPState
forall a b. (a -> b) -> a -> b
$
                         XPState
s { complIndex :: (Int, Int)
complIndex = (Int, Int)
complIndex'
                           , offset :: Int
offset = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
newCommand
                           }

-- | 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, Window) (XP ()) -> XP ()
promptSubmap defaultAction :: XP ()
defaultAction keymap :: Map (KeyMask, Window) (XP ())
keymap = do
    Bool
md <- (XPState -> Bool) -> XP 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 ()) -> XP Bool -> XP ()
eventLoop (XP ()
-> Map (KeyMask, Window) (XP ()) -> KeyStroke -> Event -> XP ()
handleSubmap XP ()
defaultAction Map (KeyMask, Window) (XP ())
keymap) XP Bool
evDefaultStop
    Bool -> XP ()
setModeDone Bool
md

handleSubmap :: XP ()
             -> M.Map (KeyMask, KeySym) (XP ())
             -> KeyStroke
             -> Event
             -> XP ()
handleSubmap :: XP ()
-> Map (KeyMask, Window) (XP ()) -> KeyStroke -> Event -> XP ()
handleSubmap defaultAction :: XP ()
defaultAction keymap :: Map (KeyMask, Window) (XP ())
keymap stroke :: KeyStroke
stroke (KeyEvent {ev_event_type :: Event -> Dimension
ev_event_type = Dimension
t, ev_state :: Event -> KeyMask
ev_state = KeyMask
m}) = do
    KeyMask
keymask <- KeyMask -> XP KeyMask
cleanMask 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, Window) (XP ()) -> KeyMask -> KeyStroke -> XP ()
handleInputSubmap XP ()
defaultAction Map (KeyMask, Window) (XP ())
keymap KeyMask
keymask KeyStroke
stroke
handleSubmap _ _ stroke :: KeyStroke
stroke event :: Event
event = KeyStroke -> Event -> XP ()
handleOther KeyStroke
stroke Event
event

handleInputSubmap :: XP ()
                  -> M.Map (KeyMask, KeySym) (XP ())
                  -> KeyMask
                  -> KeyStroke
                  -> XP ()
handleInputSubmap :: XP ()
-> Map (KeyMask, Window) (XP ()) -> KeyMask -> KeyStroke -> XP ()
handleInputSubmap defaultAction :: XP ()
defaultAction keymap :: Map (KeyMask, Window) (XP ())
keymap keymask :: KeyMask
keymask (keysym :: Window
keysym,keystr :: String
keystr) = do
    case (KeyMask, Window) -> Map (KeyMask, Window) (XP ()) -> Maybe (XP ())
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (KeyMask
keymask,Window
keysym) Map (KeyMask, Window) (XP ())
keymap of
        Just action :: XP ()
action -> XP ()
action XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
updateWindows
        Nothing     -> Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
keystr) (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$ XP ()
defaultAction XP () -> XP () -> XP ()
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 f :: String -> String -> (Bool, Bool)
f = do
    Bool
md <- (XPState -> Bool) -> XP Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Bool
modeDone
    Bool -> XP ()
setModeDone Bool
False
    (KeyStroke -> Event -> XP ()) -> XP Bool -> XP ()
eventLoop ((String -> String -> (Bool, Bool)) -> KeyStroke -> Event -> XP ()
handleBuffer String -> String -> (Bool, Bool)
f) XP Bool
evDefaultStop
    String
buff <- (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
$ \s :: XPState
s -> XPState
s { inputBuffer :: String
inputBuffer = "" }
    Bool -> XP ()
setModeDone Bool
md
    String -> XP String
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 f :: String -> String -> (Bool, Bool)
f stroke :: 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 <- KeyMask -> XP KeyMask
cleanMask 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 _ stroke :: KeyStroke
stroke event :: 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 f :: String -> String -> (Bool, Bool)
f keymask :: KeyMask
keymask (keysym :: Window
keysym,keystr :: String
keystr) event :: Event
event = do
    Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
keystr 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
/= 0) (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$ do
        (evB :: [(Window, String, Event)]
evB,inB :: String
inB) <- (XPState -> ([(Window, String, Event)], String))
-> StateT XPState IO ([(Window, String, Event)], String)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (XPState -> [(Window, String, Event)]
eventBuffer (XPState -> [(Window, String, Event)])
-> (XPState -> String)
-> XPState
-> ([(Window, String, Event)], String)
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 (cont :: Bool
cont,keep :: 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
$ \s :: XPState
s -> XPState
s { inputBuffer :: String
inputBuffer = String
inB String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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
$ \s :: XPState
s -> XPState
s { eventBuffer :: [(Window, String, Event)]
eventBuffer = (Window
keysym,String
keystr,Event
event) (Window, String, Event)
-> [(Window, String, Event)] -> [(Window, String, Event)]
forall a. a -> [a] -> [a]
: [(Window, String, Event)]
evB }

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

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

tryAutoComplete :: XP Bool
tryAutoComplete :: XP 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 d :: Int
d -> do [String]
cs <- XP [String]
getCompletions
                     case [String]
cs of
                         [c :: String
c] -> String -> Int -> XP Bool
runCompleted String
c Int
d XP Bool -> XP Bool -> XP Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                         _   -> Bool -> XP Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Nothing    -> Bool -> XP Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  where runCompleted :: String -> Int -> XP Bool
runCompleted cmd :: String
cmd delay :: 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 "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 -> XP Bool
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, Window) (XP ())
defaultXPKeymap = (Char -> Bool) -> Map (KeyMask, Window) (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, Window) (XP ())
defaultXPKeymap' p :: Char -> Bool
p = [((KeyMask, Window), XP ())] -> Map (KeyMask, Window) (XP ())
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((KeyMask, Window), XP ())] -> Map (KeyMask, Window) (XP ()))
-> [((KeyMask, Window), XP ())] -> Map (KeyMask, Window) (XP ())
forall a b. (a -> b) -> a -> b
$
  ((Window, XP ()) -> ((KeyMask, Window), XP ()))
-> [(Window, XP ())] -> [((KeyMask, Window), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((Window -> (KeyMask, Window))
-> (Window, XP ()) -> ((KeyMask, Window), XP ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Window -> (KeyMask, Window))
 -> (Window, XP ()) -> ((KeyMask, Window), XP ()))
-> (Window -> (KeyMask, Window))
-> (Window, XP ())
-> ((KeyMask, Window), XP ())
forall a b. (a -> b) -> a -> b
$ (,) KeyMask
controlMask) -- control + <key>
  [ (Window
xK_u, XP ()
killBefore)
  , (Window
xK_k, XP ()
killAfter)
  , (Window
xK_a, XP ()
startOfLine)
  , (Window
xK_e, XP ()
endOfLine)
  , (Window
xK_y, XP ()
pasteString)
  -- Retain the pre-0.14 moveWord' behavior:
  , (Window
xK_Right, (Char -> Bool) -> Direction1D -> XP ()
moveWord' Char -> Bool
p Direction1D
Next XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursor Direction1D
Next)
  , (Window
xK_Left, Direction1D -> XP ()
moveCursor Direction1D
Prev XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Direction1D -> XP ()
moveWord' Char -> Bool
p Direction1D
Prev)
  , (Window
xK_Delete, (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
p Direction1D
Next)
  , (Window
xK_BackSpace, (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
p Direction1D
Prev)
  , (Window
xK_w, (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
p Direction1D
Prev)
  , (Window
xK_g, XP ()
quit)
  , (Window
xK_bracketleft, XP ()
quit)
  ] [((KeyMask, Window), XP ())]
-> [((KeyMask, Window), XP ())] -> [((KeyMask, Window), XP ())]
forall a. [a] -> [a] -> [a]
++
  ((Window, XP ()) -> ((KeyMask, Window), XP ()))
-> [(Window, XP ())] -> [((KeyMask, Window), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((Window -> (KeyMask, Window))
-> (Window, XP ()) -> ((KeyMask, Window), XP ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Window -> (KeyMask, Window))
 -> (Window, XP ()) -> ((KeyMask, Window), XP ()))
-> (Window -> (KeyMask, Window))
-> (Window, XP ())
-> ((KeyMask, Window), XP ())
forall a b. (a -> b) -> a -> b
$ (,) 0)
  [ (Window
xK_Return, Bool -> XP ()
setSuccess Bool
True XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setDone Bool
True)
  , (Window
xK_KP_Enter, Bool -> XP ()
setSuccess Bool
True XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setDone Bool
True)
  , (Window
xK_BackSpace, Direction1D -> XP ()
deleteString Direction1D
Prev)
  , (Window
xK_Delete, Direction1D -> XP ()
deleteString Direction1D
Next)
  , (Window
xK_Left, Direction1D -> XP ()
moveCursor Direction1D
Prev)
  , (Window
xK_Right, Direction1D -> XP ()
moveCursor Direction1D
Next)
  , (Window
xK_Home, XP ()
startOfLine)
  , (Window
xK_End, XP ()
endOfLine)
  , (Window
xK_Down, (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusUp')
  , (Window
xK_Up, (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusDown')
  , (Window
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, Window) (XP ())
emacsLikeXPKeymap = (Char -> Bool) -> Map (KeyMask, Window) (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, Window) (XP ())
emacsLikeXPKeymap' p :: Char -> Bool
p = [((KeyMask, Window), XP ())] -> Map (KeyMask, Window) (XP ())
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((KeyMask, Window), XP ())] -> Map (KeyMask, Window) (XP ()))
-> [((KeyMask, Window), XP ())] -> Map (KeyMask, Window) (XP ())
forall a b. (a -> b) -> a -> b
$
  ((Window, XP ()) -> ((KeyMask, Window), XP ()))
-> [(Window, XP ())] -> [((KeyMask, Window), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((Window -> (KeyMask, Window))
-> (Window, XP ()) -> ((KeyMask, Window), XP ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Window -> (KeyMask, Window))
 -> (Window, XP ()) -> ((KeyMask, Window), XP ()))
-> (Window -> (KeyMask, Window))
-> (Window, XP ())
-> ((KeyMask, Window), XP ())
forall a b. (a -> b) -> a -> b
$ (,) KeyMask
controlMask) -- control + <key>
  [ (Window
xK_z, XP ()
killBefore) --kill line backwards
  , (Window
xK_k, XP ()
killAfter) -- kill line fowards
  , (Window
xK_a, XP ()
startOfLine) --move to the beginning of the line
  , (Window
xK_e, XP ()
endOfLine) -- move to the end of the line
  , (Window
xK_d, Direction1D -> XP ()
deleteString Direction1D
Next) -- delete a character foward
  , (Window
xK_b, Direction1D -> XP ()
moveCursor Direction1D
Prev) -- move cursor forward
  , (Window
xK_f, Direction1D -> XP ()
moveCursor Direction1D
Next) -- move cursor backward
  , (Window
xK_BackSpace, (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
p Direction1D
Prev) -- kill the previous word
  , (Window
xK_y, XP ()
pasteString)
  , (Window
xK_g, XP ()
quit)
  , (Window
xK_bracketleft, XP ()
quit)
  ] [((KeyMask, Window), XP ())]
-> [((KeyMask, Window), XP ())] -> [((KeyMask, Window), XP ())]
forall a. [a] -> [a] -> [a]
++
  ((Window, XP ()) -> ((KeyMask, Window), XP ()))
-> [(Window, XP ())] -> [((KeyMask, Window), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((Window -> (KeyMask, Window))
-> (Window, XP ()) -> ((KeyMask, Window), XP ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Window -> (KeyMask, Window))
 -> (Window, XP ()) -> ((KeyMask, Window), XP ()))
-> (Window -> (KeyMask, Window))
-> (Window, XP ())
-> ((KeyMask, Window), XP ())
forall a b. (a -> b) -> a -> b
$ (,) KeyMask
mod1Mask) -- meta key + <key>
  [ (Window
xK_BackSpace, (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
p Direction1D
Prev)
  -- Retain the pre-0.14 moveWord' behavior:
  , (Window
xK_f, (Char -> Bool) -> Direction1D -> XP ()
moveWord' Char -> Bool
p Direction1D
Next XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursor Direction1D
Next) -- move a word forward
  , (Window
xK_b, Direction1D -> XP ()
moveCursor Direction1D
Prev XP () -> XP () -> XP ()
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
  , (Window
xK_d, (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
p Direction1D
Next) -- kill the next word
  , (Window
xK_n, (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusUp')
  , (Window
xK_p, (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusDown')
  ]
  [((KeyMask, Window), XP ())]
-> [((KeyMask, Window), XP ())] -> [((KeyMask, Window), XP ())]
forall a. [a] -> [a] -> [a]
++
  ((Window, XP ()) -> ((KeyMask, Window), XP ()))
-> [(Window, XP ())] -> [((KeyMask, Window), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((Window -> (KeyMask, Window))
-> (Window, XP ()) -> ((KeyMask, Window), XP ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Window -> (KeyMask, Window))
 -> (Window, XP ()) -> ((KeyMask, Window), XP ()))
-> (Window -> (KeyMask, Window))
-> (Window, XP ())
-> ((KeyMask, Window), XP ())
forall a b. (a -> b) -> a -> b
$ (,) 0) -- <key>
  [ (Window
xK_Return, Bool -> XP ()
setSuccess Bool
True XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setDone Bool
True)
  , (Window
xK_KP_Enter, Bool -> XP ()
setSuccess Bool
True XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setDone Bool
True)
  , (Window
xK_BackSpace, Direction1D -> XP ()
deleteString Direction1D
Prev)
  , (Window
xK_Delete, Direction1D -> XP ()
deleteString Direction1D
Next)
  , (Window
xK_Left, Direction1D -> XP ()
moveCursor Direction1D
Prev)
  , (Window
xK_Right, Direction1D -> XP ()
moveCursor Direction1D
Next)
  , (Window
xK_Home, XP ()
startOfLine)
  , (Window
xK_End, XP ()
endOfLine)
  , (Window
xK_Down, (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusUp')
  , (Window
xK_Up, (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusDown')
  , (Window
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, Window) (XP ())
vimLikeXPKeymap = (XPColor -> XPColor)
-> (String -> String)
-> (String -> String)
-> (Char -> Bool)
-> Map (KeyMask, Window) (XP ())
vimLikeXPKeymap' (String -> XPColor -> XPColor
setBorderColor "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, Window) (XP ())
vimLikeXPKeymap' fromColor :: XPColor -> XPColor
fromColor promptF :: String -> String
promptF pasteFilter :: String -> String
pasteFilter notWord :: Char -> Bool
notWord = [((KeyMask, Window), XP ())] -> Map (KeyMask, Window) (XP ())
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((KeyMask, Window), XP ())] -> Map (KeyMask, Window) (XP ()))
-> [((KeyMask, Window), XP ())] -> Map (KeyMask, Window) (XP ())
forall a b. (a -> b) -> a -> b
$
    ((Window, XP ()) -> ((KeyMask, Window), XP ()))
-> [(Window, XP ())] -> [((KeyMask, Window), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((Window -> (KeyMask, Window))
-> (Window, XP ()) -> ((KeyMask, Window), XP ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Window -> (KeyMask, Window))
 -> (Window, XP ()) -> ((KeyMask, Window), XP ()))
-> (Window -> (KeyMask, Window))
-> (Window, XP ())
-> ((KeyMask, Window), XP ())
forall a b. (a -> b) -> a -> b
$ (,) 0)
    [ (Window
xK_Return,       Bool -> XP ()
setSuccess Bool
True XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setDone Bool
True)
    , (Window
xK_KP_Enter,     Bool -> XP ()
setSuccess Bool
True XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setDone Bool
True)
    , (Window
xK_BackSpace,    Direction1D -> XP ()
deleteString Direction1D
Prev)
    , (Window
xK_Delete,       Direction1D -> XP ()
deleteString Direction1D
Next)
    , (Window
xK_Left,         Direction1D -> XP ()
moveCursor Direction1D
Prev)
    , (Window
xK_Right,        Direction1D -> XP ()
moveCursor Direction1D
Next)
    , (Window
xK_Home,         XP ()
startOfLine)
    , (Window
xK_End,          XP ()
endOfLine)
    , (Window
xK_Down,         (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusUp')
    , (Window
xK_Up,           (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusDown')
    , (Window
xK_Escape,       Direction1D -> XP ()
moveCursor Direction1D
Prev
                            XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (XPColor -> XPColor) -> XP ()
modifyColor XPColor -> XPColor
fromColor
                            XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (String -> String) -> XP ()
setPrompter String -> String
promptF
                            XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP () -> Map (KeyMask, Window) (XP ()) -> XP ()
promptSubmap (() -> XP ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Map (KeyMask, Window) (XP ())
normalVimXPKeymap
                            XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
resetColor
                            XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
resetPrompter
      )
    ] where
    normalVimXPKeymap :: Map (KeyMask, Window) (XP ())
normalVimXPKeymap = [((KeyMask, Window), XP ())] -> Map (KeyMask, Window) (XP ())
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((KeyMask, Window), XP ())] -> Map (KeyMask, Window) (XP ()))
-> [((KeyMask, Window), XP ())] -> Map (KeyMask, Window) (XP ())
forall a b. (a -> b) -> a -> b
$
        ((Window, XP ()) -> ((KeyMask, Window), XP ()))
-> [(Window, XP ())] -> [((KeyMask, Window), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((Window -> (KeyMask, Window))
-> (Window, XP ()) -> ((KeyMask, Window), XP ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Window -> (KeyMask, Window))
 -> (Window, XP ()) -> ((KeyMask, Window), XP ()))
-> (Window -> (KeyMask, Window))
-> (Window, XP ())
-> ((KeyMask, Window), XP ())
forall a b. (a -> b) -> a -> b
$ (,) 0)
        [ (Window
xK_i,            Bool -> XP ()
setModeDone Bool
True)
        , (Window
xK_a,            Direction1D -> XP ()
moveCursor Direction1D
Next XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True)
        , (Window
xK_s,            Direction1D -> XP ()
deleteString Direction1D
Next XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True)
        , (Window
xK_x,            Direction1D -> XP ()
deleteString Direction1D
Next XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
clipCursor)
        , (Window
xK_Delete,       Direction1D -> XP ()
deleteString Direction1D
Next XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
clipCursor)
        , (Window
xK_p,            Direction1D -> XP ()
moveCursor Direction1D
Next
                                XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (String -> String) -> XP ()
pasteString' String -> String
pasteFilter
                                XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursor Direction1D
Prev
          )
        , (Window
xK_0,            XP ()
startOfLine)
        , (Window
xK_Escape,       XP ()
quit)
        , (Window
xK_Down,         (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusUp')
        , (Window
xK_j,            (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusUp')
        , (Window
xK_Up,           (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusDown')
        , (Window
xK_k,            (Stack String -> Stack String) -> XP ()
moveHistory Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusDown')
        , (Window
xK_Right,        Direction1D -> XP ()
moveCursorClip Direction1D
Next)
        , (Window
xK_l,            Direction1D -> XP ()
moveCursorClip Direction1D
Next)
        , (Window
xK_h,            Direction1D -> XP ()
moveCursorClip Direction1D
Prev)
        , (Window
xK_Left,         Direction1D -> XP ()
moveCursorClip Direction1D
Prev)
        , (Window
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)
        , (Window
xK_e,            Direction1D -> XP ()
moveCursorClip Direction1D
Next XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Direction1D -> XP ()
moveWord' Char -> Bool
notWord Direction1D
Next)
        , (Window
xK_b,            Direction1D -> XP ()
moveCursorClip Direction1D
Prev XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Direction1D -> XP ()
moveWord' Char -> Bool
notWord Direction1D
Prev)
        , (Window
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursorClip Direction1D
Next)
        , (Window
xK_f,            (String -> String -> (Bool, Bool)) -> XP String
promptBuffer String -> String -> (Bool, Bool)
bufferOne XP String -> (String -> XP ()) -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Direction1D -> String -> XP ()
toHeadChar Direction1D
Next)
        , (Window
xK_d,            XP () -> Map (KeyMask, Window) (XP ()) -> XP ()
promptSubmap (Bool -> XP ()
setModeDone Bool
True) Map (KeyMask, Window) (XP ())
deleteVimXPKeymap)
        , (Window
xK_c,            XP () -> Map (KeyMask, Window) (XP ()) -> XP ()
promptSubmap (Bool -> XP ()
setModeDone Bool
True) Map (KeyMask, Window) (XP ())
changeVimXPKeymap
                                XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True
          )
        ] [((KeyMask, Window), XP ())]
-> [((KeyMask, Window), XP ())] -> [((KeyMask, Window), XP ())]
forall a. [a] -> [a] -> [a]
++
        ((Window, XP ()) -> ((KeyMask, Window), XP ()))
-> [(Window, XP ())] -> [((KeyMask, Window), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map ((Window -> (KeyMask, Window))
-> (Window, XP ()) -> ((KeyMask, Window), XP ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Window -> (KeyMask, Window))
 -> (Window, XP ()) -> ((KeyMask, Window), XP ()))
-> (Window -> (KeyMask, Window))
-> (Window, XP ())
-> ((KeyMask, Window), XP ())
forall a b. (a -> b) -> a -> b
$ (,) KeyMask
shiftMask)
        [ (Window
xK_dollar,       XP ()
endOfLine XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursor Direction1D
Prev)
        , (Window
xK_D,            XP ()
killAfter XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursor Direction1D
Prev)
        , (Window
xK_C,            XP ()
killAfter XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True)
        , (Window
xK_P,            (String -> String) -> XP ()
pasteString' String -> String
pasteFilter XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursor Direction1D
Prev)
        , (Window
xK_A,            XP ()
endOfLine XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True)
        , (Window
xK_I,            XP ()
startOfLine XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setModeDone Bool
True)
        , (Window
xK_F,            (String -> String -> (Bool, Bool)) -> XP String
promptBuffer String -> String -> (Bool, Bool)
bufferOne XP String -> (String -> XP ()) -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Direction1D -> String -> XP ()
toHeadChar Direction1D
Prev)
        ]
    deleteVimXPKeymap :: Map (KeyMask, Window) (XP ())
deleteVimXPKeymap = [((KeyMask, Window), XP ())] -> Map (KeyMask, Window) (XP ())
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((KeyMask, Window), XP ())] -> Map (KeyMask, Window) (XP ()))
-> [((KeyMask, Window), XP ())] -> Map (KeyMask, Window) (XP ())
forall a b. (a -> b) -> a -> b
$
        ((Window, XP ()) -> ((KeyMask, Window), XP ()))
-> [(Window, XP ())] -> [((KeyMask, Window), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map (((Window -> (KeyMask, Window))
-> (Window, XP ()) -> ((KeyMask, Window), XP ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Window -> (KeyMask, Window))
 -> (Window, XP ()) -> ((KeyMask, Window), XP ()))
-> (Window -> (KeyMask, Window))
-> (Window, XP ())
-> ((KeyMask, Window), XP ())
forall a b. (a -> b) -> a -> b
$ (,) 0) ((Window, XP ()) -> ((KeyMask, Window), XP ()))
-> ((Window, XP ()) -> (Window, XP ()))
-> (Window, XP ())
-> ((KeyMask, Window), XP ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((XP () -> XP ()) -> (Window, XP ()) -> (Window, XP ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((XP () -> XP ()) -> (Window, XP ()) -> (Window, XP ()))
-> (XP () -> XP ()) -> (Window, XP ()) -> (Window, XP ())
forall a b. (a -> b) -> a -> b
$ (XP () -> XP () -> XP ()) -> XP () -> XP () -> XP ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>) (Bool -> XP ()
setModeDone Bool
True)))
        [ (Window
xK_e,            Direction1D -> XP ()
deleteString Direction1D
Next XP () -> XP () -> XP ()
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
clipCursor)
        , (Window
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> XP ()
clipCursor)
        , (Window
xK_0,            XP ()
killBefore)
        , (Window
xK_b,            (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
notWord Direction1D
Prev)
        , (Window
xK_d,            String -> XP ()
setInput "")
        ] [((KeyMask, Window), XP ())]
-> [((KeyMask, Window), XP ())] -> [((KeyMask, Window), XP ())]
forall a. [a] -> [a] -> [a]
++
        ((Window, XP ()) -> ((KeyMask, Window), XP ()))
-> [(Window, XP ())] -> [((KeyMask, Window), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map (((Window -> (KeyMask, Window))
-> (Window, XP ()) -> ((KeyMask, Window), XP ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Window -> (KeyMask, Window))
 -> (Window, XP ()) -> ((KeyMask, Window), XP ()))
-> (Window -> (KeyMask, Window))
-> (Window, XP ())
-> ((KeyMask, Window), XP ())
forall a b. (a -> b) -> a -> b
$ (,) KeyMask
shiftMask) ((Window, XP ()) -> ((KeyMask, Window), XP ()))
-> ((Window, XP ()) -> (Window, XP ()))
-> (Window, XP ())
-> ((KeyMask, Window), XP ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((XP () -> XP ()) -> (Window, XP ()) -> (Window, XP ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((XP () -> XP ()) -> (Window, XP ()) -> (Window, XP ()))
-> (XP () -> XP ()) -> (Window, XP ()) -> (Window, XP ())
forall a b. (a -> b) -> a -> b
$ (XP () -> XP () -> XP ()) -> XP () -> XP () -> XP ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>) (Bool -> XP ()
setModeDone Bool
True)))
        [ (Window
xK_dollar,       XP ()
killAfter XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Direction1D -> XP ()
moveCursor Direction1D
Prev)
        ]
    changeVimXPKeymap :: Map (KeyMask, Window) (XP ())
changeVimXPKeymap = [((KeyMask, Window), XP ())] -> Map (KeyMask, Window) (XP ())
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([((KeyMask, Window), XP ())] -> Map (KeyMask, Window) (XP ()))
-> [((KeyMask, Window), XP ())] -> Map (KeyMask, Window) (XP ())
forall a b. (a -> b) -> a -> b
$
        ((Window, XP ()) -> ((KeyMask, Window), XP ()))
-> [(Window, XP ())] -> [((KeyMask, Window), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map (((Window -> (KeyMask, Window))
-> (Window, XP ()) -> ((KeyMask, Window), XP ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Window -> (KeyMask, Window))
 -> (Window, XP ()) -> ((KeyMask, Window), XP ()))
-> (Window -> (KeyMask, Window))
-> (Window, XP ())
-> ((KeyMask, Window), XP ())
forall a b. (a -> b) -> a -> b
$ (,) 0) ((Window, XP ()) -> ((KeyMask, Window), XP ()))
-> ((Window, XP ()) -> (Window, XP ()))
-> (Window, XP ())
-> ((KeyMask, Window), XP ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((XP () -> XP ()) -> (Window, XP ()) -> (Window, XP ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((XP () -> XP ()) -> (Window, XP ()) -> (Window, XP ()))
-> (XP () -> XP ()) -> (Window, XP ()) -> (Window, XP ())
forall a b. (a -> b) -> a -> b
$ (XP () -> XP () -> XP ()) -> XP () -> XP () -> XP ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>) (Bool -> XP ()
setModeDone Bool
True)))
        [ (Window
xK_e,            Direction1D -> XP ()
deleteString Direction1D
Next XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
notWord Direction1D
Next)
        , (Window
xK_0,            XP ()
killBefore)
        , (Window
xK_b,            (Char -> Bool) -> Direction1D -> XP ()
killWord' Char -> Bool
notWord Direction1D
Prev)
        , (Window
xK_c,            String -> XP ()
setInput "")
        , (Window
xK_w,            (Char -> Bool) -> XP ()
changeWord Char -> Bool
notWord)
        ] [((KeyMask, Window), XP ())]
-> [((KeyMask, Window), XP ())] -> [((KeyMask, Window), XP ())]
forall a. [a] -> [a] -> [a]
++
        ((Window, XP ()) -> ((KeyMask, Window), XP ()))
-> [(Window, XP ())] -> [((KeyMask, Window), XP ())]
forall a b. (a -> b) -> [a] -> [b]
map (((Window -> (KeyMask, Window))
-> (Window, XP ()) -> ((KeyMask, Window), XP ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((Window -> (KeyMask, Window))
 -> (Window, XP ()) -> ((KeyMask, Window), XP ()))
-> (Window -> (KeyMask, Window))
-> (Window, XP ())
-> ((KeyMask, Window), XP ())
forall a b. (a -> b) -> a -> b
$ (,) KeyMask
shiftMask) ((Window, XP ()) -> ((KeyMask, Window), XP ()))
-> ((Window, XP ()) -> (Window, XP ()))
-> (Window, XP ())
-> ((KeyMask, Window), XP ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((XP () -> XP ()) -> (Window, XP ()) -> (Window, XP ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((XP () -> XP ()) -> (Window, XP ()) -> (Window, XP ()))
-> (XP () -> XP ()) -> (Window, XP ()) -> (Window, XP ())
forall a b. (a -> b) -> a -> b
$ (XP () -> XP () -> XP ()) -> XP () -> XP () -> XP ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>) (Bool -> XP ()
setModeDone Bool
True)))
        [ (Window
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 b :: 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
$ \s :: XPState
s -> XPState
s { successful :: Bool
successful = Bool
b }

-- | Set @True@ to leave all event loops, no matter how nested.
setDone :: Bool -> XP ()
setDone :: Bool -> XP ()
setDone b :: 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
$ \s :: XPState
s -> XPState
s { done :: Bool
done = Bool
b }

-- | Set @True@ to leave the current event loop, i.e. submaps.
setModeDone :: Bool -> XP ()
setModeDone :: Bool -> XP ()
setModeDone b :: 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
$ \s :: XPState
s -> XPState
s { modeDone :: Bool
modeDone = Bool
b }

-- KeyPress and State

-- | Quit.
quit :: XP ()
quit :: XP ()
quit = XP ()
flushString XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setSuccess Bool
False XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> XP ()
setDone Bool
True XP () -> XP () -> XP ()
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
$ \s :: 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 :: Int
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
$ \s :: 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' p :: Char -> Bool
p d :: 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 (f :: String
f,ss :: String
ss)        = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
o String
c
      delNextWord :: String -> String
delNextWord   = (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
. (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
p (String -> (String, 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
      (ncom :: String
ncom,noff :: Int
noff)   =
          case Direction1D
d of
            Next -> (String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
delNextWord String
ss, Int
o)
            Prev -> (String -> String
delPrevWord String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ss, String -> 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
$ \s :: XPState
s -> String -> XPState -> XPState
setCommand String
ncom (XPState -> XPState) -> XPState -> XPState
forall a b. (a -> b) -> a -> b
$ XPState
s { offset :: Int
offset = Int
noff}

-- | From Vim's @:help cw@:
--
-- * Special case: When the cursor is in a word, "cw" and "cW" do not include
--   the white space after a word, they only change up to the end of the word.
changeWord :: (Char -> Bool) -> XP ()
changeWord :: (Char -> Bool) -> XP ()
changeWord p :: Char -> Bool
p = 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 (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Char -> Bool) -> StateT XPState IO (Char -> Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char -> Bool
p) StateT XPState IO (XP ()) -> (XP () -> XP ()) -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= XP () -> XP ()
forall a. a -> a
id
    where
        f :: String -> Int -> (Char -> Bool) -> XP ()
        f :: String -> Int -> (Char -> Bool) -> XP ()
f str :: String
str off :: Int
off _ | String -> 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 -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0       = () -> XP ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        f str :: String
str off :: Int
off p' :: Char -> Bool
p'| Char -> Bool
p' (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ String
str String -> Int -> Char
forall a. [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

-- | 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
$ \s :: XPState
s -> XPState
s { offset :: Int
offset = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (XPState -> String
command XPState
s)}

-- | Put the cursor at the start of line
startOfLine :: XP ()
startOfLine :: XP ()
startOfLine  =
    (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
$ \s :: XPState
s -> XPState
s { offset :: Int
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
$ \s :: XPState
s -> String -> XPState -> XPState
setCommand "" (XPState -> XPState) -> XPState -> XPState
forall a b. (a -> b) -> a -> b
$ XPState
s { offset :: Int
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 st :: XPState
st = if (XPConfig -> Bool
alwaysHighlight (XPConfig -> Bool) -> XPConfig -> Bool
forall a b. (a -> b) -> a -> b
$ XPState -> XPConfig
config XPState
st) then XPState
st { complIndex :: (Int, Int)
complIndex = (0,0) } else XPState
st

-- | Insert a character at the cursor position
insertString :: String -> XP ()
insertString :: String -> XP ()
insertString str :: 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
$ \s :: XPState
s -> let
    cmd :: String
cmd = (String -> Int -> String
c (XPState -> String
command XPState
s) (XPState -> Int
offset XPState
s))
    st :: XPState
st = XPState -> XPState
resetComplIndex (XPState -> XPState) -> XPState -> XPState
forall a b. (a -> b) -> a -> b
$ XPState
s { offset :: Int
offset = Int -> Int
o (XPState -> Int
offset XPState
s)}
    in String -> XPState -> XPState
setCommand String
cmd XPState
st
  where o :: Int -> Int
o oo :: Int
oo = Int
oo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str
        c :: String -> Int -> String
c oc :: String
oc oo :: Int
oo | Int
oo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= String -> 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 (f :: String
f,ss :: 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' f :: String -> String
f = 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
$ IO (XP ()) -> StateT XPState IO (XP ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (XP ()) -> StateT XPState IO (XP ()))
-> IO (XP ()) -> StateT XPState IO (XP ())
forall a b. (a -> b) -> a -> b
$ (String -> XP ()) -> IO String -> IO (XP ())
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (String -> XP ()
insertString (String -> XP ()) -> (String -> String) -> String -> XP ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
f) IO String
forall (m :: * -> *). MonadIO m => m String
getSelection

-- | Remove a character at the cursor position
deleteString :: Direction1D -> XP ()
deleteString :: Direction1D -> XP ()
deleteString d :: 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
$ \s :: 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 :: Int
offset = Int -> Int
forall p. (Ord p, Num p) => p -> p
o (XPState -> Int
offset XPState
s)}
  where o :: p -> p
o oo :: p
oo = if Direction1D
d Direction1D -> Direction1D -> Bool
forall a. Eq a => a -> a -> Bool
== Direction1D
Prev then p -> p -> p
forall a. Ord a => a -> a -> a
max 0 (p
oo p -> p -> p
forall a. Num a => a -> a -> a
- 1) else p
oo
        c :: [a] -> Int -> [a]
c oc :: [a]
oc oo :: Int
oo
            | Int
oo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [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
- 1) [a]
oc
            | Int
oo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  [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
- 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 (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]
++ [a] -> [a]
forall a. [a] -> [a]
tail [a]
ss
            | Bool
otherwise = [a]
oc
            where (f :: [a]
f,ss :: [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
$ \s :: XPState
s -> XPState
s { offset :: Int
offset = Int -> String -> Int
forall (t :: * -> *) a. Foldable t => Int -> t a -> Int
o (XPState -> Int
offset XPState
s) (XPState -> String
command XPState
s)}
    where o :: Int -> t a -> Int
o oo :: Int
oo c :: 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 0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ 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
- 1) Int
oo

-- | Move the cursor one position.
moveCursor :: Direction1D -> XP ()
moveCursor :: Direction1D -> XP ()
moveCursor d :: 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
$ \s :: XPState
s -> XPState
s { offset :: Int
offset = Int -> String -> Int
forall (t :: * -> *) a. Foldable t => Int -> t a -> Int
o (XPState -> Int
offset XPState
s) (XPState -> String
command XPState
s)}
  where o :: Int -> t a -> Int
o oo :: Int
oo c :: 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 0 (Int
oo Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) else Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (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
+ 1)

-- | Move the cursor one position, but not beyond the command.
moveCursorClip :: Direction1D -> XP ()
moveCursorClip :: Direction1D -> XP ()
moveCursorClip = (XP () -> XP () -> XP ()
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' p :: Char -> Bool
p d :: 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 (f :: String
f,ss :: String
ss) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitOn Int
o String
c
      splitOn :: Int -> [a] -> ([a], [a])
splitOn n :: Int
n xs :: [a]
xs = (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) [a]
xs, Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
n [a]
xs)
      gap :: Int
gap = case Direction1D
d of
                Prev -> Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Int -> Int -> Int
forall a. Num a => a -> a -> a
- (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
c)
                Next -> 0
      len :: String -> Int
len = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 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 (-) 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 (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> (String -> Int) -> (String, String) -> (Int, Int)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (String -> 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
. (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
. (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break 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])
break (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
p)
      newoff :: Int
newoff = case Direction1D
d of
                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)
                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
$ \s :: XPState
s -> XPState
s { offset :: Int
offset = Int
newoff }

-- | Set the prompt's input to an entry further up or further down the history
-- stack. Use 'Stack' functions from 'XMonad.StackSet', i.e. 'focusUp'' or
-- 'focusDown''.
moveHistory :: (W.Stack String -> W.Stack String) -> XP ()
moveHistory :: (Stack String -> Stack String) -> XP ()
moveHistory f :: 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
$ \s :: 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 :: Stack String
commandHistory = Stack String
ch
                      , offset :: Int
offset         = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> String -> Int
forall a b. (a -> b) -> a -> b
$ Stack String -> String
forall a. Stack a -> a
W.focus Stack String
ch
                      , complIndex :: (Int, Int)
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 d :: Direction1D
d s :: String
s = Bool -> XP () -> XP ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) (XP () -> XP ()) -> XP () -> XP ()
forall a b. (a -> b) -> a -> b
$ 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 c :: Char
c = String -> Char
forall a. [a] -> a
head String
s
        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 b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
(***) (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 0 (Maybe Int -> Int) -> (String -> Maybe Int) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Int -> Int
forall a. Num a => a -> a -> a
+1) (Maybe Int -> Maybe Int)
-> (String -> Maybe Int) -> String -> Maybe 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 b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Int -> String -> String
forall a. Int -> [a] -> [a]
drop 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
$ \st :: XPState
st -> XPState
st { offset :: Int
offset = XPState -> Int
offset XPState
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
off' }

updateHighlightedCompl :: XP ()
updateHighlightedCompl :: XP ()
updateHighlightedCompl = do
  XPState
st <- StateT XPState IO XPState
forall s (m :: * -> *). MonadState s m => m s
get
  [String]
cs <- XP [String]
getCompletions
  Bool
alwaysHighlight' <- (XPState -> Bool) -> XP Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XPState -> Bool) -> XP Bool) -> (XPState -> Bool) -> XP 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
$ \s :: XPState
s -> XPState
s {highlightedCompl :: Maybe String
highlightedCompl = XPState -> [String] -> Maybe String
highlightedItem XPState
st [String]
cs}

-- X Stuff

updateWindows :: XP ()
updateWindows :: XP ()
updateWindows = 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
  [String]
c <- XP [String]
getCompletions
  case [String]
c  of
    [] -> XP ()
destroyComplWin XP () -> XP () -> XP ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> XP ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    l :: [String]
l  -> [String] -> XP ()
redrawComplWin [String]
l
  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

redrawWindows :: [String] -> XP ()
redrawWindows :: [String] -> XP ()
redrawWindows c :: [String]
c = 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
  case [String]
c of
    [] -> () -> XP ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    l :: [String]
l  -> [String] -> XP ()
redrawComplWin [String]
l
  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

createWin :: Display -> Window -> XPConfig -> Rectangle -> IO Window
createWin :: Display -> Window -> XPConfig -> Rectangle -> IO Window
createWin d :: Display
d rw :: Window
rw c :: XPConfig
c s :: Rectangle
s = do
  let (x :: Position
x,y :: Dimension
y) = case XPConfig -> XPPosition
position XPConfig
c of
                Top -> (0,0)
                Bottom -> (0, Rectangle -> Dimension
rect_height Rectangle
s Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- XPConfig -> Dimension
height XPConfig
c)
                CenteredAt py :: Rational
py w :: Rational
w -> (Rational -> Position
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 (Dimension -> Rational) -> Dimension -> Rational
forall a b. (a -> b) -> a -> b
$ Rectangle -> Dimension
rect_width Rectangle
s) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* ((1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
w) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ 2), Rational -> Dimension
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
s) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- (Dimension -> Rational
forall a b. (Integral a, Num b) => a -> b
fi (XPConfig -> Dimension
height XPConfig
c) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ 2))
      width :: Dimension
width = case XPConfig -> XPPosition
position XPConfig
c of
                CenteredAt _ w :: Rational
w -> Rational -> Dimension
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
s) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
w
                _              -> Rectangle -> Dimension
rect_width Rectangle
s
  Window
w <- Display
-> Screen
-> Window
-> Position
-> Position
-> Dimension
-> Dimension
-> IO Window
mkUnmanagedWindow Display
d (Display -> Screen
defaultScreenOfDisplay Display
d) Window
rw
                      (Rectangle -> Position
rect_x Rectangle
s Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
x) (Rectangle -> Position
rect_y Rectangle
s Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
y) Dimension
width (XPConfig -> Dimension
height XPConfig
c)
  Display -> Window -> IO ()
mapWindow Display
d Window
w
  Window -> IO Window
forall (m :: * -> *) a. Monad m => a -> m a
return Window
w

drawWin :: XP ()
drawWin :: XP ()
drawWin = do
  XPState
st <- StateT XPState IO XPState
forall s (m :: * -> *). MonadState s m => m s
get
  let (c :: XPConfig
c,(cr :: XPColor
cr,(d :: Display
d,(w :: Window
w,gc :: GC
gc)))) = (XPState -> XPConfig
config (XPState -> XPConfig)
-> (XPState -> (XPColor, (Display, (Window, GC))))
-> XPState
-> (XPConfig, (XPColor, (Display, (Window, GC))))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPState -> XPColor
color (XPState -> XPColor)
-> (XPState -> (Display, (Window, GC)))
-> XPState
-> (XPColor, (Display, (Window, GC)))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPState -> Display
dpy (XPState -> Display)
-> (XPState -> (Window, GC)) -> XPState -> (Display, (Window, GC))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPState -> Window
win (XPState -> Window) -> (XPState -> GC) -> XPState -> (Window, GC)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPState -> GC
gcon) XPState
st
      scr :: Screen
scr = Display -> Screen
defaultScreenOfDisplay Display
d
      wh :: Dimension
wh = case XPConfig -> XPPosition
position XPConfig
c of
             CenteredAt _ wd :: Rational
wd -> Rational -> Dimension
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> Dimension) -> Rational -> Dimension
forall a b. (a -> b) -> a -> b
$ Rational
wd Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Dimension -> Rational
forall a b. (Integral a, Num b) => a -> b
fi (Screen -> Dimension
widthOfScreen Screen
scr)
             _               -> Screen -> Dimension
widthOfScreen Screen
scr
      ht :: Dimension
ht = XPConfig -> Dimension
height XPConfig
c
      bw :: Dimension
bw = XPConfig -> Dimension
promptBorderWidth XPConfig
c
  Just bgcolor :: Window
bgcolor <- IO (Maybe Window) -> StateT XPState IO (Maybe Window)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe Window) -> StateT XPState IO (Maybe Window))
-> IO (Maybe Window) -> StateT XPState IO (Maybe Window)
forall a b. (a -> b) -> a -> b
$ Display -> String -> IO (Maybe Window)
initColor Display
d (XPColor -> String
bgNormal XPColor
cr)
  Just borderC :: Window
borderC <- IO (Maybe Window) -> StateT XPState IO (Maybe Window)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe Window) -> StateT XPState IO (Maybe Window))
-> IO (Maybe Window) -> StateT XPState IO (Maybe Window)
forall a b. (a -> b) -> a -> b
$ Display -> String -> IO (Maybe Window)
initColor Display
d (XPColor -> String
border XPColor
cr)
  Window
p <- IO Window -> StateT XPState IO Window
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Window -> StateT XPState IO Window)
-> IO Window -> StateT XPState IO Window
forall a b. (a -> b) -> a -> b
$ Display
-> Window -> Dimension -> Dimension -> GrabStatus -> IO Window
createPixmap Display
d Window
w Dimension
wh Dimension
ht
                         (Screen -> GrabStatus
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
-> Window
-> GC
-> Window
-> Window
-> Dimension
-> Dimension
-> Dimension
-> IO ()
fillDrawable Display
d Window
p GC
gc Window
borderC Window
bgcolor (Dimension -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Dimension
bw) Dimension
wh Dimension
ht
  Window -> XP ()
printPrompt Window
p
  IO () -> XP ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> XP ()) -> IO () -> XP ()
forall a b. (a -> b) -> a -> b
$ Display
-> Window
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> Position
-> Position
-> IO ()
copyArea Display
d Window
p Window
w GC
gc 0 0 Dimension
wh Dimension
ht 0 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 -> Window -> IO ()
freePixmap Display
d Window
p

printPrompt :: Drawable -> XP ()
printPrompt :: Window -> XP ()
printPrompt drw :: Window
drw = do
  XPState
st <- StateT XPState IO XPState
forall s (m :: * -> *). MonadState s m => m s
get
  let (pr :: String -> String
pr,(cr :: XPColor
cr,gc :: GC
gc)) = (XPState -> String -> String
prompter (XPState -> String -> String)
-> (XPState -> (XPColor, GC))
-> XPState
-> (String -> String, (XPColor, GC))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPState -> XPColor
color (XPState -> XPColor) -> (XPState -> GC) -> XPState -> (XPColor, GC)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPState -> GC
gcon) XPState
st
      (c :: XPConfig
c,(d :: Display
d,fs :: XMonadFont
fs)) = (XPState -> XPConfig
config (XPState -> XPConfig)
-> (XPState -> (Display, XMonadFont))
-> XPState
-> (XPConfig, (Display, XMonadFont))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPState -> Display
dpy (XPState -> Display)
-> (XPState -> XMonadFont) -> XPState -> (Display, XMonadFont)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPState -> XMonadFont
fontS) XPState
st
      (prt :: String
prt,(com :: String
com,off :: Int
off)) = (String -> String
pr (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, Int)) -> XPState -> (String, (String, Int))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPState -> String
command (XPState -> String) -> (XPState -> Int) -> XPState -> (String, Int)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPState -> Int
offset) 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
      (f :: String
f,p :: String
p,ss :: String
ss) = if Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
com
                 then (String
str, " ","") -- add a space: it will be our cursor ;-)
                 else let (a :: String
a,b :: String
b) = (Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
off String
com)
                      in (String
prt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a, [String -> Char
forall a. [a] -> a
head String
b], String -> String
forall a. [a] -> [a]
tail String
b)
      ht :: Dimension
ht = XPConfig -> Dimension
height XPConfig
c
  Int
fsl <- 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 (XPState -> Display
dpy XPState
st) XMonadFont
fs String
f
  Int
psl <- 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 (XPState -> Display
dpy XPState
st) XMonadFont
fs String
p
  (asc :: Position
asc,desc :: 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
str
  let y :: Position
y = 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` 2) Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+ Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi 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` 2

  let draw :: String -> String -> Position -> Position -> String -> XP ()
draw = Display
-> Window
-> XMonadFont
-> GC
-> String
-> String
-> Position
-> Position
-> String
-> XP ()
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Display
-> Window
-> XMonadFont
-> GC
-> String
-> String
-> Position
-> Position
-> String
-> m ()
printStringXMF Display
d Window
drw XMonadFont
fs GC
gc
  -- print the first part
  String -> String -> Position -> Position -> String -> XP ()
draw (XPColor -> String
fgNormal XPColor
cr) (XPColor -> String
bgNormal XPColor
cr) Position
x Position
y String
f
  -- reverse the colors and print the "cursor" ;-)
  String -> String -> Position -> Position -> String -> XP ()
draw (XPColor -> String
bgNormal XPColor
cr) (XPColor -> String
fgNormal XPColor
cr) (Position
x Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Int -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fsl) Position
y String
p
  -- reverse the colors and print the rest of the string
  String -> String -> Position -> Position -> String -> XP ()
draw (XPColor -> String
fgNormal XPColor
cr) (XPColor -> String
bgNormal XPColor
cr) (Position
x Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Int -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
fsl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
psl)) Position
y String
ss

-- get the current completion function depending on the active mode
getCompletionFunction :: XPState -> ComplFunction
getCompletionFunction :: XPState -> ComplFunction
getCompletionFunction st :: XPState
st = case XPState -> XPOperationMode
operationMode XPState
st of
  XPSingleMode compl :: ComplFunction
compl _ -> ComplFunction
compl
  XPMultipleModes modes :: 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

-- Completions
getCompletions :: XP [String]
getCompletions :: XP [String]
getCompletions = do
  XPState
s <- StateT XPState IO XPState
forall s (m :: * -> *). MonadState s m => m s
get
  let q :: String
q     = XPType -> String -> String
forall t. XPrompt t => t -> String -> String
commandToComplete (XPState -> XPType
currentXPMode XPState
s) (XPState -> String
command XPState
s)
      compl :: ComplFunction
compl = XPState -> ComplFunction
getCompletionFunction XPState
s
      srt :: String -> [String] -> [String]
srt   = XPConfig -> String -> [String] -> [String]
sorter (XPState -> XPConfig
config XPState
s)
  IO [String] -> XP [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [String] -> XP [String]) -> IO [String] -> XP [String]
forall a b. (a -> b) -> a -> b
$ (String -> [String] -> [String]
srt String
q ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ComplFunction
compl String
q) IO [String] -> (SomeException -> IO [String]) -> IO [String]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(SomeException _) -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []

setComplWin :: Window -> ComplWindowDim -> XP ()
setComplWin :: Window -> ComplWindowDim -> XP ()
setComplWin w :: Window
w wi :: ComplWindowDim
wi = do
  IORef (Maybe Window)
wr <- (XPState -> IORef (Maybe Window))
-> StateT XPState IO (IORef (Maybe Window))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> IORef (Maybe Window)
complWinRef
  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 Window) -> Maybe Window -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Window)
wr (Window -> Maybe Window
forall a. a -> Maybe a
Just Window
w)
  (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\s :: XPState
s -> XPState
s { complWin :: Maybe Window
complWin = Window -> Maybe Window
forall a. a -> Maybe a
Just Window
w, complWinDim :: Maybe ComplWindowDim
complWinDim = ComplWindowDim -> Maybe ComplWindowDim
forall a. a -> Maybe a
Just ComplWindowDim
wi })

destroyComplWin :: XP ()
destroyComplWin :: XP ()
destroyComplWin = do
  Display
d  <- (XPState -> Display) -> StateT XPState IO Display
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Display
dpy
  Maybe Window
cw <- (XPState -> Maybe Window) -> StateT XPState IO (Maybe Window)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> Maybe Window
complWin
  IORef (Maybe Window)
wr <- (XPState -> IORef (Maybe Window))
-> StateT XPState IO (IORef (Maybe Window))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets XPState -> IORef (Maybe Window)
complWinRef
  case Maybe Window
cw of
    Just w :: Window
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 -> Window -> IO ()
destroyWindow Display
d Window
w
                 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 Window) -> Maybe Window -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Window)
wr Maybe Window
forall a. Maybe a
Nothing
                 (XPState -> XPState) -> XP ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\s :: XPState
s -> XPState
s { complWin :: Maybe Window
complWin = Maybe Window
forall a. Maybe a
Nothing, complWinDim :: Maybe ComplWindowDim
complWinDim = Maybe ComplWindowDim
forall a. Maybe a
Nothing })
    Nothing -> () -> XP ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

type ComplWindowDim = (Position,Position,Dimension,Dimension,Columns,Rows)
type Rows = [Position]
type Columns = [Position]

createComplWin :: ComplWindowDim -> XP Window
createComplWin :: ComplWindowDim -> StateT XPState IO Window
createComplWin wi :: ComplWindowDim
wi@(x :: Position
x,y :: Position
y,wh :: Dimension
wh,ht :: Dimension
ht,_,_) = do
  XPState
st <- StateT XPState IO XPState
forall s (m :: * -> *). MonadState s m => m s
get
  let d :: Display
d = XPState -> Display
dpy XPState
st
      scr :: Screen
scr = Display -> Screen
defaultScreenOfDisplay Display
d
  Window
w <- IO Window -> StateT XPState IO Window
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Window -> StateT XPState IO Window)
-> IO Window -> StateT XPState IO Window
forall a b. (a -> b) -> a -> b
$ Display
-> Screen
-> Window
-> Position
-> Position
-> Dimension
-> Dimension
-> IO Window
mkUnmanagedWindow Display
d Screen
scr (XPState -> Window
rootw XPState
st)
                      Position
x Position
y Dimension
wh Dimension
ht
  IO () -> XP ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> XP ()) -> IO () -> XP ()
forall a b. (a -> b) -> a -> b
$ Display -> Window -> IO ()
mapWindow Display
d Window
w
  Window -> ComplWindowDim -> XP ()
setComplWin Window
w ComplWindowDim
wi
  Window -> StateT XPState IO Window
forall (m :: * -> *) a. Monad m => a -> m a
return Window
w

getComplWinDim :: [String] -> XP ComplWindowDim
getComplWinDim :: [String] -> XP ComplWindowDim
getComplWinDim compl :: [String]
compl = do
  XPState
st <- StateT XPState IO XPState
forall s (m :: * -> *). MonadState s m => m s
get
  let (c :: XPConfig
c,(scr :: Rectangle
scr,fs :: XMonadFont
fs)) = (XPState -> XPConfig
config (XPState -> XPConfig)
-> (XPState -> (Rectangle, XMonadFont))
-> XPState
-> (XPConfig, (Rectangle, XMonadFont))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPState -> Rectangle
screen (XPState -> Rectangle)
-> (XPState -> XMonadFont) -> XPState -> (Rectangle, XMonadFont)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XPState -> XMonadFont
fontS) XPState
st
      wh :: Dimension
wh = case XPConfig -> XPPosition
position XPConfig
c of
             CenteredAt _ w :: Rational
w -> Rational -> Dimension
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
w
             _ -> Rectangle -> Dimension
rect_width Rectangle
scr
      ht :: Dimension
ht = XPConfig -> Dimension
height XPConfig
c
      bw :: Dimension
bw = XPConfig -> Dimension
promptBorderWidth XPConfig
c

  [Int]
tws <- (String -> XP Int) -> [String] -> StateT XPState IO [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Display -> XMonadFont -> String -> XP Int
forall (m :: * -> *).
MonadIO m =>
Display -> XMonadFont -> String -> m Int
textWidthXMF (XPState -> Display
dpy XPState
st) XMonadFont
fs) [String]
compl
  let max_compl_len :: Position
max_compl_len =  Int -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((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` 2) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
tws)
      columns :: Dimension
columns = Dimension -> Dimension -> Dimension
forall a. Ord a => a -> a -> a
max 1 (Dimension -> Dimension) -> Dimension -> Dimension
forall a b. (a -> b) -> a -> b
$ Dimension
wh Dimension -> Dimension -> Dimension
forall a. Integral a => a -> a -> a
`div` Position -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Position
max_compl_len
      rem_height :: Dimension
rem_height =  Rectangle -> Dimension
rect_height Rectangle
scr Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
ht
      (rows :: Int
rows,r :: Int
r) = [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [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
      needed_rows :: Int
needed_rows = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 1 (Int
rows Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then 0 else 1)
      limit_max_number :: Dimension -> Dimension
limit_max_number = case XPConfig -> Maybe Dimension
maxComplRows XPConfig
c of
                           Nothing -> Dimension -> Dimension
forall a. a -> a
id
                           Just m :: Dimension
m -> Dimension -> Dimension -> Dimension
forall a. Ord a => a -> a -> a
min Dimension
m
      actual_max_number_of_rows :: Dimension
actual_max_number_of_rows = Dimension -> Dimension
limit_max_number (Dimension -> Dimension) -> Dimension -> Dimension
forall a b. (a -> b) -> a -> b
$ Dimension
rem_height Dimension -> Dimension -> Dimension
forall a. Integral a => a -> a -> a
`div` Dimension
ht
      actual_rows :: Dimension
actual_rows = Dimension -> Dimension -> Dimension
forall a. Ord a => a -> a -> a
min Dimension
actual_max_number_of_rows (Int -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Int
needed_rows)
      actual_height :: Dimension
actual_height = Dimension
actual_rows Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
* Dimension
ht
      (x :: Position
x,y :: Dimension
y) = case XPConfig -> XPPosition
position XPConfig
c of
                Top -> (0,Dimension
ht Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
bw)
                Bottom -> (0, (0 Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+ Dimension
rem_height Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
actual_height Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+ Dimension
bw))
                CenteredAt py :: Rational
py w :: Rational
w
                  | Rational
py Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= 1Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/2 -> (Rational -> Position
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
* ((1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
w) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ 2), Rational -> Dimension
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
/2) Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
bw)
                  | Bool
otherwise -> (Rational -> Position
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
* ((1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
w) Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ 2), Rational -> Dimension
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
/2) Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
- Dimension
actual_height Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+ Dimension
bw)
  (asc :: Position
asc,desc :: 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
$ [String] -> String
forall a. [a] -> a
head [String]
compl
  let yp :: Dimension
yp = Dimension -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi (Dimension -> Dimension) -> Dimension -> Dimension
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` 2
      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` 2
      yy :: Columns
yy = (Dimension -> Position) -> [Dimension] -> Columns
forall a b. (a -> b) -> [a] -> [b]
map Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi ([Dimension] -> Columns)
-> ([Dimension] -> [Dimension]) -> [Dimension] -> Columns
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Dimension] -> [Dimension]
forall a. Int -> [a] -> [a]
take (Dimension -> Int
forall a b. (Integral a, Num b) => a -> b
fi Dimension
actual_rows) ([Dimension] -> Columns) -> [Dimension] -> Columns
forall a b. (a -> b) -> a -> b
$ [Dimension
yp,(Dimension
yp Dimension -> Dimension -> Dimension
forall a. Num a => a -> a -> a
+ Dimension
ht)..]
      xx :: Columns
xx = Int -> Columns -> Columns
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
+ Position
max_compl_len)..]

  ComplWindowDim -> XP ComplWindowDim
forall (m :: * -> *) a. Monad m => a -> m a
return (Rectangle -> Position
rect_x Rectangle
scr Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
x, Rectangle -> Position
rect_y Rectangle
scr Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Dimension -> Position
forall a b. (Integral a, Num b) => a -> b
fi Dimension
y, Dimension
wh, Dimension
actual_height, Columns
xx, Columns
yy)

drawComplWin :: Window -> [String] -> XP ()
drawComplWin :: Window -> [String] -> XP ()
drawComplWin w :: Window
w compl :: [String]
compl = do
  XPState
st <- StateT XPState IO XPState
forall s (m :: * -> *). MonadState s m => m s
get
  let c :: XPConfig
c   = XPState -> XPConfig
config XPState
st
      cr :: XPColor
cr  = XPState -> XPColor
color XPState
st
      d :: Display
d   = XPState -> Display
dpy XPState
st
      scr :: Screen
scr = Display -> Screen
defaultScreenOfDisplay Display
d
      bw :: Dimension
bw  = XPConfig -> Dimension
promptBorderWidth XPConfig
c
      gc :: GC
gc  = XPState -> GC
gcon XPState
st
  Just bgcolor :: Window
bgcolor <- IO (Maybe Window) -> StateT XPState IO (Maybe Window)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe Window) -> StateT XPState IO (Maybe Window))
-> IO (Maybe Window) -> StateT XPState IO (Maybe Window)
forall a b. (a -> b) -> a -> b
$ Display -> String -> IO (Maybe Window)
initColor Display
d (XPColor -> String
bgNormal XPColor
cr)
  Just borderC :: Window
borderC <- IO (Maybe Window) -> StateT XPState IO (Maybe Window)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe Window) -> StateT XPState IO (Maybe Window))
-> IO (Maybe Window) -> StateT XPState IO (Maybe Window)
forall a b. (a -> b) -> a -> b
$ Display -> String -> IO (Maybe Window)
initColor Display
d (XPColor -> String
border XPColor
cr)

  (_,_,wh :: Dimension
wh,ht :: Dimension
ht,xx :: Columns
xx,yy :: Columns
yy) <- [String] -> XP ComplWindowDim
getComplWinDim [String]
compl

  Window
p <- IO Window -> StateT XPState IO Window
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Window -> StateT XPState IO Window)
-> IO Window -> StateT XPState IO Window
forall a b. (a -> b) -> a -> b
$ Display
-> Window -> Dimension -> Dimension -> GrabStatus -> IO Window
createPixmap Display
d Window
w Dimension
wh Dimension
ht
                         (Screen -> GrabStatus
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
-> Window
-> GC
-> Window
-> Window
-> Dimension
-> Dimension
-> Dimension
-> IO ()
fillDrawable Display
d Window
p GC
gc Window
borderC Window
bgcolor (Dimension -> Dimension
forall a b. (Integral a, Num b) => a -> b
fi Dimension
bw) Dimension
wh Dimension
ht
  let ac :: [[String]]
ac = Int -> [String] -> [[String]]
forall a. Int -> [a] -> [[a]]
splitInSubListsAt (Columns -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Columns
yy) (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take (Columns -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Columns
xx Int -> Int -> Int
forall a. Num a => a -> a -> a
* Columns -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Columns
yy) [String]
compl)

  Display
-> Window
-> GC
-> String
-> String
-> Columns
-> Columns
-> [[String]]
-> XP ()
printComplList Display
d Window
p GC
gc (XPColor -> String
fgNormal XPColor
cr) (XPColor -> String
bgNormal XPColor
cr) Columns
xx Columns
yy [[String]]
ac
  --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
-> Window
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> Position
-> Position
-> IO ()
copyArea Display
d Window
p Window
w GC
gc 0 0 Dimension
wh Dimension
ht 0 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 -> Window -> IO ()
freePixmap Display
d Window
p

redrawComplWin ::  [String] -> XP ()
redrawComplWin :: [String] -> XP ()
redrawComplWin compl :: [String]
compl = do
  XPState
st <- StateT XPState IO XPState
forall s (m :: * -> *). MonadState s m => m s
get
  ComplWindowDim
nwi <- [String] -> XP ComplWindowDim
getComplWinDim [String]
compl
  let recreate :: XP ()
recreate = do XP ()
destroyComplWin
                    Window
w <- ComplWindowDim -> StateT XPState IO Window
createComplWin ComplWindowDim
nwi
                    Window -> [String] -> XP ()
drawComplWin Window
w [String]
compl
  if [String]
compl [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] Bool -> Bool -> Bool
&& XPState -> Bool
showComplWin XPState
st
     then case XPState -> Maybe Window
complWin XPState
st of
            Just w :: Window
w -> case XPState -> Maybe ComplWindowDim
complWinDim XPState
st of
                        Just wi :: ComplWindowDim
wi -> if ComplWindowDim
nwi ComplWindowDim -> ComplWindowDim -> Bool
forall a. Eq a => a -> a -> Bool
== ComplWindowDim
wi -- complWinDim did not change
                                   then Window -> [String] -> XP ()
drawComplWin Window
w [String]
compl -- so update
                                   else XP ()
recreate
                        Nothing -> XP ()
recreate
            Nothing -> XP ()
recreate
     else XP ()
destroyComplWin

-- Finds the column and row indexes in which a string appears.
-- if the string is not in the matrix, the indexes default to (0,0)
findComplIndex :: String -> [[String]] -> (Int,Int)
findComplIndex :: String -> [[String]] -> (Int, Int)
findComplIndex x :: String
x xss :: [[String]]
xss = let
  colIndex :: Int
colIndex = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 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 (\cols :: [String]
cols -> String
x String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
cols) [[String]]
xss
  rowIndex :: Int
rowIndex = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 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
x ([String] -> Maybe Int) -> [String] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [[String]] -> Int -> [String]
forall a. [a] -> Int -> a
(!!) [[String]]
xss Int
colIndex
  in (Int
colIndex,Int
rowIndex)

printComplList :: Display -> Drawable -> GC -> String -> String
               -> [Position] -> [Position] -> [[String]] -> XP ()
printComplList :: Display
-> Window
-> GC
-> String
-> String
-> Columns
-> Columns
-> [[String]]
-> XP ()
printComplList d :: Display
d drw :: Window
drw gc :: GC
gc fc :: String
fc bc :: String
bc xs :: Columns
xs ys :: Columns
ys sss :: [[String]]
sss =
    (Position -> [String] -> XP ()) -> Columns -> [[String]] -> XP ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (\x :: Position
x ss :: [String]
ss ->
        (Position -> String -> XP ()) -> Columns -> [String] -> XP ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (\y :: Position
y item :: String
item -> do
            XPState
st <- StateT XPState IO XPState
forall s (m :: * -> *). MonadState s m => m s
get
            Bool
alwaysHlight <- (XPState -> Bool) -> XP Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((XPState -> Bool) -> XP Bool) -> (XPState -> Bool) -> XP 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
            let (f :: String
f,b :: String
b) = case Bool
alwaysHlight of
                  True -> -- default to the first item, the one in (0,0)
                    let
                      (colIndex :: Int
colIndex,rowIndex :: Int
rowIndex) = String -> [[String]] -> (Int, Int)
findComplIndex String
item [[String]]
sss
                    in -- assign some colors
                     if ((XPState -> (Int, Int)
complIndex XPState
st) (Int, Int) -> (Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
colIndex,Int
rowIndex))
                     then (XPColor -> String
fgHighlight (XPColor -> String) -> XPColor -> String
forall a b. (a -> b) -> a -> b
$ XPState -> XPColor
color XPState
st,XPColor -> String
bgHighlight (XPColor -> String) -> XPColor -> String
forall a b. (a -> b) -> a -> b
$ XPState -> XPColor
color XPState
st)
                     else (String
fc,String
bc)
                  False ->
                    -- compare item with buffer's value
                    if 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)
                    then (XPColor -> String
fgHighlight (XPColor -> String) -> XPColor -> String
forall a b. (a -> b) -> a -> b
$ XPState -> XPColor
color XPState
st,XPColor -> String
bgHighlight (XPColor -> String) -> XPColor -> String
forall a b. (a -> b) -> a -> b
$ XPState -> XPColor
color XPState
st)
                    else (String
fc,String
bc)
            Display
-> Window
-> XMonadFont
-> GC
-> String
-> String
-> Position
-> Position
-> String
-> XP ()
forall (m :: * -> *).
(Functor m, MonadIO m) =>
Display
-> Window
-> XMonadFont
-> GC
-> String
-> String
-> Position
-> Position
-> String
-> m ()
printStringXMF Display
d Window
drw (XPState -> XMonadFont
fontS XPState
st) GC
gc String
f String
b Position
x Position
y String
item)
        Columns
ys [String]
ss) Columns
xs [[String]]
sss

-- History

type History = M.Map String [String]

emptyHistory :: History
emptyHistory :: History
emptyHistory = History
forall k a. Map k a
M.empty

getHistoryFile :: IO FilePath
getHistoryFile :: IO String
getHistoryFile = (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/prompt-history") IO String
forall (m :: * -> *). MonadIO m => m String
getXMonadCacheDir

readHistory :: IO History
readHistory :: IO History
readHistory = IO History
readHist IO History -> (SomeException -> IO History) -> IO History
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(SomeException _) -> History -> IO History
forall (m :: * -> *) a. Monad m => a -> m a
return History
emptyHistory
 where
    readHist :: IO History
readHist = do
        String
path <- IO String
getHistoryFile
        String
xs <- IO Handle
-> (Handle -> IO ()) -> (Handle -> IO String) -> IO String
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IOMode -> IO Handle
openFile String
path IOMode
ReadMode) Handle -> IO ()
hClose Handle -> IO String
hGetLine
        String -> IO History
forall a. Read a => String -> IO a
readIO String
xs

writeHistory :: History -> IO ()
writeHistory :: History -> IO ()
writeHistory hist :: History
hist = do
  String
path <- IO String
getHistoryFile
  let filtered :: History
filtered = ([String] -> Bool) -> History -> History
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 (t :: * -> *) a. Foldable t => t a -> Bool
null) History
hist
  String -> String -> IO ()
writeFile String
path (History -> String
forall a. Show a => a -> String
show History
filtered) IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \(SomeException e :: e
e) ->
                          Handle -> String -> IO ()
hPutStrLn Handle
stderr ("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
-> Window
-> GC
-> Window
-> Window
-> Dimension
-> Dimension
-> Dimension
-> IO ()
fillDrawable d :: Display
d drw :: Window
drw gc :: GC
gc borderC :: Window
borderC bgcolor :: Window
bgcolor bw :: Dimension
bw wh :: Dimension
wh ht :: Dimension
ht = do
  -- we start with the border
  Display -> GC -> Window -> IO ()
setForeground Display
d GC
gc Window
borderC
  Display
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> IO ()
fillRectangle Display
d Window
drw GC
gc 0 0 Dimension
wh Dimension
ht
  -- here foreground means the background of the text
  Display -> GC -> Window -> IO ()
setForeground Display
d GC
gc Window
bgcolor
  Display
-> Window
-> GC
-> Position
-> Position
-> Dimension
-> Dimension
-> IO ()
fillRectangle Display
d Window
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
* 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
* 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
-> Window
-> Position
-> Position
-> Dimension
-> Dimension
-> IO Window
mkUnmanagedWindow d :: Display
d s :: Screen
s rw :: Window
rw x :: Position
x y :: Position
y w :: Dimension
w h :: Dimension
h = do
  let visual :: Visual
visual = Screen -> Visual
defaultVisualOfScreen Screen
s
      attrmask :: Window
attrmask = Window
cWOverrideRedirect
  (Ptr SetWindowAttributes -> IO Window) -> IO Window
forall a. (Ptr SetWindowAttributes -> IO a) -> IO a
allocaSetWindowAttributes ((Ptr SetWindowAttributes -> IO Window) -> IO Window)
-> (Ptr SetWindowAttributes -> IO Window) -> IO Window
forall a b. (a -> b) -> a -> b
$
         \attributes :: Ptr SetWindowAttributes
attributes -> do
           Ptr SetWindowAttributes -> Bool -> IO ()
set_override_redirect Ptr SetWindowAttributes
attributes Bool
True
           Display
-> Window
-> Position
-> Position
-> Dimension
-> Dimension
-> GrabStatus
-> GrabStatus
-> GrabStatus
-> Visual
-> Window
-> Ptr SetWindowAttributes
-> IO Window
createWindow Display
d Window
rw Position
x Position
y Dimension
w Dimension
h 0 (Screen -> GrabStatus
defaultDepthOfScreen Screen
s)
                        GrabStatus
inputOutput Visual
visual Window
attrmask Ptr SetWindowAttributes
attributes

-- $utils

-- | This function takes a list of possible completions and returns a
-- completions function to be used with 'mkXPrompt'
mkComplFunFromList :: [String] -> String -> IO [String]
mkComplFunFromList :: [String] -> ComplFunction
mkComplFunFromList _ [] = [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
mkComplFunFromList l :: [String]
l s :: String
s =
  [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\x :: String
x -> Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== 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' :: [String] -> String -> IO [String]
mkComplFunFromList' :: [String] -> ComplFunction
mkComplFunFromList' l :: [String]
l [] = [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
l
mkComplFunFromList' l :: [String]
l s :: String
s =
  [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\x :: String
x -> Int -> String -> String
forall a. Int -> [a] -> [a]
take (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== 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 :: t -> String -> [String] -> String
getNextOfLastWord t :: t
t c :: String
c l :: [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. [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 i :: Int
i -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1 then 0 else Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
                 Nothing -> 0

-- | An alternative 'nextCompletion' implementation: given a command
-- and a completion list, get the next completion in the list matching
-- the whole command line.
getNextCompletion :: String -> [String] -> String
getNextCompletion :: String -> [String] -> String
getNextCompletion c :: String
c l :: [String]
l = [String]
l [String] -> Int -> String
forall a. [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 i :: Int
i  -> if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1 then 0 else Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
                  Nothing -> 0

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

-- | 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 s :: String
s
    | " \\" 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
forall a. [a] -> [a] -> [a]
++ String
s1', String
s2')
    | Bool
otherwise = (String
s1, String
s2)
      where (s1 :: String
s1, s2 :: String
s2 ) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace String
s
            (s1' :: String
s1',s2' :: String
s2') = String -> (String, String)
breakAtSpace (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
tail 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 :: ComplFunction
historyCompletion :: ComplFunction
historyCompletion = (String -> Bool) -> 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) -> ComplFunction
historyCompletionP :: (String -> Bool) -> ComplFunction
historyCompletionP p :: String -> Bool
p x :: String
x = (History -> [String]) -> IO History -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (History -> [String]
forall k. Map k [String] -> [String]
toComplList (History -> [String])
-> (History -> History) -> History -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> Bool) -> History -> History
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)) IO History
readHistory
    where 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]
(++) []

-- | Sort a list and remove duplicates. Like 'deleteAllDuplicates', but trades off
--   laziness and stability for efficiency.
uniqSort :: Ord a => [a] -> [a]
uniqSort :: [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 [String] -> String
forall a. [a] -> a
head ([[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

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 :: 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 (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 ref :: IORef ([String], Maybe (Stack String))
ref) next :: Stack String -> Stack String
next = do
  (completed :: [String]
completed,completions :: 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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
completed
     then case Maybe (Stack String)
completions of
            Just cs :: 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
$ \s :: XPState
s -> XPState
s { offset :: Int
offset = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
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)
            Nothing -> () -> XP ()
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 prefix :: 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 hm :: 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 hm :: HistoryMatches
hm = HistoryMatches -> (Stack String -> Stack String) -> XP ()
historyNextMatching HistoryMatches
hm Stack String -> Stack String
forall a. Stack a -> Stack a
W.focusUp'