summaryrefslogtreecommitdiffstats
path: root/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Main.hs')
-rw-r--r--Main.hs50
1 files changed, 32 insertions, 18 deletions
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