diff options
Diffstat (limited to 'Main.hs')
| -rw-r--r-- | Main.hs | 50 |
1 files changed, 32 insertions, 18 deletions
@@ -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 |