diff options
Diffstat (limited to 'src/Main.hs')
| -rw-r--r-- | src/Main.hs | 633 |
1 files changed, 0 insertions, 633 deletions
diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 index 3c62184..0000000 --- a/src/Main.hs +++ /dev/null @@ -1,633 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -module Main where - -import Control.Lens hiding (Empty, imap) -import Control.Applicative -import Control.Concurrent -import Control.Monad -import Data.Char -import Data.IORef -import Data.List hiding (delete) -import Numeric (showIntAtBase) -import System.IO ---import System.Posix.Signals - -import GHC.Stats (getRTSStats) - -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.State -import Control.Monad.Writer - -import Data.Map (Map) -import qualified Data.Map as Map - -import Hack.Buffer -import Process -import Scanner -import Blessings -import qualified Blessings.Internal as Blessings -import Blessings.String () - - -data Mode - = InsertMode - | NormalMode - | VerbatimMode - | SelectRegisterMode - | DeleteMode - | YankMode - deriving (Eq) - -instance Show Mode where - show NormalMode = "normal" - show InsertMode = "insert" - show VerbatimMode = "verbatim" - show SelectRegisterMode = "select register" - show DeleteMode = "delete" - show YankMode = "yank" - - -data VTConfig = VTConfig - { withOutput :: IO () -> IO () - } - -data VTState = VTState - { _buffer :: Buffer - , _mode :: Mode - , _processCount :: Int - , _count :: Maybe Int - , _register :: Char - , _registers :: Map Char String - } - -instance Show VTState where - show VTState{..} = - "<VTState" - ++ " buffer=" ++ show _buffer - ++ " mode=" ++ show _mode - ++ " processCount=" ++ show _processCount - ++ " count=" ++ show (maybe 0 id _count) - ++ " register=" ++ show _register - ++ " registers=" ++ show _registers - ++ ">" - -makeLenses ''VTState - - -defaultRegister :: Char -defaultRegister = '"' - -main :: IO () -main = do - hSetEcho stdin False - hSetBuffering stdin NoBuffering - - -- WINCH - -- TODO installHandler 28 (Catch $ ioctl 0 ...) Nothing - - let st = VTState - { _mode = InsertMode - , _buffer = ("!while date; do sleep 1; done", "") - , _processCount = 0 - , _count = Nothing - , _register = defaultRegister - , _registers = Map.empty - } - - 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 (_count q) (_mode q) (_buffer q) - hFlush stdout - - let cf = VTConfig - { withOutput = _withOutput - } - - -- render initial input line - _withOutput $ return () - - uiThread cf _putState _getState - - -uiThread :: VTConfig -> (VTState -> IO ()) -> IO VTState -> IO () -uiThread cf putState getState = forever $ do - q0 <- getState - - - _ <- hLookAhead stdin -- wait for input - --t0 <- getCurrentTime - s <- scan stdin - --t1 <- getCurrentTime - --putStrLn $ "====> \ESC[32;1m" ++ show s ++ "\ESC[m in " ++ - -- (show $ diffUTCTime t1 t0) - -- ++ ": \"\ESC[35m" ++ (s >>= colorize . toChar) - -- ++ "\ESC[m\"" - --case res of - -- Left msg -> putStrLn $ " error: " ++ msg - -- Right _ -> return () - - -- TODO don't leak C - let ScanKey k = s - let cmd = getCommand (_mode q0) k - - --withOutput cf $ do - -- putStrLn $ show cmd - - ((eitCmd, lns), q1) <- runVT cf q0 (execCommand cmd) - - -- TODO only putState if it has changed (?) - putState q1 - - withOutput cf $ do - forM_ lns putStrLn - - whenLeft eitCmd $ \err -> - ringBell >> putStrLn (prettyError err) - - --when (mode st /= mode st') $ do - -- putStrLn $ "change mode: " ++ (show $ mode st') - - - -data Command - = AlertBadInput String - | DebugShowVTState - | InsertString String - | ExecuteInputBuffer - | MoveCursor Motion - | MoveCursorLeftIfAtEndOfLine - | MoveCursorWarn Motion - | ChangeMode Mode - -- TODO Move Count Motion - -- Delete Count Register Motion - -- etc. - | Combine Command Command - | Nop - | RingBell - | AppendCount Int - | SetCount (Maybe Int) - | SetRegister Char - | Delete Motion - | DeleteEntireLine - | Yank Motion - - -instance Semigroup Command where - (<>) = Combine - - -instance Monoid Command where - mempty = Nop - - - -data ExecError - = UnhandledInputError String - | OtherError String - - -prettyError :: ExecError -> String - -prettyError (UnhandledInputError s) = - pp $ SGR [31] $ - "unhandled input: <" <> SGR [1] (gaudySpecial [35,1] s) <> ">" - -prettyError (OtherError s) = - pp $ SGR [31] $ gaudySpecial [35] s - - - -newtype VT a = VT - (ReaderT VTConfig - (ExceptT 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 (runExceptT (runReaderT a cf))) st - - - -insertString :: String -> Buffer -> Buffer -insertString s (ls, rs) = (ls ++ s, rs) - - -execCommand :: Command -> VT () - -execCommand DebugShowVTState = - get >>= tell . (:[]) . pp . SGR [35] . Plain . show - -execCommand (MoveCursor x) = do - c <- uses count (maybe 1 id) - buffer %= move x c - - -- TODO apply mode constraints somewhere else - whenM (uses mode (==NormalMode) >>&& uses (buffer . _2) null) $ - buffer %= gotoLeft 1 - --- TODO merge with mode constraints in MoveCursor -execCommand MoveCursorLeftIfAtEndOfLine = do - whenM (uses (buffer . _2) null) $ - buffer %= gotoLeft 1 - --- TODO Make this "real" warnings, i.e. don't throwError but tell. This --- is required in order to perform any Combine-d commands regardless of --- failed moves. Currently this is only used to SetCount Nothing (which --- is defunct atm) Alternatively we could simply reset the state when an --- error happens Discus! -execCommand (MoveCursorWarn x) = do - b0 <- use buffer - execCommand (MoveCursor x) - b1 <- use buffer - - -- TODO make this a warning or else ... - when (b0 == b1) $ - throwError (OtherError $ "your motion has no effect: " ++ show x) - -execCommand (ChangeMode m) = - mode .= m - -execCommand (InsertString s) = - buffer %= 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 - ":c" -> do - let f i = pp $ SGR [38,5,i] $ Plain $ padl 3 '0' $ show i - tell [ intercalate " " $ map f [0..255] - ] - ":r" -> do - tell [ "--- Registers ---" ] - tell $ map (\(r, s) -> ['"', r] ++ " " ++ s) -- TODO pp - $ Map.toList (_registers st) - ":s" -> do - s <- liftIO getRTSStats - tell [ show s ] - '!' : cmdline -> do - --tell [ "spawn: " ++ cmdline ] - -- "input: <" ++ (showBuffer b >>= reform 32) ++ ">" ] - -- TODO register process - i <- processCount <<+= 1 - cf <- ask - liftIO $ forkIO $ spawn i (withOutput cf) cmdline - return () - "" -> do - liftIO ringBell - s -> do - let s' = SGR [32] $ gaudySpecial [1] s - tell [ pp $ "input: " <> s' - , pp $ SGR [35] $ gaudySpecial [1] $ pp s' - ] - - buffer .= emptyBuffer - -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 - -execCommand (AppendCount i) = - count %= Just . (i+) . maybe 0 (10*) - -execCommand (SetCount i) = - count .= i - -execCommand (SetRegister c) = - register .= c - -execCommand DeleteEntireLine = - -- TODO Numbered registers "0 to "9 - -- Small delete _register "- - modify $ \q -> do - - let v = Just $ showBuffer $ _buffer q - r = _register q - - q & buffer .~ emptyBuffer - & register .~ defaultRegister - & registers %~ (at r .~ v) . - (at defaultRegister .~ v) - --- TODO yank into "- (smallDeleteRegister) when deleting less than one line --- TODO reset register after this command (q & register .~ defaultRegister) -execCommand (Delete x) = do - b0 <- use buffer - c <- uses count (maybe 1 id) - buffer %= delete x c - b1 <- use buffer - - when (b0 == b1) $ throwError (OtherError "nothing to delete") - - --- TODO Yank register motion (after motion has incorporated count) -execCommand (Yank x) = - modify $ \q@VTState{..} -> do - let c = maybe 1 id _count - y = select x c _buffer - - q & registers %~ (at _register .~ Just y) - - --- XXX assumes that the cursor is already at the (cleared) input line --- TODO renderInputLine looks like it wants to be -> VT () -renderInputLine :: Maybe Int -> Mode -> Buffer -> IO () -renderInputLine mb_cnt m (lhs, rhs) = do - renderRight $ - SGR [30,1] $ - Plain (show m) <> - maybe Empty - (("["<>) . (<>"]") . SGR [33,1] . Plain . show) - mb_cnt - renderLeft $ promptString m <> gaudySpecial [35] (lhs ++ rhs) - moveCursorLeft $ length $ lit rhs - - -renderLeft :: Blessings String -> IO () -renderLeft = putStr . pp - - -renderRight :: Blessings String -> IO () -renderRight a = do - saveCursor - moveCursorRight 1024 -- XXX obviously, this is a hack..^_^ - moveCursorLeft $ Blessings.length a - 1 - renderLeft a - unsaveCursor - - - -promptString :: Mode -> Blessings String -promptString NormalMode = SGR [33,1] "@ " -promptString InsertMode = "> " -promptString SelectRegisterMode = "\" " -promptString DeleteMode = SGR [31,1] "> " -promptString VerbatimMode = SGR [34,1] "^ " -promptString YankMode = SGR [31,1] "y " - - -spans :: (a -> Bool) -> [a] -> [Either [a] [a]] -spans p xs = f_r (span p_r xs) - where - p_r = not . p - p_l = p - f_r (as, bs) = Right as : if null bs then [] else f_l (span p_l bs) - f_l (as, bs) = Left as : if null bs then [] else f_r (span p_r bs) - - -gaudySpans :: Pm -> (Char -> Bool) -> String -> Blessings String -gaudySpans c p = - mconcat . map (either (SGR c . Plain . lit) Plain) . spans p - - -gaudySpecial :: Pm -> String -> Blessings String -gaudySpecial c = gaudySpans c (not . isPrint) - - -lit :: String -> String -lit = (>>= f) - where f '\ESC' = "^[" - f c = showLitChar c "" - - -clearLine :: IO () -clearLine = - putStr "\ESC[2K" >> - moveCursorLeft 1024 - - -ringBell :: IO () -ringBell = putStr "\x07" -- BEL '\a' - - -saveCursor :: IO () -saveCursor = putStr "\ESC[s" - -unsaveCursor :: IO () -unsaveCursor = putStr "\ESC[u" - - -moveCursorLeft :: Int -> IO () -moveCursorLeft 0 = return () -moveCursorLeft i = putStr $ "\ESC[" ++ show i ++ "D" - - -moveCursorRight :: Int -> IO () -moveCursorRight 0 = return () -moveCursorRight i = putStr $ "\ESC[" ++ show i ++ "C" - - --- TODO? charToCode c = "\\x" ++ showHex (ord c) -charToCode :: Char -> String -charToCode c = "\\x" ++ showIntAtBase 16 intToDigit (ord c) "" - - -dmap :: Keymap -dmap = - [ ("\ESC", ChangeMode NormalMode <> SetCount Nothing) - , ("\ESC[24~", DebugShowVTState) - , ("d", DeleteEntireLine <> ChangeMode NormalMode <> SetCount Nothing) - , ("$", Yank ToEndOfLine <> - Delete ToEndOfLine <> - ChangeMode NormalMode <> - SetCount Nothing <> - MoveCursorLeftIfAtEndOfLine - ) - , ("0", Yank ToStartOfLine <> - Delete ToStartOfLine <> - ChangeMode NormalMode <> SetCount Nothing) - , ("h", Yank CharsBackward <> - Delete CharsBackward <> - ChangeMode NormalMode <> SetCount Nothing) - , ("l", Yank CharsForward <> - Delete CharsForward <> - ChangeMode NormalMode <> - SetCount Nothing <> - MoveCursorLeftIfAtEndOfLine - ) - ] - - -selectRegisterMap :: Keymap -selectRegisterMap = - [ ("\ESC", ChangeMode NormalMode) - ] - ++ (map (\c -> ([c], SetRegister c <> ChangeMode NormalMode)) - (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ".%#:-\"")) - - --- TODO maybe in normal mode reset count (SetCount Nothing) after each --- command doesn't alter the count. How would this work together with --- ChangeMode DeleteMode --- TODO 2017-08-06 --- initialize count whenever nmap is entered --- ditch SetCount Nothing --- pass count to commands / modes -nmap :: Keymap -nmap = - [ ("\ESC", SetCount Nothing) - -- ^TODO RingBell if count is already Nothing - -- TODO cancel any unfinished commands - , ("i", ChangeMode InsertMode <> SetCount Nothing) - , ("a", ChangeMode InsertMode <> SetCount Nothing <> MoveCursor CharsForward) - , ("I", ChangeMode InsertMode <> MoveCursor ToStartOfLine) - , ("A", ChangeMode InsertMode <> MoveCursor ToEndOfLine) - , ("|", MoveCursorWarn ToColumn <> SetCount Nothing) - , ("$", MoveCursorWarn ToEndOfLine <> SetCount Nothing) - , ("h", MoveCursorWarn CharsBackward <> SetCount Nothing) - , ("l", MoveCursorWarn CharsForward <> SetCount Nothing) - , ("b", MoveCursorWarn WordsBackward <> SetCount Nothing) - , ("w", MoveCursorWarn WordsForward <> SetCount Nothing) - , ("d", ChangeMode DeleteMode) - , ("y", ChangeMode YankMode) - , ("\"", ChangeMode SelectRegisterMode <> SetCount Nothing) - , ("\ESC[24~", DebugShowVTState) - , ("\ESC[C", MoveCursorWarn CharsForward <> SetCount Nothing) - , ("\ESC[D", MoveCursorWarn CharsBackward <> SetCount Nothing) - , ("\n", ExecuteInputBuffer <> ChangeMode InsertMode <> SetCount Nothing) - ] - ++ (map (\i -> (show i, AppendCount i)) [0..9]) - -- XXX - -- if we would want 0 to move the cursor to the first character of the - -- line, then we would need ("0", x) - -- where - -- x :: Command - -- x = Embed f - -- f :: VT Command - -- f = gets (isJust . count) >>= - -- return . bool (MoveCursor ToStartOfLine) (AppendCount 0) - -- bool :: a -> a -> Bool -> a - -- bool _ a True = a - -- bool a _ False = a - -- and also we would have to extend data Command by Embed (VT Command) - -- execCommand (Embed a) = a >>= execCommand - -- - -- This all looks quite strange, so just use | if you want that movement... - -- ^_^ - - -imap :: Keymap -imap = - [ ("\ESC", ChangeMode NormalMode <> MoveCursor CharsBackward) - , ("\x01", MoveCursorWarn ToStartOfLine) - , ("\x05", MoveCursorWarn ToEndOfLine) - , ("\ESC[24~", DebugShowVTState) - , ("\ESC[3~", Delete CharsForward) - , ("\ESC[C", MoveCursorWarn CharsForward) - , ("\ESC[D", MoveCursorWarn CharsBackward) - , ("\x16", ChangeMode VerbatimMode) -- ^V - , ("\x17", Delete WordsBackward) -- ^W - , ("\x0a", ExecuteInputBuffer) - , ("\x7f", Delete CharsBackward) -- Delete - , ("\x08", Delete CharsBackward) -- BackSpace - , ("\ESCOc", MoveCursorWarn WordsForward) - , ("\ESCOd", MoveCursorWarn WordsBackward) - ] - -ymap :: Keymap -ymap = - [ ("\ESC", ChangeMode NormalMode <> SetCount Nothing) - , ("\ESC[24~", DebugShowVTState) - -- TODO , ("y", DeleteEntireLine <> ChangeMode NormalMode <> SetCount Nothing) - , ("$", Yank ToEndOfLine <> ChangeMode NormalMode <> SetCount Nothing) - , ("0", Yank ToStartOfLine <> ChangeMode NormalMode <> SetCount Nothing) - , ("h", Yank CharsBackward <> ChangeMode NormalMode <> SetCount Nothing) - , ("l", Yank CharsForward <> ChangeMode NormalMode <> SetCount Nothing) - ] - - -type Keymap = [(String, Command)] - - -getCommand :: Mode -> String -> Command - -getCommand InsertMode s = maybe (InsertString s) id $ lookup s imap - -getCommand NormalMode s = - maybe (AlertBadInput s <> SetCount Nothing) id $ lookup s nmap - -getCommand VerbatimMode s = InsertString s <> ChangeMode InsertMode - -getCommand SelectRegisterMode s = - maybe (AlertBadInput s) id $ lookup s selectRegisterMap - -- ^ TODO clear bad input - -getCommand DeleteMode s = maybe (AlertBadInput s) id $ lookup s dmap - -getCommand YankMode s = maybe (AlertBadInput s) id $ lookup s ymap - - --- TODO Control.Monad.whenLeft -whenLeft :: Monad m => Either a b -> (a -> m ()) -> m () -whenLeft (Left x) f = f x -whenLeft _ _ = return () - -whenM :: Monad m => m Bool -> m () -> m () -whenM a b = a >>= flip when b - -infixl 1 >>&& - -(>>&&) :: Monad m => m Bool -> m Bool -> m Bool -a >>&& b = do - ra <- a - rb <- b - return $ ra && rb - - -padl :: Int -> a -> [a] -> [a] -padl n c s - | length s < n = padl n c (c : s) - | otherwise = s |