summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authortv <tv@shackspace.de>2014-07-28 13:59:33 +0200
committertv <tv@shackspace.de>2014-07-28 13:59:33 +0200
commit9c3f9557ded1e2d08d3799fb202f86becf1ea534 (patch)
tree54511e219acfb080723b02fa80ead11a9ab0d545
parent1985060171be23c6188ead52341b0970923e7ddb (diff)
add withOutput
-rw-r--r--Main.hs115
1 files changed, 49 insertions, 66 deletions
diff --git a/Main.hs b/Main.hs
index ed4c6b3..adb022d 100644
--- a/Main.hs
+++ b/Main.hs
@@ -31,10 +31,6 @@ data VTState = VTState
, mode :: Mode
}
-emptyState = VTState emptyBuffer InsertMode
-
-
-
main :: IO ()
main = do
hSetEcho stdin False
@@ -45,84 +41,71 @@ main = do
-- WINCH
-- TODO installHandler 28 (Catch $ ioctl 0 ...) Nothing
- let m = InsertMode
- b = ("", "")
+ let st = VTState
+ { mode = InsertMode
+ , buffer = ("Was geht ab, Junge?", " ^_^")
+ }
- modeRef <- newIORef m
- lock <- newMVar b
+ 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
- renderInputLine m b
- hFlush stdout
+ -- render initial input line
+ withOutput $ return ()
- forkIO $ dateThread 1000000 modeRef lock
- uiThread modeRef lock
+ forkIO $ dateThread withOutput 1000000
+ uiThread withOutput putState getState
-dateThread :: Int -> IORef Mode -> MVar Buffer -> IO ()
-dateThread delay modeRef lock = forever $ do
- t <- getCurrentTime
- m <- readIORef modeRef
- withMVar lock $ \ buf -> do
- clearLine
+
+dateThread :: (IO () -> IO ()) -> Int -> IO ()
+dateThread withOutput delay = forever $ do
+ t <- liftIO getCurrentTime
+ withOutput $
putStrLn $ formatTime defaultTimeLocale rfc822DateFormat t
- renderInputLine m buf
- hFlush stdout
threadDelay delay
-uiThread :: IORef Mode -> MVar Buffer -> IO ()
-uiThread modeRef lock = do
- m <- readIORef modeRef
- b <- readMVar lock
- let cf = VTConfig
- {
- }
- st = VTState
- { mode = m
- , buffer = b
- }
- ((eCmd, _), _) <- runVT cf st (getCommand m)
-
- let c = case eCmd of
- Left _ -> undefined
- Right cmd -> cmd
-
- m' <- modifyMVar lock $ \ buf -> do
- let cf = VTConfig
- {
- }
- st = VTState
- { mode = m
- , buffer = buf
- }
-
- ((eSt, lines), st') <- runVT cf st (execCommand c)
-
- clearLine
- forM_ lines putStrLn
+uiThread :: (IO () -> IO ()) -> (VTState -> IO ()) -> IO VTState -> IO ()
+uiThread withOutput putState getState = forever $ do
+ q0 <- getState
- whenLeft eSt $ \err ->
- ringBell >>
- putStrLn (prettyError err)
+ ((eitCmd, lines), q1) <- runVT VTConfig q0 $ do
+ c <- getCommand (mode q0)
+ execCommand c
+ return c
- -- TODO move this to execCommand / throwError
- case c of
- MotionCommand motion ->
- when (buffer st == buffer st') $
- ringBell >>
- putStrLn (prettyError $ OtherError $ "motion failed: " ++ show motion)
- _ -> return ()
+ -- 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 $ do
+ forM_ lines putStrLn
+
+ case mbErr of
+ Just err -> ringBell >> putStrLn (prettyError err)
+ Nothing -> return ()
--when (mode st /= mode st') $ do
-- putStrLn $ "change mode: " ++ (show $ mode st')
- renderInputLine (mode st') (buffer st')
- hFlush stdout
- return (buffer st', mode st')
-
- writeIORef modeRef m'
- uiThread modeRef lock
data Command