From 9c3f9557ded1e2d08d3799fb202f86becf1ea534 Mon Sep 17 00:00:00 2001
From: tv <tv@shackspace.de>
Date: Mon, 28 Jul 2014 13:59:33 +0200
Subject: add withOutput

---
 Main.hs | 115 +++++++++++++++++++++++++++-------------------------------------
 1 file 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
-- 
cgit v1.2.3