From e3c8479127589b05719567f6821383ad0d9f5b27 Mon Sep 17 00:00:00 2001 From: tv Date: Mon, 28 Jul 2014 14:18:39 +0200 Subject: move source to src/ --- Main.hs | 554 ---------------------------------------------------------------- 1 file changed, 554 deletions(-) delete mode 100644 Main.hs (limited to 'Main.hs') diff --git a/Main.hs b/Main.hs deleted file mode 100644 index 43ff393..0000000 --- a/Main.hs +++ /dev/null @@ -1,554 +0,0 @@ -{-# 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 () - - -- cgit v1.2.3