diff options
| -rw-r--r-- | Main.hs | 237 |
1 files changed, 133 insertions, 104 deletions
@@ -1,6 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Main where +import Control.Applicative import Control.Concurrent import Control.Concurrent.MVar import Control.Monad @@ -14,6 +15,10 @@ import System.IO import System.Locale (defaultTimeLocale, rfc822DateFormat) --import System.Posix.Signals +import Control.Monad.Error +import Control.Monad.Writer +import Control.Monad.State + data VTState = VTState { buffer :: Buffer @@ -50,40 +55,36 @@ main = do dateThread delay lock = forever $ do t <- getCurrentTime withMVar lock $ \ buf -> do - putLine $ formatTime defaultTimeLocale rfc822DateFormat t + clearLine + putStrLn $ formatTime defaultTimeLocale rfc822DateFormat t renderInputLine buf hFlush stdout threadDelay delay - + uiThread mod lock = do c <- getCommand mod - --mbMode <- modifyMVar lock (execCommand c) - --case mbMode of - -- Nothing -> - -- uiThread mode lock - -- Just mode' -> - -- uiThread mode' lock mod' <- modifyMVar lock $ \ buf -> do let st = VTState { mode = mod , buffer = buf } - mbst' <- execCommand c st - - case mbst' of - Nothing -> do - ringBell - hFlush stdout - return (buf, mod) - Just st' -> do - clearLine - when (show (mode st) /= show (mode st')) $ do - putStrLn $ "change mode: " ++ (show $ mode st') - renderInputLine (buffer st') - hFlush stdout - - return (buffer st', mode st') + + ((eSt, lines), st') <- runExecCommand st (execCommand c) + + clearLine + forM_ lines putStrLn + + whenLeft eSt $ \err -> + ringBell >> + putStrLn (prettyError err) + + when (show (mode st) /= show (mode st')) $ do + putStrLn $ "change mode: " ++ (show $ mode st') + + renderInputLine (buffer st') + hFlush stdout + return (buffer st', mode st') uiThread mod' lock @@ -103,34 +104,45 @@ data Command | GotoBOL | GotoEOL +data ExecError + = UnboundSequenceError String String + | UnhandledInputError String + | OtherError String + +instance Error ExecError where + noMsg = OtherError "something went wrong" + +prettyError :: ExecError -> String +prettyError e = rec e + where + color cc s = "\x1b[" ++ cc ++ "m" ++ s ++ "\x1b[m" + rec (UnboundSequenceError s n) = + color "31" $ "unbound sequence: <" ++ (pp "31;1" s) ++ "\x1b[;31m> " + ++ (pp "31;1" n) + + rec (UnhandledInputError s) = + color "31" $ "unhandled input: <" ++ (pp "31;1" s) ++ "\x1b[;31m>" ---finishCommand :: Buffer -> IO (Buffer, Maybe Mode) ---finishCommand buf = do --- clearLine --- renderInputLine buf --- hFlush stdout --- return (buf, Nothing) --- ---finishCommandChangeMode :: Buffer -> Mode -> IO (Buffer, Maybe Mode) ---finishCommandChangeMode buf mode = do --- clearLine --- putStrLn $ "change mode: " ++ (show mode) --- renderInputLine buf --- hFlush stdout --- return (buf, Just mode) + rec (OtherError s) = + color "31" $ "error: " ++ s --- TODO execCommand :: Command -> VTState -> VTState + -- TODO cc is ColorCode + pp cc = concat . map (pp1 cc) + pp1 cc c + | isPrint c = [c] + | otherwise = specialChar cc $ + case c of + '\x1b' -> "^[" + _ -> charToCode c + specialChar cc s = "\x1b[1;35m" ++ s ++ "\x1b[;" ++ cc ++ "m" ---execCommand :: Command -> Buffer -> IO (Buffer, Maybe Mode) --- TODO instead of propagating Maybe to caller, use --- something like Writer monad to generate bell -modifyBuffer :: (Buffer -> Maybe Buffer) -> VTState -> Maybe VTState -modifyBuffer f st = - case f (buffer st) of - Nothing -> Nothing - Just b' -> Just st { buffer = b' } + +modifyBuffer :: (Buffer -> Buffer) -> ExecM () +modifyBuffer f = + modify $ \st -> st { buffer = f (buffer st) } + -- TODO instance Show Buffer (w/newtype Buffer) @@ -138,75 +150,87 @@ showBuffer :: Buffer -> String showBuffer (lhs, rhs) = lhs ++ rhs -execCommand :: Command -> VTState -> IO (Maybe VTState) -execCommand GotoBOL q = - return . modifyBuffer (\(lhs, rhs) -> Just ("", lhs ++ rhs)) $ q +newtype ExecM a = ExecM + ( ErrorT ExecError (WriterT [String] (StateT VTState IO)) a + ) + deriving + ( Applicative + , Functor + , Monad + , MonadError ExecError + , MonadIO + , MonadState VTState + , MonadWriter [String] + ) + +runExecCommand :: + VTState -> ExecM a -> IO ((Either ExecError a, [String]), VTState) + +runExecCommand st (ExecM ex) = + runStateT (runWriterT (runErrorT ex)) st + -execCommand GotoEOL q = - return . modifyBuffer (\(lhs, rhs) -> Just (lhs ++ rhs, "")) $ q -execCommand MoveCursorLeft q = - return . modifyBuffer (\(lhs, rhs) -> - if null lhs then Nothing else Just (init lhs, last lhs : rhs) - ) $ q +execCommand :: Command -> ExecM () -execCommand MoveCursorRight q = - return . modifyBuffer (\(lhs, rhs) -> - if null lhs then Nothing else Just (lhs ++ [head rhs], tail rhs) - ) $ q +execCommand GotoBOL = + modifyBuffer $ \(lhs, rhs) -> ("", lhs ++ rhs) -execCommand (InsertChar c) q = - return . modifyBuffer (\(lhs, rhs) -> Just (lhs ++ [c], rhs)) $ q +execCommand GotoEOL = + modifyBuffer $ \(lhs, rhs) -> (lhs ++ rhs, "") -execCommand (InsertCharThenChangeMode c m) q = - execCommand (InsertChar c) q { mode = m } +execCommand MoveCursorLeft = do + get >>= flip (when . null . fst . buffer) + (throwError $ OtherError "no char to move left") + modifyBuffer $ \(lhs, rhs) -> (init lhs, last lhs : rhs) -execCommand InsertNextCharVerbatim q = - return . modifyBuffer Just $ q { mode = VerbatimMode } +execCommand MoveCursorRight = do + get >>= flip (when . null . snd . buffer) + (throwError $ OtherError "no char to move right") + modifyBuffer $ \(lhs, rhs) -> (lhs ++ [head rhs], tail rhs) -execCommand ExecuteInputBuffer q = do - -- TODO Writer monad? - putLine $ concat - [ "input: <", concat $ map (reform 32) $ showBuffer . buffer $ q, ">" - ] - return . modifyBuffer (const $ Just emptyBuffer) $ q +execCommand (InsertChar c) = + modifyBuffer $ \(lhs, rhs) -> (lhs ++ [c], rhs) -execCommand KillNextChar q = - return . modifyBuffer (\(lhs, _:rhs') -> Just (lhs, rhs')) $ q +execCommand (InsertCharThenChangeMode c m) = + modify $ \ q -> q + { buffer = (\(lhs, rhs) -> (lhs ++ [c], rhs)) $ buffer q + , mode = m + } -execCommand KillLastChar q = - return . modifyBuffer (\(lhs, rhs) -> - if null lhs then Nothing else Just (init lhs, rhs) - ) $ q +execCommand InsertNextCharVerbatim = + modify $ \ q -> q { mode = VerbatimMode } -execCommand KillLastWord q = - return . modifyBuffer (\(lhs, rhs) -> - if null lhs then Nothing - else Just (foldr dropWhileEnd lhs [not . isSpace, isSpace], rhs) - ) $ q +execCommand ExecuteInputBuffer = do + b <- gets buffer + tell [ "input: <" ++ (concat $ map (reform 32) $ showBuffer b) ++ ">" ] + modifyBuffer (const emptyBuffer) -execCommand (AlertBadInput s) q = do - putLine $ "unhandled input: <" ++ (concat $ map (reform 31) s) ++ ">" - return Nothing - --return . Just $ q +execCommand KillNextChar = do + get >>= flip (when . null . snd . buffer) + (throwError $ OtherError "nothing to kill right") + modifyBuffer $ \(lhs, _:rhs') -> (lhs, rhs') -execCommand (UnboundSequence s n) q = do - putLine $ "unbound sequence: <" ++ (concat $ map (reform 31) s) ++ "> " - ++ (special 31 n) - --return . Just $ q - return Nothing +execCommand KillLastChar = do + get >>= flip (when . null . fst . buffer) + (throwError $ OtherError "nothing to kill left") + modifyBuffer $ \(lhs, rhs) -> (init lhs, rhs) ---execCommand _ q = do --- ringBell --- hFlush stdout --- return q +execCommand KillLastWord = do + get >>= flip (when . null . fst . buffer) + (throwError $ OtherError "nothing to kill left") + modifyBuffer $ + \(lhs, rhs) -> (foldr dropWhileEnd lhs [not . isSpace, isSpace], rhs) + +execCommand (AlertBadInput s) = + throwError (UnhandledInputError s) + +execCommand (UnboundSequence s n) = + throwError (UnboundSequenceError s n) -putLine s = do - clearLine -- TODO this renders finishCommand's clearLine redundant - putStrLn s @@ -224,13 +248,11 @@ special colorCode s = "\x1b[1;" ++ show colorCode ++ "m" ++ s ++ "\x1b[m" --- XXX assumes that the cursor is already at the input line +-- XXX assumes that the cursor is already at the (cleared) input line renderInputLine :: Buffer -> IO () renderInputLine (lhs, rhs) = do - --clearLine putStr $ "> " ++ pp lhs ++ pp rhs moveCursorLeft (length $ ppVis rhs) - --hFlush stdout where pp = concat . map reform reform c = @@ -240,7 +262,7 @@ renderInputLine (lhs, rhs) = do "\x1b[35m" ++ ( case ord c of 27 -> "^[" - _ -> "\\" ++ show (ord c) + _ -> charToCode c ) ++ "\x1b[m" ppVis = concat . map reformVis @@ -250,7 +272,7 @@ renderInputLine (lhs, rhs) = do else case ord c of 27 -> "^[" - _ -> "\\" ++ show (ord c) + _ -> charToCode c @@ -398,3 +420,10 @@ verbatimKeymap = do --return $ InsertCharThenChangeMode c defaultGetCommand return $ InsertCharThenChangeMode c (NormalMode nmap) + +-- TODO Control.Monad.whenLeft +whenLeft :: Monad m => Either a b -> (a -> m ()) -> m () +whenLeft (Left x) f = f x +whenLeft _ _ = return () + + |