diff options
| -rw-r--r-- | default.nix | 1 | ||||
| -rw-r--r-- | hack.cabal | 1 | ||||
| -rw-r--r-- | src/Main.hs | 147 |
3 files changed, 80 insertions, 69 deletions
diff --git a/default.nix b/default.nix index bba6906..599a096 100644 --- a/default.nix +++ b/default.nix @@ -2,6 +2,7 @@ let pkgs = import <nixpkgs> {}; hsEnv = pkgs.haskellPackages.ghcWithPackages (hsPkgs : with hsPkgs; [ + lens mtl ]); in @@ -16,6 +16,7 @@ Executable hack Build-depends: containers, + lens, mtl, old-locale, process, diff --git a/src/Main.hs b/src/Main.hs index 4d8ba5c..af9cf33 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,7 +1,9 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Main where +import Control.Lens hiding (imap) import Control.Applicative import Control.Concurrent import Control.Monad @@ -28,19 +30,31 @@ import Scanner (scan, runScanner, toChar) import Trammel +data Mode + = InsertMode + | NormalMode + | VerbatimMode + | SelectRegisterMode + | DeleteMode + deriving (Eq) + + data VTConfig = VTConfig { withOutput :: IO () -> IO () } data VTState = VTState - { buffer :: Buffer - , mode :: Mode - , processCount :: Int - , count :: Maybe Int - , register :: Char - , registers :: Map Char String + { _buffer :: Buffer + , _mode :: Mode + , _processCount :: Int + , _count :: Maybe Int + , _register :: Char + , _registers :: Map Char String } +makeLenses ''VTState + + defaultRegister :: Char defaultRegister = '"' @@ -53,12 +67,12 @@ main = do -- 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 + { _mode = InsertMode + , _buffer = ("!while date; do sleep 1; done", "") + , _processCount = 0 + , _count = Nothing + , _register = defaultRegister + , _registers = Map.empty } lockRef <- newMVar () @@ -70,7 +84,7 @@ main = do withMVar lockRef $ \ _ -> do clearLine a - renderInputLine (count q) (mode q) (buffer q) + renderInputLine (_count q) (_mode q) (_buffer q) hFlush stdout let cf = VTConfig @@ -102,7 +116,7 @@ uiThread cf putState getState = forever $ do -- Right _ -> return () -- TODO don't leak C - let cmd = getCommand (mode q0) (map toChar s) + let cmd = getCommand (_mode q0) (map toChar s) --withOutput cf $ do -- putStrLn $ show cmd @@ -168,11 +182,6 @@ prettyError (OtherError s) = pp $ SGR [31] $ gaudySpecial [35] s -modifyBuffer :: (Buffer -> Buffer) -> VT () -modifyBuffer f = - modify $ \st -> st { buffer = f (buffer st) } - - newtype VT a = VT (ReaderT VTConfig @@ -207,13 +216,12 @@ insertString s (ls, rs) = (ls ++ s, rs) execCommand :: Command -> VT () execCommand (MotionCommand x) = do - c <- gets count - modifyBuffer (move x $ maybe 1 id c) + c <- uses count (maybe 1 id) + buffer %= move x c + -- TODO apply mode constraints somewhere else - q <- get - when (mode q == NormalMode) $ - when (null $ snd $ buffer q) $ - modifyBuffer (gotoLeft 1) + whenM (uses mode (==NormalMode) >>&& 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 @@ -221,19 +229,19 @@ execCommand (MotionCommand x) = do -- is defunct atm) Alternatively we could simply reset the state when an -- error happens Discus! execCommand (MotionCommandWarn x) = do - b0 <- gets buffer + b0 <- use buffer execCommand (MotionCommand x) - b1 <- gets buffer + 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) = - modify $ \ q -> q { mode = m } + mode .= m execCommand (InsertString s) = - modifyBuffer (insertString s) + buffer %= insertString s execCommand ExecuteInputBuffer = do @@ -243,7 +251,7 @@ execCommand ExecuteInputBuffer = do st <- get - case showBuffer (buffer st) of + 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] @@ -251,7 +259,7 @@ execCommand ExecuteInputBuffer = do ":r" -> do tell [ "--- Registers ---" ] tell $ map (\(r, s) -> ['"', r] ++ " " ++ s) -- TODO pp - $ Map.toList (registers st) + $ Map.toList (_registers st) ":s" -> do s <- liftIO getGCStats tell [ show s ] @@ -259,9 +267,7 @@ execCommand ExecuteInputBuffer = do --tell [ "spawn: " ++ cmdline ] -- "input: <" ++ (showBuffer b >>= reform 32) ++ ">" ] -- TODO register process - i <- state $ \ q -> - let i = processCount q + 1 - in (i, q { processCount = i }) + i <- processCount <<+= 1 cf <- ask liftIO $ forkIO $ spawn i (withOutput cf) cmdline return () @@ -273,23 +279,25 @@ execCommand ExecuteInputBuffer = do , pp $ SGR [35] $ gaudySpecial [1] $ pp s' ] - modifyBuffer (const emptyBuffer) + buffer .= emptyBuffer execCommand KillNextChar = do - get >>= flip (when . null . snd . buffer) - (throwError $ OtherError "nothing to kill right") - modifyBuffer $ \(lhs, _:rhs') -> (lhs, rhs') + whenM (uses (buffer . _2) null) $ + throwError (OtherError "nothing to kill right") + + buffer . _2 %= tail execCommand KillLastChar = do - get >>= flip (when . null . fst . buffer) - (throwError $ OtherError "nothing to kill left") - modifyBuffer $ \(lhs, rhs) -> (init lhs, rhs) + whenM (uses (buffer . _1) null) $ + throwError (OtherError "nothing to kill left") + + buffer . _1 %= init 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) + whenM (uses (buffer . _1) null) $ + throwError (OtherError "nothing to kill left") + + buffer . _1 %= foldr dropWhileEnd `flip` [not . isSpace, isSpace] execCommand (AlertBadInput s) = throwError (UnhandledInputError s) @@ -318,28 +326,26 @@ execCommand Nop = return () execCommand RingBell = liftIO ringBell execCommand (AppendCount i) = - modify $ \q -> q { count = f (count q) } - where - f Nothing = Just i - f (Just c) = Just (c * 10 + i) + count %= Just . (i+) . maybe 0 (10*) execCommand (SetCount i) = - modify $ \q -> q { count = i } + count .= i -execCommand (SetRegister c) = modify $ \q -> q { register = c } +execCommand (SetRegister c) = + register .= c -execCommand DeleteEntireLine = modify $ \q -> +execCommand DeleteEntireLine = -- TODO Numbered registers "0 to "9 - -- Small delete register "- - let s = showBuffer $ buffer q - r = register q - in q { registers = Map.insert r s - $ Map.insert defaultRegister s - $ registers q - , buffer = emptyBuffer - , register = defaultRegister - } + -- 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) -- XXX assumes that the cursor is already at the (cleared) input line @@ -510,14 +516,6 @@ imap = type Keymap = [(String, Command)] -data Mode - = InsertMode - | NormalMode - | VerbatimMode - | SelectRegisterMode - | DeleteMode - deriving (Eq) - instance Show Mode where show NormalMode = "normal" show InsertMode = "insert" @@ -547,6 +545,17 @@ 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 |