{- | 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) --------------- -- TODO: messageState param not needed anymore. data Message s = Message {messageState :: s, messageText :: String} instance LineState (Message s) 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)