module System.Console.Haskeline.LineState where
class LineState s where
beforeCursor :: String -> s -> String -- text to left of cursor
afterCursor :: s -> String -- text under and to right of cursor
isTemporary :: s -> Bool
isTemporary _ = False
type LineChars = (String,String)
lineChars :: LineState s => String -> s -> LineChars
lineChars prefix s = (beforeCursor prefix s, afterCursor s)
lengthToEnd :: LineChars -> Int
lengthToEnd = length . snd
class LineState s => Result s where
toResult :: s -> String
class (Result s) => FromString s where
fromString :: String -> s
class Move s where
goLeft, goRight, moveToStart, moveToEnd :: s -> s
data InsertMode = IMode String String
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) = reverse xs ++ ys
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) []
instance FromString InsertMode where
fromString s = IMode (reverse s) []
emptyIM :: InsertMode
emptyIM = IMode "" ""
insertChar :: Char -> InsertMode -> InsertMode
insertChar c (IMode xs ys) = IMode (c:xs) ys
insertString :: String -> InsertMode -> InsertMode
insertString s (IMode xs ys) = IMode (reverse 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 xs
in IMode zs (reverse ws ++ ys)
skipRight f (IMode xs ys) = let (ws,zs) = span f ys
in IMode (reverse ws ++ xs) zs
data CommandMode = CMode String Char String | 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) = reverse xs ++ (c:ys)
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
instance FromString CommandMode where
fromString s = case reverse s of
[] -> CEmpty
(c:cs) -> CMode cs c []
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 _ ys) = CMode xs c ys
replaceChar _ CEmpty = CEmpty
------------------------
-- 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
data ArgMode s = ArgMode {arg :: Int, argState :: s}
instance Functor ArgMode where
fmap f (ArgMode n s) = ArgMode n (f s)
instance LineState s => LineState (ArgMode s) where
beforeCursor _ am = beforeCursor ("(arg: " ++ show (arg am) ++ ") ")
(argState am)
afterCursor = afterCursor . argState
instance Result s => Result (ArgMode s) where
toResult = toResult . argState
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) (argState am)
where
repeatN n | n <= 1 = f
| otherwise = f . repeatN (n-1)
---------------
data Cleared = Cleared
instance LineState Cleared where
beforeCursor _ Cleared = ""
afterCursor Cleared = ""
data Message s = Message {messageState :: s, messageText :: String}
instance LineState s => LineState (Message s) where
beforeCursor _ = messageText
afterCursor _ = ""
isTemporary _ = True
-----------------
deleteFromDiff :: InsertMode -> InsertMode -> InsertMode
deleteFromDiff (IMode xs1 ys1) (IMode xs2 ys2)
| length xs1 < length xs2 = IMode xs1 ys2
| otherwise = IMode xs2 ys1
deleteFromMove :: (InsertMode -> InsertMode) -> InsertMode -> InsertMode
deleteFromMove f = \x -> deleteFromDiff x (f x)