summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--Main.hs237
1 files changed, 133 insertions, 104 deletions
diff --git a/Main.hs b/Main.hs
index 8f4ceb7..ac0b236 100644
--- a/Main.hs
+++ b/Main.hs
@@ -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 ()
+
+