From 9ca0fcc6e90fef6f7adece3db7f168c9307e2864 Mon Sep 17 00:00:00 2001
From: Benjamin Barenblat <bbaren@mit.edu>
Date: Wed, 27 May 2015 22:04:48 -0400
Subject: Simple demonstration of multiple producers
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

This doesn’t work the way it should, though – something is wrong with my
threading.
---
 jarvis.cabal |  4 ++++
 src/Main.hs  | 65 ++++++++++++++++++++++++++++++++++++++++++++++++++----------
 2 files changed, 58 insertions(+), 11 deletions(-)

diff --git a/jarvis.cabal b/jarvis.cabal
index 9f201e7..8695548 100644
--- a/jarvis.cabal
+++ b/jarvis.cabal
@@ -30,6 +30,8 @@ executable jarvis
   main-is:             Main.hs
   -- other-modules:       
   build-depends:       base >=4.6 && <4.7
+                     , data-default-class >=0.0.1 && <0.1
+                     , vty >=5.2.3 && <5.3
   hs-source-dirs:      src
   default-language:    Haskell2010
   -- extensions:          
@@ -40,3 +42,5 @@ executable jarvis
                        -fwarn-missing-signatures
                        -fwarn-orphans
                        -fwarn-unused-do-bind
+                       -threaded
+                       -with-rtsopts=-N
diff --git a/src/Main.hs b/src/Main.hs
index 3edefe2..9d3906c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -14,18 +14,61 @@
 
 module Main (main) where
 
-import Control.Monad (forever)
-import System.IO (hFlush, stdout)
+import Control.Concurrent (forkIO, threadDelay)
+import Control.Concurrent.SampleVar
+import Control.Monad (forever, void)
+import Data.Default.Class (def)
+import Graphics.Vty (Vty, (<->), (<|>))
+import qualified Graphics.Vty as Vty
 
 main :: IO ()
-main = forever $
-  readCommand >>= evaluate
+main = do
+  terminal <- Vty.mkVty def
+  initialize terminal
+  jarvis terminal
+  Vty.shutdown terminal
 
-readCommand :: IO String
-readCommand = do
-  putStr "> " >> hFlush stdout
-  getLine
+initialize :: Vty -> IO ()
+initialize _ = return ()
 
-evaluate :: String -> IO ()
-evaluate command =
-  putStrLn $ "Got command ‘" ++ command ++ "’"
+jarvis :: Vty -> IO ()
+jarvis terminal = do
+  log <- newSampleVar Vty.emptyImage
+  prompt <- newSampleVar Vty.emptyImage
+  ready <- newEmptySampleVar
+  void $ forkIO $ redrawer ready log prompt terminal
+  void $ forkIO $ prompter prompt ready
+  void $ forkIO $ logger log ready
+  void $ Vty.nextEvent terminal
+
+prompter :: SampleVar Vty.Image -> SampleVar () -> IO ()
+prompter output redraw = prompt' 0
+  where prompt' n = do
+          writeSampleVar output $ Vty.string def ("jarvis " ++ show n ++ " >")
+          writeSampleVar redraw ()
+          threadDelay 1000000
+          prompt' (n + 1)
+
+logger :: SampleVar Vty.Image -> SampleVar () -> IO ()
+logger output redraw = log 0 []
+  where log n lines = do
+          let lines' = lines ++ ["<" ++ show n ++ ">"]
+          writeSampleVar output $ Vty.vertCat $ map (Vty.string def) lines'
+          writeSampleVar redraw ()
+          threadDelay 200000
+          log (n + 1) lines'
+
+redrawer :: SampleVar () -> SampleVar Vty.Image -> SampleVar Vty.Image -> Vty -> IO ()
+redrawer ready log prompt terminal = forever $ do
+  void $ readSampleVar ready
+  (_maxX, maxY) <- Vty.displayBounds $ Vty.outputIface terminal
+  images <- sequence $ map readSampleVar [log, prompt]
+  let stack = resizeHeight' maxY $ Vty.vertCat images
+  Vty.update terminal $ Vty.picForImage stack
+  Vty.refresh terminal
+
+resizeHeight' :: Int -> Vty.Image -> Vty.Image
+resizeHeight' h i = case h `compare` Vty.imageHeight i of
+    LT -> Vty.cropTop h i
+    EQ -> i
+    GT -> Vty.translateY (h - Vty.imageHeight i) i
-- 
cgit v1.2.3