diff options
| -rw-r--r-- | Buffer/Class.hs | 3 | ||||
| -rw-r--r-- | Buffer/Motion.hs | 14 | ||||
| -rw-r--r-- | Main.hs | 50 |
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 @@ -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 |