summaryrefslogtreecommitdiffstats
path: root/src/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Main.hs')
-rw-r--r--src/Main.hs554
1 files changed, 554 insertions, 0 deletions
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..43ff393
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,554 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Main where
+
+import Control.Applicative
+import Control.Concurrent
+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 GHC.Stats (getGCStats)
+
+import Control.Monad.Error
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Writer
+
+import Buffer
+import Process
+
+data VTConfig = VTConfig
+ { withOutput :: IO () -> IO ()
+ }
+
+data VTState = VTState
+ { buffer :: Buffer
+ , mode :: Mode
+ , processCount :: Int
+ }
+
+main :: IO ()
+main = do
+ hSetEcho stdin False
+ hSetBuffering stdin NoBuffering
+
+ -- WINCH
+ -- TODO installHandler 28 (Catch $ ioctl 0 ...) Nothing
+
+ let st = VTState
+ { mode = InsertMode
+ , buffer = ("", "")
+ , processCount = 0
+ }
+
+ lockRef <- newMVar ()
+ qRef <- newIORef st
+ let _putState = writeIORef qRef -- TODO atomicModifyIORef (?)
+ _getState = readIORef qRef
+ _withOutput a = do
+ q <- _getState
+ withMVar lockRef $ \ _ -> do
+ clearLine
+ a
+ renderInputLine (mode q) (buffer q)
+ hFlush stdout
+
+ let cf = VTConfig
+ { withOutput = _withOutput
+ }
+
+ -- render initial input line
+ _withOutput $ return ()
+
+ forkIO $ dateThread _withOutput 1000000
+
+ uiThread cf _putState _getState
+
+
+dateThread :: (IO () -> IO ()) -> Int -> IO ()
+dateThread _withOutput delay = forever $ do
+ t <- liftIO getCurrentTime
+ _withOutput $
+ putStrLn $ formatTime defaultTimeLocale rfc822DateFormat t
+ threadDelay delay
+
+
+uiThread :: VTConfig -> (VTState -> IO ()) -> IO VTState -> IO ()
+uiThread cf putState getState = forever $ do
+ q0 <- getState
+
+ ((eitCmd, lns), q1) <- runVT cf q0 $ do
+ c <- getCommand (mode q0)
+ execCommand c
+ return c
+
+ -- TODO only putState if it has changed (?)
+ putState q1
+
+ let mbErr = case eitCmd of
+ Left err -> Just err
+ Right c ->
+ -- TODO move this to execCommand / throwError
+ case c of
+ MotionCommand motion | buffer q0 == buffer q1 ->
+ Just (OtherError $ "motion failed: " ++ show motion)
+ _ ->
+ Nothing
+
+ withOutput cf $ do
+ forM_ lns putStrLn
+
+ case mbErr of
+ Just err -> ringBell >> putStrLn (prettyError err)
+ Nothing -> return ()
+
+ --when (mode st /= mode st') $ do
+ -- putStrLn $ "change mode: " ++ (show $ mode st')
+
+
+
+data Command
+ = AlertBadInput String
+ | InsertString String
+ | KillLastWord
+ | KillLastChar
+ | KillNextChar
+ | ExecuteInputBuffer
+ | MotionCommand LeftRightMotion
+ | ChangeMode Mode
+ -- TODO Move Count Motion
+ -- Delete Count Register Motion
+ -- etc.
+ | Combine Command Command
+ | Nop
+ | RingBell
+
+instance Monoid Command where
+ mempty = Nop
+ mappend = Combine
+
+
+
+data ExecError
+ = 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 (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) -> VT ()
+modifyBuffer f =
+ modify $ \st -> st { buffer = f (buffer st) }
+
+
+
+newtype VT a = VT
+ (ReaderT VTConfig
+ (ErrorT ExecError
+ (WriterT [String]
+ (StateT VTState IO
+ )))
+ a)
+ deriving
+ ( Applicative
+ , Functor
+ , Monad
+ , MonadError ExecError
+ , MonadIO
+ , MonadReader VTConfig
+ , MonadState VTState
+ , MonadWriter [String]
+ )
+
+runVT ::
+ VTConfig -> VTState -> VT a -> IO ((Either ExecError a, [String]), VTState)
+
+runVT cf st (VT a) =
+ runStateT (runWriterT (runErrorT (runReaderT a cf))) st
+
+
+
+insertString :: String -> Buffer -> Buffer
+insertString s (ls, rs) = (ls ++ s, rs)
+
+
+execCommand :: Command -> VT ()
+
+execCommand (MotionCommand x) = do
+ modifyBuffer (move x)
+ -- TODO apply mode constraints somewhere else
+ q <- get
+ when (mode q == NormalMode) $
+ when (null $ snd $ buffer q) $
+ modifyBuffer (gotoLeft 1)
+
+execCommand (ChangeMode m) =
+ modify $ \ q -> q { mode = m }
+
+execCommand (InsertString s) =
+ modifyBuffer (insertString s)
+
+execCommand ExecuteInputBuffer = do
+
+ ---- XXX hack to replace empty command line
+ --gets (null . showBuffer . buffer) >>= flip when
+ -- (modify $ \q -> q { buffer = ("!","") })
+
+ st <- get
+
+ case showBuffer (buffer st) of
+ ":s" -> do
+ s <- liftIO getGCStats
+ tell [ show s ]
+ '!' : cmdline -> do
+ --tell [ "spawn: " ++ cmdline ]
+ -- "input: <" ++ (concat $ map (reform 32) $ showBuffer b) ++ ">" ]
+ -- TODO register process
+ i <- state $ \ q ->
+ let i = processCount q + 1
+ in (i, q { processCount = i })
+ cf <- ask
+ liftIO $ forkIO $ spawn i (withOutput cf) cmdline
+ return ()
+ "" -> do
+ liftIO ringBell
+ s -> do
+ tell [ "input: <" ++ (concat $ map (reform 32) s) ++ ">" ]
+
+ 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 (Combine c1 c2) = do
+ cf <- ask
+ q0 <- get
+
+ ((eSt1, lines1), q1) <- liftIO $ runVT cf q0 (execCommand c1)
+
+ -- TODO "stack trace"
+ whenLeft eSt1 throwError
+
+ ((eSt2, lines2), q2) <- liftIO $ runVT cf q1 (execCommand c2)
+
+ -- TODO "stack trace"
+ whenLeft eSt2 throwError
+
+ tell lines1
+ tell lines2
+
+ put q2
+
+execCommand Nop = return ()
+
+execCommand RingBell = liftIO ringBell
+
+
+reform :: Int -> Char -> String
+reform colorCode c =
+ if isPrint c
+ then normal colorCode [c]
+ else
+ special colorCode $
+ case ord c of
+ 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"
+
+
+
+-- 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
+
+ let promptString = case m of
+ NormalMode -> "\x1b[33;1m@\x1b[m "
+ InsertMode -> "> "
+ VerbatimMode -> "\x1b[34;1m^\x1b[m "
+
+ putStr $ promptString ++ pp lhs ++ pp rhs
+ moveCursorLeft (length $ ppVis rhs)
+ where
+ pp = concat . map reform'
+
+ -- TODO unify reform and 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 :: 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))
+ , ("I", ChangeMode InsertMode <> MotionCommand GotoFirstChar)
+ , ("A", ChangeMode InsertMode <> MotionCommand GotoEndOfLine)
+ , ("0", MotionCommand GotoFirstChar)
+ , ("$", MotionCommand GotoEndOfLine)
+ , ("h", MotionCommand $ GotoLeft 1)
+ , ("l", MotionCommand $ GotoRight 1)
+ , ("b", MotionCommand $ WordsBackward 1)
+ , ("w", MotionCommand $ WordsForward 1)
+ , ("\x1b[C", MotionCommand $ GotoRight 1)
+ , ("\x1b[D", MotionCommand $ GotoLeft 1)
+ , ("\x0a", ExecuteInputBuffer <> ChangeMode InsertMode)
+ , ("\x1b", RingBell) -- TODO cancel any unfinished commands
+ ]
+
+
+imap :: Keymap
+imap =
+ [ ("\x1b", ChangeMode NormalMode <> MotionCommand (GotoLeft 1))
+ , ("\x01", MotionCommand GotoFirstChar)
+ , ("\x05", MotionCommand GotoEndOfLine)
+ , ("\x1b[3~", KillNextChar)
+ , ("\x1b[C", MotionCommand $ GotoRight 1)
+ , ("\x1b[D", MotionCommand $ GotoLeft 1)
+ , ("\x16", ChangeMode VerbatimMode) -- ^V
+ , ("\x17", KillLastWord) -- ^W
+ , ("\x0a", ExecuteInputBuffer)
+ , ("\x7f", KillLastChar) -- Delete
+ , ("\x08", KillLastChar) -- BackSpace
+ , ("\x1bOc", MotionCommand $ WordsForward 1)
+ , ("\x1bOd", MotionCommand $ WordsBackward 1)
+ ]
+
+
+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 -> VT Command
+getCommand InsertMode = getCommandXXX imap InsertString
+getCommand NormalMode = getCommandXXX nmap AlertBadInput
+getCommand VerbatimMode = verbatimKeymap
+
+
+-- TODO refactor me please^_^
+getCommandXXX :: Keymap -> (String -> Command) -> VT Command
+getCommandXXX keymap defCmd = do
+
+ -- wait for the first character
+ _ <- liftIO $ hLookAhead stdin
+
+ bufRef <- liftIO $ newIORef ""
+ candRef <- liftIO $ newIORef Nothing
+ cmdRef <- liftIO $ newEmptyMVar -- :: MVar (Maybe (String -> Command))
+
+ -- TODO ensure that this thread dies eventually
+ --forkIO $ rec "" keymap cmdRef candRef
+ getCharThreadId <-
+ --forkFinally (rec keymap cmdRef candRef bufRef)
+ -- (\_ -> putStrLn "input terminated")
+ liftIO $ forkIO $ do
+ rec keymap cmdRef candRef bufRef
+
+ watchDogThreadId <-
+ liftIO $ forkIO $ do
+ --putStrLn "watchdog activated"
+ threadDelay $ 1000 * 50 -- 50ms
+ --putStrLn "watchdog timeout"
+ killThread getCharThreadId
+ --putStrLn "watchdog killed getCharThread"
+ putMVar cmdRef Nothing -- continue main thread
+
+ mbCmd <- liftIO $ takeMVar cmdRef
+
+ liftIO $ killThread watchDogThreadId
+
+ cmd <- case mbCmd of
+ Just cmd -> return cmd
+ Nothing -> do
+ mbCmd2 <- liftIO $ readIORef candRef
+ case mbCmd2 of
+ Just cmd2 -> return cmd2
+ Nothing -> return defCmd
+
+ s <- liftIO $ readIORef bufRef
+
+ --clearLine
+ --putStrLn $ "\x1b[35;1m" ++ (show s) ++ " -> " ++ (show $ cmd s) ++ "\x1b[m"
+ return $ cmd s
+
+ where
+ rec :: Keymap
+ -> MVar (Maybe (String -> Command))
+ -> IORef (Maybe (String -> Command))
+ -> IORef String
+ -> IO ()
+ rec km cmdRef candRef bufRef = do
+ c <- getChar
+ -- TODO s <- atomicModifyIORef bufRef $ \s -> let s' = s++[c] in (s,s)
+ olds <- readIORef bufRef
+ let s = olds ++ [c]
+ writeIORef bufRef s
+
+ let km' = map (\(str,cmd) -> (tail str, cmd))
+ $ filter ((==c) . head . fst) km
+
+ -- direct and indirect candidates
+ (dc, ic) = partition (null . fst) km'
+
+ --clearLine
+ --putStrLn $ " s: " ++ show s
+ --putStrLn $ "ic: " ++ (show $ map snd ic)
+ --putStrLn $ "dc: " ++ (show $ map snd dc)
+
+ -- update candidate
+ if length dc == 1
+ then atomicWriteIORef candRef (Just $ const $ snd $ dc !! 0)
+ else atomicWriteIORef candRef Nothing
+
+ case length km' of
+ 0 -> do
+ --return $ defCmd' (s ++ [c])
+ cand <- readIORef candRef
+ putMVar cmdRef cand
+ 1 ->
+ let (rest, cmd) = km' !! 0
+ in if null rest
+ then do
+ --return $ cmd
+ -- TODO somehow give s?
+ putMVar cmdRef (Just $ const cmd)
+ else do
+ --rec (s ++ [c]) ic defCmd'
+ rec ic cmdRef candRef bufRef
+ _ -> do
+ --rec (s ++ [c]) ic defCmd'
+ rec ic cmdRef candRef bufRef
+
+
+
+verbatimKeymap :: VT Command
+verbatimKeymap = do
+ c <- liftIO getChar
+ return $ InsertString [c] <> ChangeMode InsertMode
+
+
+-- TODO Control.Monad.whenLeft
+whenLeft :: Monad m => Either a b -> (a -> m ()) -> m ()
+whenLeft (Left x) f = f x
+whenLeft _ _ = return ()
+
+
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 01:56:38 +0000