haskeline-0.7.2.0: System/Console/Haskeline/LineState.hs
{- |
This module contains the various datatypes which model the state of the line; that is, the characters displayed and the position of the cursor.
-}
module System.Console.Haskeline.LineState(
-- * Graphemes
Grapheme(),
baseChar,
stringToGraphemes,
graphemesToString,
modifyBaseChar,
mapBaseChars,
-- * Line State class
LineState(..),
Prefix,
-- ** Convenience functions for the drawing backends
LineChars,
lineChars,
lengthToEnd,
-- ** Supplementary classes
Result(..),
Save(..),
listSave,
listRestore,
Move(..),
-- * Instances
-- ** InsertMode
InsertMode(..),
emptyIM,
insertChar,
insertString,
replaceCharIM,
insertGraphemes,
deleteNext,
deletePrev,
skipLeft,
skipRight,
transposeChars,
-- *** Moving to word boundaries
goRightUntil,
goLeftUntil,
atStart,
atEnd,
beforeChar,
afterChar,
overChar,
-- ** CommandMode
CommandMode(..),
deleteChar,
replaceChar,
pasteGraphemesBefore,
pasteGraphemesAfter,
-- *** Transitioning between modes
enterCommandMode,
enterCommandModeRight,
insertFromCommandMode,
appendFromCommandMode,
withCommandMode,
-- ** ArgMode
ArgMode(..),
startArg,
addNum,
applyArg,
applyCmdArg,
-- ** Other line state types
Message(..),
Password(..),
addPasswordChar,
deletePasswordChar,
) where
import Data.Char
-- | A 'Grapheme' is a fundamental unit of display for the UI. Several characters in sequence
-- can represent one grapheme; for example, an @a@ followed by the diacritic @\'\\768\'@ should
-- be treated as one unit.
data Grapheme = Grapheme {gBaseChar :: Char,
combiningChars :: [Char]}
deriving Eq
instance Show Grapheme where
show g = show (gBaseChar g : combiningChars g)
baseChar :: Grapheme -> Char
baseChar = gBaseChar
modifyBaseChar :: (Char -> Char) -> Grapheme -> Grapheme
modifyBaseChar f g = g {gBaseChar = f (gBaseChar g)}
mapBaseChars :: (Char -> Char) -> [Grapheme] -> [Grapheme]
mapBaseChars f = map (modifyBaseChar f)
-- | Create a 'Grapheme' from a single base character.
--
-- NOTE: Careful, don't use outside this module; and inside, make sure this is only
-- ever called on non-combining characters.
baseGrapheme :: Char -> Grapheme
baseGrapheme c = Grapheme {gBaseChar = c, combiningChars = []}
-- | Add a combining character to the given 'Grapheme'.
addCombiner :: Grapheme -> Char -> Grapheme
addCombiner g c = g {combiningChars = combiningChars g ++ [c]}
isCombiningChar :: Char -> Bool
isCombiningChar c = generalCategory c == NonSpacingMark
-- | Converts a string into a sequence of graphemes.
--
-- NOTE: Drops any initial, unattached combining characters.
stringToGraphemes :: String -> [Grapheme]
stringToGraphemes = mkString . dropWhile isCombiningChar
where
mkString [] = []
-- Minor hack: "\ESC...\STX" or "\SOH\ESC...\STX", where "\ESC..." is some
-- control sequence (e.g., ANSI colors), is represented as a grapheme
-- of zero length with '\ESC' as the base character.
-- Note that this won't round-trip correctly with graphemesToString.
-- In practice, however, that's fine since control characters can only occur
-- in the prompt.
mkString ('\SOH':cs) = stringToGraphemes cs
mkString ('\ESC':cs) | (ctrl,'\STX':rest) <- break (=='\STX') cs
= Grapheme '\ESC' ctrl : stringToGraphemes rest
mkString (c:cs) = Grapheme c (takeWhile isCombiningChar cs)
: mkString (dropWhile isCombiningChar cs)
graphemesToString :: [Grapheme] -> String
graphemesToString = concatMap (\g -> (baseChar g : combiningChars g))
-- | This class abstracts away the internal representations of the line state,
-- for use by the drawing actions. Line state is generally stored in a zipper format.
class LineState s where
beforeCursor :: Prefix -- ^ The input prefix.
-> s -- ^ The current line state.
-> [Grapheme] -- ^ The text to the left of the cursor
-- (including the prefix).
afterCursor :: s -> [Grapheme] -- ^ The text under and to the right of the cursor.
type Prefix = [Grapheme]
-- | The characters in the line (with the cursor in the middle). NOT in a zippered format;
-- both lists are in the order left->right that appears on the screen.
type LineChars = ([Grapheme],[Grapheme])
-- | Accessor function for the various backends.
lineChars :: LineState s => Prefix -> s -> LineChars
lineChars prefix s = (beforeCursor prefix s, afterCursor s)
-- | Compute the number of characters under and to the right of the cursor.
lengthToEnd :: LineChars -> Int
lengthToEnd = length . snd
class LineState s => Result s where
toResult :: s -> String
class LineState s => Save s where
save :: s -> InsertMode
restore :: InsertMode -> s
listSave :: Save s => s -> [Grapheme]
listSave s = case save s of IMode xs ys -> reverse xs ++ ys
listRestore :: Save s => [Grapheme] -> s
listRestore xs = restore $ IMode (reverse xs) []
class Move s where
goLeft, goRight, moveToStart, moveToEnd :: s -> s
-- | The standard line state representation; considers the cursor to be located
-- between two characters. The first list is reversed.
data InsertMode = IMode [Grapheme] [Grapheme]
deriving (Show, Eq)
instance LineState InsertMode where
beforeCursor prefix (IMode xs _) = prefix ++ reverse xs
afterCursor (IMode _ ys) = ys
instance Result InsertMode where
toResult (IMode xs ys) = graphemesToString $ reverse xs ++ ys
instance Save InsertMode where
save = id
restore = id
instance Move InsertMode where
goLeft im@(IMode [] _) = im
goLeft (IMode (x:xs) ys) = IMode xs (x:ys)
goRight im@(IMode _ []) = im
goRight (IMode ys (x:xs)) = IMode (x:ys) xs
moveToStart (IMode xs ys) = IMode [] (reverse xs ++ ys)
moveToEnd (IMode xs ys) = IMode (reverse ys ++ xs) []
emptyIM :: InsertMode
emptyIM = IMode [] []
-- | Insert one character, which may be combining, to the left of the cursor.
--
insertChar :: Char -> InsertMode -> InsertMode
insertChar c im@(IMode xs ys)
| isCombiningChar c = case xs of
[] -> im -- drop a combining character if it
-- appears at the start of the line.
z:zs -> IMode (addCombiner z c : zs) ys
| otherwise = IMode (baseGrapheme c : xs) ys
-- | Insert a sequence of characters to the left of the cursor.
insertString :: String -> InsertMode -> InsertMode
insertString s (IMode xs ys) = IMode (reverse (stringToGraphemes s) ++ xs) ys
deleteNext, deletePrev :: InsertMode -> InsertMode
deleteNext im@(IMode _ []) = im
deleteNext (IMode xs (_:ys)) = IMode xs ys
deletePrev im@(IMode [] _) = im
deletePrev (IMode (_:xs) ys) = IMode xs ys
skipLeft, skipRight :: (Char -> Bool) -> InsertMode -> InsertMode
skipLeft f (IMode xs ys) = let (ws,zs) = span (f . baseChar) xs
in IMode zs (reverse ws ++ ys)
skipRight f (IMode xs ys) = let (ws,zs) = span (f . baseChar) ys
in IMode (reverse ws ++ xs) zs
transposeChars :: InsertMode -> InsertMode
transposeChars (IMode (x:xs) (y:ys)) = IMode (x:y:xs) ys
transposeChars (IMode (y:x:xs) []) = IMode (x:y:xs) []
transposeChars im = im
insertGraphemes :: [Grapheme] -> InsertMode -> InsertMode
insertGraphemes s (IMode xs ys) = IMode (reverse s ++ xs) ys
-- For the 'R' command.
replaceCharIM :: Char -> InsertMode -> InsertMode
replaceCharIM c im
| isCombiningChar c = case im of
IMode [] [] -> im
IMode [] (y:ys) -> IMode [] (addCombiner y c:ys)
IMode (x:xs) ys -> IMode (addCombiner x c:xs) ys
| otherwise = let g = baseGrapheme c
in case im of
IMode xs [] -> IMode (g:xs) []
IMode xs (_:ys) -> IMode (g:xs) ys
-- | Used by vi mode. Considers the cursor to be located over some specific character.
-- The first list is reversed.
data CommandMode = CMode [Grapheme] Grapheme [Grapheme] | CEmpty
deriving Show
instance LineState CommandMode where
beforeCursor prefix CEmpty = prefix
beforeCursor prefix (CMode xs _ _) = prefix ++ reverse xs
afterCursor CEmpty = []
afterCursor (CMode _ c ys) = c:ys
instance Result CommandMode where
toResult CEmpty = ""
toResult (CMode xs c ys) = graphemesToString $ reverse xs ++ (c:ys)
instance Save CommandMode where
save = insertFromCommandMode
restore = enterCommandModeRight
instance Move CommandMode where
goLeft (CMode (x:xs) c ys) = CMode xs x (c:ys)
goLeft cm = cm
goRight (CMode xs c (y:ys)) = CMode (c:xs) y ys
goRight cm = cm
moveToStart (CMode xs c ys) = let zs = reverse xs ++ (c:ys) in CMode [] (head zs) (tail zs)
moveToStart CEmpty = CEmpty
moveToEnd (CMode xs c ys) = let zs = reverse ys ++ (c:xs) in CMode (tail zs) (head zs) []
moveToEnd CEmpty = CEmpty
deleteChar :: CommandMode -> CommandMode
deleteChar (CMode xs _ (y:ys)) = CMode xs y ys
deleteChar (CMode (x:xs) _ []) = CMode xs x []
deleteChar _ = CEmpty
replaceChar :: Char -> CommandMode -> CommandMode
replaceChar c (CMode xs d ys)
| not (isCombiningChar c) = CMode xs (baseGrapheme c) ys
| otherwise = CMode xs (addCombiner d c) ys
replaceChar _ CEmpty = CEmpty
pasteGraphemesBefore, pasteGraphemesAfter :: [Grapheme] -> CommandMode -> CommandMode
pasteGraphemesBefore [] = id
pasteGraphemesBefore s = enterCommandMode . insertGraphemes s . insertFromCommandMode
pasteGraphemesAfter [] = id
pasteGraphemesAfter s = enterCommandMode . insertGraphemes s . appendFromCommandMode
------------------------
-- Transitioning between modes
enterCommandMode, enterCommandModeRight :: InsertMode -> CommandMode
enterCommandMode (IMode (x:xs) ys) = CMode xs x ys
enterCommandMode (IMode [] (y:ys)) = CMode [] y ys
enterCommandMode _ = CEmpty
enterCommandModeRight (IMode xs (y:ys)) = CMode xs y ys
enterCommandModeRight (IMode (x:xs) []) = CMode xs x []
enterCommandModeRight _ = CEmpty
insertFromCommandMode, appendFromCommandMode :: CommandMode -> InsertMode
insertFromCommandMode CEmpty = emptyIM
insertFromCommandMode (CMode xs c ys) = IMode xs (c:ys)
appendFromCommandMode CEmpty = emptyIM
appendFromCommandMode (CMode xs c ys) = IMode (c:xs) ys
withCommandMode :: (InsertMode -> InsertMode) -> CommandMode -> CommandMode
withCommandMode f = enterCommandModeRight . f . insertFromCommandMode
----------------------
-- Supplementary modes
-- | Used for commands which take an integer argument.
data ArgMode s = ArgMode {arg :: Int, argState :: s}
instance Functor ArgMode where
fmap f am = am {argState = f (argState am)}
instance LineState s => LineState (ArgMode s) where
beforeCursor _ am = let pre = map baseGrapheme $ "(arg: " ++ show (arg am) ++ ") "
in beforeCursor pre (argState am)
afterCursor = afterCursor . argState
instance Result s => Result (ArgMode s) where
toResult = toResult . argState
instance Save s => Save (ArgMode s) where
save = save . argState
restore = startArg 0 . restore
startArg :: Int -> s -> ArgMode s
startArg = ArgMode
addNum :: Int -> ArgMode s -> ArgMode s
addNum n am
| arg am >= 1000 = am -- shouldn't ever need more than 4 digits
| otherwise = am {arg = arg am * 10 + n}
-- todo: negatives
applyArg :: (s -> s) -> ArgMode s -> s
applyArg f am = repeatN (arg am) f (argState am)
repeatN :: Int -> (a -> a) -> a -> a
repeatN n f | n <= 1 = f
| otherwise = f . repeatN (n-1) f
applyCmdArg :: (InsertMode -> InsertMode) -> ArgMode CommandMode -> CommandMode
applyCmdArg f am = withCommandMode (repeatN (arg am) f) (argState am)
---------------
newtype Message = Message {messageText :: String}
instance LineState Message where
beforeCursor _ = stringToGraphemes . messageText
afterCursor _ = []
----------------
data Password = Password {passwordState :: [Char], -- ^ reversed
passwordChar :: Maybe Char}
instance LineState Password where
beforeCursor prefix p
= prefix ++ (stringToGraphemes
$ case passwordChar p of
Nothing -> []
Just c -> replicate (length $ passwordState p) c)
afterCursor _ = []
instance Result Password where
toResult = reverse . passwordState
addPasswordChar :: Char -> Password -> Password
addPasswordChar c p = p {passwordState = c : passwordState p}
deletePasswordChar :: Password -> Password
deletePasswordChar (Password (_:cs) m) = Password cs m
deletePasswordChar p = p
-----------------
atStart, atEnd :: (Char -> Bool) -> InsertMode -> Bool
atStart f (IMode (x:_) (y:_)) = not (f (baseChar x)) && f (baseChar y)
atStart _ _ = False
atEnd f (IMode _ (y1:y2:_)) = f (baseChar y1) && not (f (baseChar y2))
atEnd _ _ = False
overChar, beforeChar, afterChar :: (Char -> Bool) -> InsertMode -> Bool
overChar f (IMode _ (y:_)) = f (baseChar y)
overChar _ _ = False
beforeChar f (IMode _ (_:y:_)) = f (baseChar y)
beforeChar _ _ = False
afterChar f (IMode (x:_) _) = f (baseChar x)
afterChar _ _ = False
goRightUntil, goLeftUntil :: (InsertMode -> Bool) -> InsertMode -> InsertMode
goRightUntil f = loop . goRight
where
loop im@(IMode _ ys) | null ys || f im = im
| otherwise = loop (goRight im)
goLeftUntil f = loop . goLeft
where
loop im@(IMode xs _) | null xs || f im = im
| otherwise = loop (goLeft im)