summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--jarvis.cabal2
-rw-r--r--src/Flag.hs36
-rw-r--r--src/Main.hs18
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