I have a timer function that takes a time to wait for and a starting time and returns the current UTCTime when it ends:
runTimer :: NominalDiffTime -> UTCTime -> IO UTCTime
I'd like to run this timer function in a separate thread, because I want to simultaneously be able to capture input from the user. In this main loop I also use a WriterT monad transformer to log events. I also want to log an event when the timer ends normally, so I've tried using forkFinally:
type Log = [Entry]
data Entry = Entry {
_etype :: EntryType
, _etime :: UTCTime
} deriving Show
data EntryType = Start | End | Pause | Quit deriving Show
type Program = WriterT Log IO
loop :: Maybe ThreadId -> Program ()
loop timerId = do
liftIO $ putStr ">"
x <- liftIO $ getChar
now <- liftIO $ getCurrentTime
case x of
'q' -> do
liftIO $ putStrLn "\n Quitting..."
tell [Entry Quit now]
-- Kill the timer thread if there is one.
maybe (return ()) (liftIO . killThread) timerId
liftIO $ putStrLn "\n Quit."
's' -> case timerId of
Just _ -> do
liftIO $ putStrLn "Timer already started!"
loop timerId
Nothing -> do
-- Start a timer in a new thread.
tell [Entry Start now]
timerId' <- liftIO $ forkFinally (runTimer 5 now) eHandler
-- Call the main loop with the timer thread id.
loop (Just timerId')
_ -> do
liftIO $ putChar x
loop timerId
eHandler :: (Show a, Exception e) => Either e a -> IO ()
eHandler (Left x) = throw x
eHandler (Right x) = do
putStrLn $ show x
eHandler' :: (Exception t) => Either t UTCTime -> WriterT Log IO ()
eHandler' (Left x) = throw x
eHandler' (Right t) = do
tell [Entry End t]
This code works when using forkFinally with eHandler. But how can I get it to work with eHandler', so that I can log when the timer finishes?
You need to convert a WriterT monad to an IO monad, something like this:
wrapWriterT::WriterT a IO c->IO c
wrapWriterT writer = do
(result, log) <- runWriterT writer
<do something with the log, like send it to a file>
return result
and then use it like this:
timerId' <- liftIO $ forkFinally (runTimer 5 now) (wrapWriterT . eHandler')
What is happening here? Remember, the Writer monad is used to pass an extra string around, that can be appended to, like a log. The IO monad is used for, well.... IO. forkFinally needs type IO(), but the WriterT is for both IO and also returns a log. forkFinally doesn't know what to do with this log, but if you wrap it in a function to extract the log and do something with it, then you are left with simply an IO monad, which forkFinally knows how to handle.
I do want to ask though.... The standard timer functions in Control.Concurrent are nonblocking (you hand it a function of type IO(), and it returns, with the understanding that it will be done later). What are you doing that needs explicit threads?
Related
I was trying to compile a haskell game code, this code generates three thread, one for infinite loop, one for collecting user's interaction, one for triggering the events. However, the code cannot be compiled and I don't know why.
Here's the code:
module Main where
import Control.Concurrent
import Control.Monad
import System.IO
import System.Random
import Text.Printf
data Msg = C Char | Time
data Event = C Char | Time Char
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
hSetBuffering stdin NoBuffering
hSetEcho stdin False
-- shared resources
chan <- newEmptyMVar
removedDigits <- newEmptyMVar
unmatchedDigits <- newEmptyMVar
numberOfGuesses <- newEmptyMVar
--starting the generating thread and the user thread
forkIO $ generatingThread chan
forkIO $ userThread chan
--the main loop
if mainloop chan == True then "Congratulations! You won!" else "Better luck next time!"
return()
mainloop :: Chan c -> Bool
let mainloop = do
if length unmatchedDigits >= 10
then return False
Event <- readChan c
if Event == "timer"
then unmatchedDigits ++ param
else if testGuessedNumber param unmatchedDigits == True
then
removeMatchedDigit
if length unmatchedDigits == 0
then return True
mainloop c
-- Generating Thread aka event thread generating the random numbers
generatingThread :: Chan msgChan -> IO ()
generatingThread msgChan = forever $ do
publishTimerEvent msgChan 1000000
publishTimerEvent :: Chan msgChan -> Int delay ()
publishTimerEvent msgChan = do
c <- getRandomChar
putMVar msgChan ("timer" c)
threadDelay newDelay
velocity <- 0.9
if delay * velocity < 100
then newDelay <- 100
else newDelay <- delay * velocity
publishTimerEvent msgChan newDelay
getRandomChar :: Char c ()
getRandomChar = do
i <- randomRIO (0,9)
let c = "0123456789" !! i
return c
-- User Thread
userThread :: MVar Msg -> IO ()
userThread chan = forever $ do
c <- getChar
putMVar chan (C c)
showStr(show c)
testGuessedNumber :: Int -> Int -> Bool
testGuessedNumber a b
| a == b = True
| otherwise = False
-- Shows the given string at the left edge of the current terminal line after
-- having blanked out the first 20 characters on that line.
showStr :: String -> IO ()
showStr s = putStr ("\r" ++ replicate 20 ' ' ++ "\r" ++ s)
The error is "test.hs:36:3: error: parse error on input ‘Event’"
Variable names can not begin with uppercase letters, such as Event. Try renaming the variable to something like event.
In Haskell, all if ... then ... else blocks must have all their components; what would the result be otherwise?
The problem is that the compiler was expecting an else, but it actually got Event. That said, you have more problems than a simple parse error. return does not do what you think it does. For example, this code will print hi.
main = do
return ()
putStrLn "hi"
The return function simply lifts a value into a monad, it doesn't stop the computation or anything like that. Here is what your probably want to have:
...
if length unmatchedDigits >= 10
then return False
else do
Event <- readChan c
if Event == "timer"
then ...
else ...
This way, nothing happens after the if block, so the function just ends there, with the last value as False (if length unmatchedDigits >= 10) or continues on properly (if length unmatchedDigits < 10).
You also almost certainly don't want to use Event (uppercase E), because that would mean it is a data constructor. You probably meant event (lowercase e), which is just an ordinary variable name.
Additionally: This is very, very non-idiomatic Haskell. You definitely don't need MVars in this situation, and certainly not four of them. Chans are not the same thing as MVars, and you don't need either one unless you are doing heavy-duty multi-threading. I highly recommend you completely rewrite this and try to minimize the amount of code that uses IO (it should be maybe 10-15 lines of IO code in this example, probably less).
This is not Java; you don't need to name your variables in your type signature (Chan msgChan -> Int delay ()), nor do you need to write wrapper functions for standard library functions to monomorphize their type. testGuessedNumber is literally the same function as (==).
You will have much more success if you revisit basic, pure function syntax and understand how problems are solved in Haskell than with trying to emulate another language. Read some LYAH or Real World Haskell.
EDITED 2015-11-29: see bottom
I'm trying to write an application that has a do-last-action-again button. The command in question can ask for input, and my thought for how to accomplish this was to just rerun the resulting monad with memoized IO.
There are lots of posts on SO with similar questions, but none of the solutions seem to work here.
I lifted the memoIO code from this SO answer, and changed the implementation to run over MonadIO.
-- Memoize an IO function
memoIO :: MonadIO m => m a -> m (m a)
memoIO action = do
ref <- liftIO $ newMVar Nothing
return $ do
x <- maybe action return =<< liftIO (takeMVar ref)
liftIO . putMVar ref $ Just x
return x
I've got a small repro of my app's approach, the only real difference being my app has a big transformer stack instead of just running in IO:
-- Global variable to contain the action we want to repeat
actionToRepeat :: IORef (IO String)
actionToRepeat = unsafePerformIO . newIORef $ return ""
-- Run an action and store it as the action to repeat
repeatable :: IO String -> IO String
repeatable action = do
writeIORef actionToRepeat action
action
-- Run the last action stored by repeatable
doRepeat :: IO String
doRepeat = do
x <- readIORef actionToRepeat
x
The idea being I can store an action with memoized IO in an IORef (via repeatable) when I record what was last done, and then do it again it out with doRepeat.
I test this via:
-- IO function to memoize
getName :: IO String
getName = do
putStr "name> "
getLine
main :: IO ()
main = do
repeatable $ do
memoized <- memoIO getName
name <- memoized
putStr "hello "
putStrLn name
return name
doRepeat
return ()
with expected output:
name> isovector
hello isovector
hello isovector
but actual output:
name> isovector
hello isovector
name> wasnt memoized
hello wasnt memoized
I'm not entirely sure what the issue is, or even how to go about debugging this. Gun to my head, I'd assume lazy evaluation is biting me somewhere, but I can't figure out where.
Thanks in advance!
EDIT 2015-11-29: My intended use case for this is to implement the repeat last change operator in a vim-clone. Each action can perform an arbitrary number of arbitrary IO calls, and I would like it to be able to specify which ones should be memoized (reading a file, probably not. asking the user for input, yes).
the problem is in main you are creating a new memo each time you call the action
you need to move memoized <- memoIO getName up above the action
main :: IO ()
main = do
memoized <- memoIO getName --moved above repeatable $ do
repeatable $ do
--it was here
name <- memoized
putStr "hello "
putStrLn name
return name
doRepeat
return ()
edit: is this acceptable
import Data.IORef
import System.IO.Unsafe
{-# NOINLINE actionToRepeat #-}
actionToRepeat :: IORef (IO String)
actionToRepeat = unsafePerformIO . newIORef $ return ""
type Repeatable a = IO (IO a)
-- Run an action and store the Repeatable part of the action
repeatable :: Repeatable String -> IO String
repeatable action = do
repeatAction <- action
writeIORef actionToRepeat repeatAction
repeatAction
-- Run the last action stored by repeatable
doRepeat :: IO String
doRepeat = do
x <- readIORef actionToRepeat
x
-- everything before (return $ do) is run just once
hello :: Repeatable String
hello = do
putStr "name> "
name <- getLine
return $ do
putStr "hello "
putStrLn name
return name
main :: IO ()
main = do
repeatable hello
doRepeat
return ()
I came up with a solution. It requires wrapping the original monad in a new transformer which records the results of IO and injects them the next time the underlying monad is run.
Posting it here so my answer is complete.
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
import Control.Applicative (Applicative(..))
import Data.Dynamic
import Data.Maybe (fromJust)
import Control.Monad.RWS
-- | A monad transformer adding the ability to record the results
-- of IO actions and later replay them.
newtype ReplayT m a =
ReplayT { runReplayT :: RWST () [Dynamic] [Dynamic] m a }
deriving ( Functor
, Applicative
, Monad
, MonadIO
, MonadState [Dynamic]
, MonadWriter [Dynamic]
, MonadTrans
)
-- | Removes the first element from a list State and returns it.
dequeue :: MonadState [r] m
=> m (Maybe r)
dequeue = do
get >>= \case
[] -> return Nothing
(x:xs) -> do
put xs
return $ Just x
-- | Marks an IO action to be memoized after its first invocation.
sample :: ( MonadIO m
, Typeable r)
=> IO r
-> ReplayT m r
sample action = do
a <- dequeue >>= \case
Just x -> return . fromJust $ fromDynamic x
Nothing -> liftIO action
tell [toDyn a]
return a
-- | Runs an action and records all of its sampled IO. Returns a
-- action which when invoked will use the recorded IO.
record :: Monad m
=> ReplayT m a
-> m (m a)
record action = do
(a, w) <- evalRWST (runReplayT action) () []
return $ do
evalRWST (runReplayT action) () w
return a
I'm trying to make a program that print arrows until the user press enter (see code bellow).
The problem is that when I press enter, I see the "stop" string in the console, but it doesn't change the value of m in the outputArrows function.
How can I share the state?
import Control.Concurrent
import Control.Concurrent.Async
import Control.Monad
waitForInput m = do
getLine
putStrLn "stop"
putMVar m True
outputArrows m = do
stop <- readMVar m
unless stop $ do
threadDelay 1000000
putStr ">"
outputArrows m
main = do
m <- newMVar False
th1 <- async (waitForInput m)
th2 <- async (outputArrows m)
wait th1
wait th2
Your putMVar doesn't actually put a new value in the MVar but blocks indefinitely. MVars are like boxes that can hold only a single value. If you want to replace the value, you need to take out the old value first.
If you don't need the blocking behavior of MVar, you should just use a regular IORef or possibly a TVar if you need to ensure that more complex operations run atomically.
You should use swapMVar instead of putMVar. As mentioned by #shang, putMVar blocks until the MVar is empty, so the putMVar never finishes:
waitForInput m = do
getLine
putStrLn "stop"
swapMVar m True
Alternatively, you could just use an empty MVar () as a boolean flag:
waitForInput :: MVar () -> IO ()
waitForInput m = do
getLine
putStrLn "stop"
putMVar m ()
outputArrows :: MVar () -> IO ()
outputArrows m = do
running <- isEmptyMVar m
when running $ do
threadDelay 1000000
putStr ">"
outputArrows m
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
m <- newEmptyMVar
th1 <- async (waitForInput m)
th2 <- async (outputArrows m)
wait th1
wait th2
I'm trying to write a convenient abstraction to thottle api calls. The API calls will be some kind of HTTP request. I want to be able to write all the app logic as if I were just in the IO Monad but then have the abstraction throttle the calls for me so I don't surpass some predefined limit. Having these calls run asynchronously would be nice. Right now I have this.
data APICallStats = APICallStats
{
startTime :: !UTCTime
, requestCount :: !Int
, tps :: !Int
} deriving Show
newtype APICall a = APICall (IO a)
initStats :: Int -> IO APICallStats
initStats limit = APICallStats <$> getCurrentTime <*> pure 0 <*> pure limit
makeCall :: MVar APICallStats -> APICall a -> IO a
makeCall mv (APICall f) = do
(APICallStats st c t) <- readMVar mv
now <- getCurrentTime
let inSeconds = realToFrac (diffUTCTime now st) :: Double
cp1 = fromIntegral (c+1)
td = fromIntegral t
when (cp1 / inSeconds > td)
(threadDelay (round $ (cp1 / td - inSeconds)*1000000))
modifyMVar_ mv
(\(APICallStats start req ts) -> return $ APICallStats start (req+1) ts)
f
And I can test it like this. And it works fine in a single or multiple threads because of the MVar.
testCall :: String -> APICall ()
testCall id = APICall (getCurrentTime >>= (putStrLn . ((++) (id ++ " ")) . show))
test :: IO ()
test = do
mv <- initStats 1 >>= newMVar
forever $ makeCall mv (testCall "")
threadedTest :: IO ()
threadedTest = do
mv <- initStats 1 >>= newMVar
threadId <- forkIO $ forever $ makeCall mv (testCall "thread0")
forever $ makeCall mv (testCall "main thread")
killThread threadId
This is nice and all but it is not as abstract as I want it to be. Since there will only be a couple specific API calls I can have them return the type APICall a. And then make this a monad that is an instance of MonadIO so I can just write my logic and use liftIO when I need to. But I'm unsure if I would be able to make this a monad that didn't break the laws and how exactly to go about it.
EDIT
I think I've gotten pretty close to what I want it to do.
withThrottle :: Int -> StateT (MVar APICallStats) IO a -> IO a
withThrottle limit f = do
mv <- initStats limit >>= newMVar
evalStateT f mv
process :: APICall a -> StateT (MVar APICallStats) IO a
process a = do
mv <- get
liftIO $ makeCall mv a
With this I can write something like this.
stateTest = do
withThrottle 2 $ do
process (testCall "")
process (testCall "")
process (testCall "")
liftIO $ threadDelay 10000000 -- Some long computation
process (testCall "")
process (testCall "")
process (testCall "")
process (testCall "")
With a long running app the entire thing can run is this monad. This will guarantee that It doesn't make too many outside API calls over the lifetime of the service. I just don't want the state monad. Just something that is MonadIO. So I think I just need to hide that and I'll be done. But the solution isn't very pretty so other suggestions welcome.
The current version of the Pipes tutorial, uses the following two functions in one of the example:
stdout :: () -> Consumer String IO r
stdout () = forever $ do
str <- request ()
lift $ putStrLn str
stdin :: () -> Producer String IO ()
stdin () = loop
where
loop = do
eof <- lift $ IO.hIsEOF IO.stdin
unless eof $ do
str <- lift getLine
respond str
loop
As is mentinoed in the tutorial itself, P.stdin is a bit more complicated due to the need to check for the end of input.
Are there any nice ways to rewrite P.stdin to not need a manual tail recursive loop and use higher order control flow combinators like P.stdout does? In an imperative language I would use a structured while loop or a break statement to do the same thing:
while(not IO.isEOF(IO.stdin) ){
str <- getLine()
respond(str)
}
forever(){
if(IO.isEOF(IO.stdin) ){ break }
str <- getLine()
respond(str)
}
I prefer the following:
import Control.Monad
import Control.Monad.Trans.Either
loop :: (Monad m) => EitherT e m a -> m e
loop = liftM (either id id) . runEitherT . forever
-- I'd prefer 'break', but that's in the Prelude
quit :: (Monad m) => e -> EitherT e m r
quit = left
You use it like this:
import Pipes
import qualified System.IO as IO
stdin :: () -> Producer String IO ()
stdin () = loop $ do
eof <- lift $ lift $ IO.hIsEOF IO.stdin
if eof
then quit ()
else do
str <- lift $ lift getLine
lift $ respond str
See this blog post where I explain this technique.
The only reason I don't use that in the tutorial is that I consider it less beginner-friendly.
Looks like a job for whileM_:
stdin () = whileM_ (lift . fmap not $ IO.hIsEOF IO.stdin) (lift getLine >>= respond)
or, using do-notation similarly to the original example:
stdin () =
whileM_ (lift . fmap not $ IO.hIsEOF IO.stdin) $ do
str <- lift getLine
respond str
The monad-loops package offers also whileM which returns a list of intermediate results instead of ignoring the results of the repeated action, and other useful combinators.
Since there is no implicit flow there is no such thing like "break". Moreover your sample already is small block which will be used in more complicated code.
If you want to stop "producing strings" it should be supported by your abstraction. I.e. some "managment" of "pipes" using special monad in Consumer and/or other monads that related with this one.
You can simply import System.Exit, and use exitWith ExitSuccess
Eg. if (input == 'q')
then exitWith ExitSuccess
else print 5 (anything)