summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--Buffer/Class.hs3
-rw-r--r--Buffer/Motion.hs14
-rw-r--r--Main.hs50
3 files changed, 49 insertions, 18 deletions
diff --git a/Buffer/Class.hs b/Buffer/Class.hs
index 8f8bb75..75664a5 100644
--- a/Buffer/Class.hs
+++ b/Buffer/Class.hs
@@ -1,10 +1,13 @@
-- TODO Class is a lie
module Buffer.Class where
+
type Buffer = (String, String)
+emptyBuffer :: Buffer
emptyBuffer = ("", "")
+
-- TODO instance Show Buffer (w/newtype Buffer) (?)
showBuffer :: Buffer -> String
showBuffer (lhs, rhs) = lhs ++ rhs
diff --git a/Buffer/Motion.hs b/Buffer/Motion.hs
index 86446e0..fa9e059 100644
--- a/Buffer/Motion.hs
+++ b/Buffer/Motion.hs
@@ -25,21 +25,33 @@ data LeftRightMotion
| WordsBackward Int
deriving (Show)
+
-- TODO fail if cannot splitAt properly OR if we didn't modify the buffer
+gotoLeft :: Int -> Buffer -> Buffer
gotoLeft i (ls, rs) =
let (lls, rls) = splitAt (length ls - i) ls in (lls, rls ++ rs)
+
-- TODO fail if cannot splitAt properly OR if we didn't modify the buffer
+gotoRight :: Int -> Buffer -> Buffer
gotoRight i (ls, rs) =
let (lrs, rrs) = splitAt i rs in (ls ++ lrs, rrs)
+
+gotoFirstChar :: Buffer -> Buffer
gotoFirstChar (ls, rs) = ("", ls ++ rs)
+
+gotoEndOfLine :: Buffer -> Buffer
gotoEndOfLine (ls, rs) = (ls ++ rs, "")
+
-- TODO fail if i <= 0 or i > length
+gotoColumn :: Int -> Buffer -> Buffer
gotoColumn i (ls, rs) = splitAt (i - 1) $ ls ++ rs
+
+wordsForward :: Int -> Buffer -> Buffer
wordsForward i (ls, rs) =
let rs' = dropWhile (==' ') $ dropWhile (/=' ') rs
ls' = ls ++ take (length rs - length rs') rs
@@ -49,6 +61,8 @@ wordsForward i (ls, rs) =
then wordsForward (i - 1) b'
else b'
+
+wordsBackward :: Int -> Buffer -> Buffer
wordsBackward i (ls, rs) =
let ls' = dropWhileEnd (/=' ') $ dropWhileEnd (==' ') ls
rs' = drop (length ls') ls ++ rs
diff --git a/Main.hs b/Main.hs
index a055950..8611342 100644
--- a/Main.hs
+++ b/Main.hs
@@ -3,7 +3,6 @@ module Main where
import Control.Applicative
import Control.Concurrent
-import Control.Concurrent.MVar
import Control.Monad
import Data.Char
import Data.IORef
@@ -40,8 +39,6 @@ main = do
hSetEcho stdin False
hSetBuffering stdin NoBuffering
- tid <- myThreadId
-
-- WINCH
-- TODO installHandler 28 (Catch $ ioctl 0 ...) Nothing
@@ -53,10 +50,10 @@ main = do
lockRef <- newMVar ()
qRef <- newIORef st
- let putState = writeIORef qRef -- TODO atomicModifyIORef (?)
- getState = readIORef qRef
- withOutput a = do
- q <- getState
+ let _putState = writeIORef qRef -- TODO atomicModifyIORef (?)
+ _getState = readIORef qRef
+ _withOutput a = do
+ q <- _getState
withMVar lockRef $ \ _ -> do
clearLine
a
@@ -64,21 +61,21 @@ main = do
hFlush stdout
let cf = VTConfig
- { withOutput = withOutput
+ { withOutput = _withOutput
}
-- render initial input line
- withOutput $ return ()
+ _withOutput $ return ()
- forkIO $ dateThread withOutput 1000000
+ forkIO $ dateThread _withOutput 1000000
- uiThread cf putState getState
+ uiThread cf _putState _getState
dateThread :: (IO () -> IO ()) -> Int -> IO ()
-dateThread withOutput delay = forever $ do
+dateThread _withOutput delay = forever $ do
t <- liftIO getCurrentTime
- withOutput $
+ _withOutput $
putStrLn $ formatTime defaultTimeLocale rfc822DateFormat t
threadDelay delay
@@ -87,7 +84,7 @@ uiThread :: VTConfig -> (VTState -> IO ()) -> IO VTState -> IO ()
uiThread cf putState getState = forever $ do
q0 <- getState
- ((eitCmd, lines), q1) <- runVT cf q0 $ do
+ ((eitCmd, lns), q1) <- runVT cf q0 $ do
c <- getCommand (mode q0)
execCommand c
return c
@@ -106,7 +103,7 @@ uiThread cf putState getState = forever $ do
Nothing
withOutput cf $ do
- forM_ lines putStrLn
+ forM_ lns putStrLn
case mbErr of
Just err -> ringBell >> putStrLn (prettyError err)
@@ -202,6 +199,7 @@ runVT cf st (VT a) =
+insertString :: String -> Buffer -> Buffer
insertString s (ls, rs) = (ls ++ s, rs)
@@ -293,6 +291,7 @@ execCommand Nop = return ()
execCommand RingBell = liftIO ringBell
+reform :: Int -> Char -> String
reform colorCode c =
if isPrint c
then normal colorCode [c]
@@ -302,7 +301,10 @@ reform colorCode c =
27 -> "^["
_ -> charToCode c
+normal :: Int -> String -> String
normal colorCode s = "\x1b[" ++ show colorCode ++ "m" ++ s ++ "\x1b[m"
+
+special :: Int -> String -> String
special colorCode s = "\x1b[1;" ++ show colorCode ++ "m" ++ s ++ "\x1b[m"
@@ -324,8 +326,10 @@ renderInputLine m (lhs, rhs) = do
putStr $ promptString ++ pp lhs ++ pp rhs
moveCursorLeft (length $ ppVis rhs)
where
- pp = concat . map reform
- reform c =
+ pp = concat . map reform'
+
+ -- TODO unify reform and reform'
+ reform' c =
if isPrint c
then [c]
else
@@ -349,31 +353,40 @@ renderInputLine m (lhs, rhs) = do
+clearLine :: IO ()
clearLine =
putStr "\x1b[2K" >>
moveCursorLeft 1024
+ringBell :: IO ()
ringBell = putStr "\x07" -- BEL '\a'
+saveCursor :: IO ()
saveCursor = putStr "\x1b[s"
+
+unsaveCursor :: IO ()
unsaveCursor = putStr "\x1b[u"
+moveCursorLeft :: Int -> IO ()
moveCursorLeft 0 = return ()
moveCursorLeft i = putStr $ "\x1b[" ++ show i ++ "D"
+moveCursorRight :: Int -> IO ()
moveCursorRight 0 = return ()
moveCursorRight i = putStr $ "\x1b[" ++ show i ++ "C"
-- TODO? charToCode c = "\\x" ++ showHex (ord c)
+charToCode :: Char -> String
charToCode c = "\\x" ++ showIntAtBase 16 intToDigit (ord c) ""
+nmap :: Keymap
nmap =
[ ("i", ChangeMode InsertMode)
, ("a", ChangeMode InsertMode <> MotionCommand (GotoRight 1))
@@ -392,6 +405,7 @@ nmap =
]
+imap :: Keymap
imap =
[ ("\x1b", ChangeMode NormalMode <> MotionCommand (GotoLeft 1))
, ("\x01", MotionCommand GotoFirstChar)
@@ -434,7 +448,7 @@ getCommandXXX :: Keymap -> (String -> Command) -> VT Command
getCommandXXX keymap defCmd = do
-- wait for the first character
- c <- liftIO $ hLookAhead stdin
+ _ <- liftIO $ hLookAhead stdin
bufRef <- liftIO $ newIORef ""
candRef <- liftIO $ newIORef Nothing