diff options
| -rw-r--r-- | Main.hs | 115 |
1 files changed, 49 insertions, 66 deletions
@@ -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 |