diff options
| -rw-r--r-- | jarvis.cabal | 2 | ||||
| -rw-r--r-- | src/Flag.hs | 36 | ||||
| -rw-r--r-- | src/Main.hs | 18 |
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 |