Abstract 'MSampleVar ()' as 'Flag'

3 files changed, 47 insertions, 9 deletions

diff --git a/jarvis.cabal b/jarvis.cabal
index 79069f8..54cf9d8 100644
--- a/jarvis.cabal
+++ b/jarvis.cabal
@@ -28,7 +28,7 @@ tested-with:         GHC==7.6.3
 
 executable jarvis
   main-is:             Main.hs
-  -- other-modules:       
+  other-modules:       Flag
   build-depends:       base >=4.6 && <4.7
                      , data-default-class >=0.0.1 && <0.1
                      , vty >=5.2.3 && <5.3
diff --git a/src/Flag.hs b/src/Flag.hs
new file mode 100644
index 0000000..0896187
--- /dev/null
+++ b/src/Flag.hs
@@ -0,0 +1,36 @@
+-- Copyright © 2015 Benjamin Barenblat
+--
+-- Licensed under the Apache License, Version 2.0 (the "License"); you may not
+-- use this file except in compliance with the License.  You may obtain a copy
+-- of the License at
+--
+--     http://www.apache.org/licenses/LICENSE-2.0
+--
+-- Unless required by applicable law or agreed to in writing, software
+-- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
+-- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.  See the
+-- License for the specific language governing permissions and limitations under
+-- the License.
+
+module Flag ( Flag
+            , new
+            , wave
+            , wait
+            ) where
+
+import Control.Concurrent.MSampleVar
+
+-- | A flag that a thread can wave at another thread.
+newtype Flag = Flag (MSampleVar ())
+
+-- | Creates a new flag.
+new :: IO Flag
+new = fmap Flag newEmptySV
+
+-- | Waves the flag, allowing a thread waiting on the flag to wake up.
+wave :: Flag -> IO ()
+wave (Flag v) = writeSV v ()
+
+-- | Waits until the flag is waved.
+wait :: Flag -> IO ()
+wait (Flag v) = readSV v
diff --git a/src/Main.hs b/src/Main.hs
index 2c61a3b..e3b8448 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -17,13 +17,15 @@ module Main (main) where
 import Prelude hiding (lines, log)
 
 import Control.Concurrent (forkIO, threadDelay)
-import Control.Concurrent.MSampleVar
 import Control.Monad (forever, void)
 import Data.Default.Class (def)
 import Data.IORef
 import Graphics.Vty (Vty)
 import qualified Graphics.Vty as Vty
 
+import Flag (Flag)
+import qualified Flag
+
 main :: IO ()
 main = do
   terminal <- Vty.mkVty def
@@ -38,34 +40,34 @@ jarvis :: Vty -> IO ()
 jarvis terminal = do
   log <- newIORef Vty.emptyImage
   prompt <- newIORef Vty.emptyImage
-  ready <- newEmptySV
+  ready <- Flag.new
   void $ forkIO $ redrawer ready log prompt terminal
   void $ forkIO $ prompter prompt ready
   void $ forkIO $ logger log ready
   void $ Vty.nextEvent terminal
 
-prompter :: IORef Vty.Image -> MSampleVar () -> IO ()
+prompter :: IORef Vty.Image -> Flag -> IO ()
 prompter output redraw = prompt' 0
   where prompt' :: Integer -> IO ()
         prompt' n = do
           writeIORef output $ Vty.string def ("jarvis " ++ show n ++ " >")
-          writeSV redraw ()
+          Flag.wave redraw
           threadDelay 1000000
           prompt' (n + 1)
 
-logger :: IORef Vty.Image -> MSampleVar () -> IO ()
+logger :: IORef Vty.Image -> Flag -> IO ()
 logger output redraw = log 0 []
   where log :: Integer -> [String] -> IO ()
         log n lines = do
           let lines' = lines ++ ["<" ++ show n ++ ">"]
           writeIORef output $ Vty.vertCat $ map (Vty.string def) lines'
-          writeSV redraw ()
+          Flag.wave redraw
           threadDelay 200000
           log (n + 1) lines'
 
-redrawer :: MSampleVar () -> IORef Vty.Image -> IORef Vty.Image -> Vty -> IO ()
+redrawer :: Flag -> IORef Vty.Image -> IORef Vty.Image -> Vty -> IO ()
 redrawer ready log prompt terminal = forever $ do
-  void $ readSV ready
+  Flag.wait ready
   (_maxX, maxY) <- Vty.displayBounds $ Vty.outputIface terminal
   images <- sequence $ map readIORef [log, prompt]
   let stack = resizeHeight' maxY $ Vty.vertCat images