use ExecM monad to execCommand

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 ()
+
+