summaryrefslogtreecommitdiffstats
path: root/src/Main.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Main.hs')
-rw-r--r--src/Main.hs147
1 files changed, 78 insertions, 69 deletions
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