{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Main where import Control.Applicative import Control.Concurrent import Control.Concurrent.MVar import Control.Monad import Data.Char import Data.IORef import Data.List import Data.Time.Clock (getCurrentTime) import Data.Time.Format (formatTime) import Numeric (showIntAtBase) import System.IO import System.Locale (defaultTimeLocale, rfc822DateFormat) --import System.Posix.Signals import Control.Monad.Error import Control.Monad.Writer import Control.Monad.State import Buffer data VTState = VTState { buffer :: Buffer , mode :: Mode } emptyState = VTState emptyBuffer InsertMode main :: IO () main = do hSetEcho stdin False hSetBuffering stdin NoBuffering tid <- myThreadId -- WINCH -- TODO installHandler 28 (Catch $ ioctl 0 ...) Nothing modeRef <- newIORef InsertMode lock <- newMVar emptyBuffer renderInputLine InsertMode emptyBuffer hFlush stdout forkIO $ dateThread 1000000 modeRef lock uiThread modeRef lock dateThread :: Int -> IORef Mode -> MVar Buffer -> IO () dateThread delay modeRef lock = forever $ do t <- getCurrentTime m <- readIORef modeRef withMVar lock $ \ buf -> do clearLine putStrLn $ formatTime defaultTimeLocale rfc822DateFormat t renderInputLine m buf hFlush stdout threadDelay delay uiThread modeRef lock = do m <- readIORef modeRef c <- getCommand m m' <- modifyMVar lock $ \ buf -> do let st = VTState { mode = m , buffer = buf } ((eSt, lines), st') <- runExecCommand st (execCommand c) clearLine forM_ lines putStrLn whenLeft eSt $ \err -> ringBell >> putStrLn (prettyError err) -- TODO move this to execCommand / throwError case c of MotionCommand motion -> when (buffer st == buffer st') $ ringBell >> putStrLn (prettyError $ OtherError $ "motion failed: " ++ show motion) _ -> return () when (mode st /= mode st') $ do putStrLn $ "change mode: " ++ (show $ mode st') renderInputLine (mode st') (buffer st') hFlush stdout return (buffer st', mode st') writeIORef modeRef m' uiThread modeRef lock data Command = AlertBadInput String | InsertChar Char | InsertNextCharVerbatim | InsertCharThenChangeMode Char Mode | KillLastWord | KillLastChar | KillNextChar | ExecuteInputBuffer | UnboundSequence String String | MotionCommand LeftRightMotion | ChangeMode Mode -- TODO Move Count Motion -- Delete Count Register Motion -- etc. | Combine Command Command | Nop instance Monoid Command where mempty = Nop mappend = Combine 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>" rec (OtherError s) = color "31" $ "error: " ++ s -- 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" modifyBuffer :: (Buffer -> Buffer) -> ExecM () modifyBuffer f = modify $ \st -> st { buffer = f (buffer st) } 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 insertChar c (ls, rs) = (ls ++ [c], rs) execCommand :: Command -> ExecM () execCommand (MotionCommand x) = modifyBuffer (move x) execCommand (InsertChar c) = modifyBuffer (insertChar c) execCommand (ChangeMode m) = modify $ \ q -> q { mode = m } execCommand (InsertCharThenChangeMode c m) = modify $ \ q -> q { mode = m , buffer = insertChar c (buffer q) } execCommand InsertNextCharVerbatim = modify $ \ q -> q { mode = VerbatimMode } execCommand ExecuteInputBuffer = do b <- gets buffer tell [ "input: <" ++ (concat $ map (reform 32) $ showBuffer b) ++ ">" ] modifyBuffer (const emptyBuffer) execCommand KillNextChar = do get >>= flip (when . null . snd . buffer) (throwError $ OtherError "nothing to kill right") modifyBuffer $ \(lhs, _:rhs') -> (lhs, rhs') execCommand KillLastChar = do get >>= flip (when . null . fst . buffer) (throwError $ OtherError "nothing to kill left") modifyBuffer $ \(lhs, rhs) -> (init lhs, rhs) 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) execCommand (Combine c1 c2) = do q0 <- get ((eSt1, lines1), q1) <- liftIO $ runExecCommand q0 (execCommand c1) -- TODO "stack trace" whenLeft eSt1 throwError ((eSt2, lines2), q2) <- liftIO $ runExecCommand q1 (execCommand c2) -- TODO "stack trace" whenLeft eSt2 throwError tell lines1 tell lines2 put q2 execCommand Nop = return () reform colorCode c = if isPrint c then normal colorCode [c] else special colorCode $ case ord c of 27 -> "^[" _ -> charToCode c normal colorCode s = "\x1b[" ++ show colorCode ++ "m" ++ s ++ "\x1b[m" special colorCode s = "\x1b[1;" ++ show colorCode ++ "m" ++ s ++ "\x1b[m" -- XXX assumes that the cursor is already at the (cleared) input line renderInputLine :: Mode -> Buffer -> IO () renderInputLine m (lhs, rhs) = do clearLine -- TODO this is required for drawing the mode on the right side saveCursor moveCursorRight 1024 moveCursorLeft (length (show m) - 1) putStr $ "\x1b[1;30m" ++ show m ++ "\x1b[m" unsaveCursor putStr $ "> " ++ pp lhs ++ pp rhs moveCursorLeft (length $ ppVis rhs) where pp = concat . map reform reform c = if isPrint c then [c] else "\x1b[35m" ++ ( case ord c of 27 -> "^[" _ -> charToCode c ) ++ "\x1b[m" ppVis = concat . map reformVis reformVis c = if isPrint c then [c] else case ord c of 27 -> "^[" _ -> charToCode c clearLine = putStr "\x1b[2K" >> moveCursorLeft 1024 ringBell = putStr "\x07" -- BEL '\a' saveCursor = putStr "\x1b[s" unsaveCursor = putStr "\x1b[u" moveCursorLeft 0 = return () moveCursorLeft i = putStr $ "\x1b[" ++ show i ++ "D" moveCursorRight 0 = return () moveCursorRight i = putStr $ "\x1b[" ++ show i ++ "C" -- TODO? charToCode c = "\\x" ++ showHex (ord c) charToCode c = "\\x" ++ showIntAtBase 16 intToDigit (ord c) "" nmap = [ ("i", ChangeMode InsertMode) , ("0", MotionCommand GotoFirstChar) , ("$", MotionCommand GotoEndOfLine) ] imap = [ ("\x1b", ChangeMode NormalMode) , ("\x01", MotionCommand GotoFirstChar) , ("\x05", MotionCommand GotoEndOfLine) , ("\x1b[3~", KillNextChar) , ("\x1b[C", MotionCommand $ GotoRight 1) , ("\x1b[D", MotionCommand $ GotoLeft 1) , ("\x16", InsertNextCharVerbatim) -- ^V , ("\x17", KillLastWord) -- ^W , ("\x0a", ExecuteInputBuffer) , ("\x7f", KillLastChar) -- Delete , ("\x08", KillLastChar) -- BackSpace , ("\x1bOc", MotionCommand $ WordsForward 1) , ("\x1bOd", MotionCommand $ WordsBackward 1) ] ++ [unboundSequence "\x1b[2~" ""] ++ [unboundSequence "\x1b[5~" ""] -- page up ++ [unboundSequence "\x1b[6~" ""] -- page dn ++ [unboundSequence "\x1b[7~" ""] ++ [unboundSequence "\x1b[8~" ""] ++ [unboundSequence "\x1b[2$" ""] ++ [unboundSequence "\x1b[5$" ""] -- page up ++ [unboundSequence "\x1b[6$" ""] -- page dn ++ [unboundSequence "\x1b[7$" ""] ++ [unboundSequence "\x1b[8$" ""] ++ [unboundSequence "\x1b\x1b[2$" ""] ++ [unboundSequence "\x1b\x1b[5$" ""] -- page up ++ [unboundSequence "\x1b\x1b[6$" ""] -- page dn ++ [unboundSequence "\x1b\x1b[7$" ""] ++ [unboundSequence "\x1b\x1b[8$" ""] ++ [unboundSequence "\x1b\x1b[A" ""] ++ [unboundSequence "\x1b\x1b[B" ""] ++ [unboundSequence "\x1b\x1b[C" ""] ++ [unboundSequence "\x1b\x1b[D" ""] ++ [unboundSequence "\x1b\x1b[a" ""] ++ [unboundSequence "\x1b\x1b[b" ""] ++ [unboundSequence "\x1b\x1b[c" ""] ++ [unboundSequence "\x1b\x1b[d" ""] ++ [unboundSequence "\x1b[a" ""] ++ [unboundSequence "\x1b[b" ""] ++ [unboundSequence "\x1b[c" ""] ++ [unboundSequence "\x1b[d" ""] ++ [unboundSequence "\x1bOa" ""] ++ [unboundSequence "\x1bOb" ""] ++ [unboundSequence "\x1bOc" ""] ++ [unboundSequence "\x1bOd" ""] ++ [unboundSequence "\x1b\x1bOa" ""] ++ [unboundSequence "\x1b\x1bOb" ""] ++ [unboundSequence "\x1b\x1bOc" ""] ++ [unboundSequence "\x1b\x1bOd" ""] ++ [unboundSequence "\x1b[11~" ""] ++ [unboundSequence "\x1b[12~" ""] ++ [unboundSequence "\x1b[13~" ""] ++ [unboundSequence "\x1b[14~" ""] ++ [unboundSequence "\x1b[15~" ""] ++ [unboundSequence "\x1b[17~" ""] ++ [unboundSequence "\x1b[18~" ""] ++ [unboundSequence "\x1b[19~" ""] ++ [unboundSequence "\x1b[20~" ""] ++ [unboundSequence "\x1b[21~" ""] ++ [unboundSequence "\x1b[23~" ""] ++ [unboundSequence "\x1b[24~" ""] ++ [unboundSequence "\x1b\x1b[11~" ""] ++ [unboundSequence "\x1b\x1b[12~" ""] ++ [unboundSequence "\x1b\x1b[13~" ""] ++ [unboundSequence "\x1b\x1b[14~" ""] ++ [unboundSequence "\x1b\x1b[15~" ""] ++ [unboundSequence "\x1b\x1b[17~" ""] ++ [unboundSequence "\x1b\x1b[18~" ""] ++ [unboundSequence "\x1b\x1b[19~" ""] ++ [unboundSequence "\x1b\x1b[20~" ""] ++ [unboundSequence "\x1b\x1b[21~" ""] ++ [unboundSequence "\x1b\x1b[23~" ""] ++ [unboundSequence "\x1b\x1b[24~" ""] ++ [unboundSequence "\x1b\x1b[2~" ""] ++ [unboundSequence "\x1b\x1b[3~" ""] ++ [unboundSequence "\x1b\x7f" ""] ++ [unboundSequence "\x1b\x0a" ""] unboundSequence seq name = (seq, UnboundSequence seq name) type Keymap = [(String, Command)] data Mode = InsertMode | NormalMode | VerbatimMode deriving (Eq) instance Show Mode where show NormalMode = "normal" show InsertMode = "insert" show VerbatimMode = "verbatim" getCommand :: Mode -> IO Command getCommand InsertMode = getMappedCommand imap InsertChar getCommand NormalMode = getMappedCommand nmap (AlertBadInput . (:[])) getCommand VerbatimMode = verbatimKeymap getMappedCommand :: Keymap -> (Char -> Command) -> IO Command getMappedCommand xs defCmd = do c <- getChar if any (isPrefixOf [c] . fst) xs then rec [c] else if isPrint c then return $ defCmd c else return $ AlertBadInput [c] where rec :: String -> IO Command rec s = case lookup s xs of Just c -> return c _ -> if any (isPrefixOf s . fst) xs then do c <- getChar rec $ s ++ [c] else return $ AlertBadInput s verbatimKeymap :: IO Command verbatimKeymap = do c <- getChar --return $ InsertCharThenChangeMode c defaultGetCommand return $ InsertCharThenChangeMode c NormalMode -- TODO Control.Monad.whenLeft whenLeft :: Monad m => Either a b -> (a -> m ()) -> m () whenLeft (Left x) f = f x whenLeft _ _ = return ()