I have a code that reads files and parses using UU.Parsing lib that returns an abstract sintax tree and shows on the screen.
I received the error message "No instance for Show" in my functions originated in tokensParserToByteString and applyParser using parseIO (of UU.Parsing lib) and inherited signatures until main. I fixed the signatures but my problem is in the main function. I added the instance Show in the signature but I have the next compilation error:
No instance for (Show (IO J2s)) arising from a use of ‘main’
In the expression: main
When checking the type of the IO action ‘main’
The complete error message is:
$ cabal build
Building java2scala-1.0...
Preprocessing library java2scala-1.0...
In-place registering java2scala-1.0...
Preprocessing executable 'java2scala' for java2scala-1.0...
Preprocessing executable 'test' for java2scala-1.0...
[5 of 5] Compiling Main ( test/Main.hs, dist/build/test/test-tmp/Main.o )
test/Main.hs:27:1:
No instance for (Show (IO J2s)) arising from a use of ‘main’
In the expression: main
When checking the type of the IO action ‘main’
Some idea, about the problem?
Main module
{-# LANGUAGE FlexibleContexts #-}
module Main where
import UU.Parsing
...
import Content
main :: (Show (IO J2s)) => IO()
main = do f <- getLine
let command = test f
command
test :: (Show (IO J2s)) => String -> IO()
test "testparser" = testParser
Test module
{-# LANGUAGE FlexibleContexts #-}
module J2s.Parser.Test where
import Content
import J2s.Ast.Sintax
import J2s.Parser
import UU.Parsing
...
testParser :: (Show (IO J2s)) => IO()
testParser = (runSafeIO $ runProxy $ runEitherK $
contentsRecursive "path/of/my/tests" />/ handlerParser) :: (Show (IO J2s)) => IO()
Content module
{-# LANGUAGE FlexibleContexts #-}
module Content where
import Control.Monad(forM, liftM)
import System.Directory (doesDirectoryExist, getDirectoryContents)
import System.FilePath ((</>), splitExtension, splitFileName)
import J2s.Parser
import J2s.Ast.Sintax
import UU.Parsing
import Control.Monad (when, unless)
import Control.Proxy
import Control.Proxy.Safe hiding (readFileS)
import J2s.Scanner.Token
import Text.Show
import UU.Parsing
contentsRecursive
:: (CheckP p)
=> FilePath -> () -> Producer (ExceptionP p) FilePath SafeIO ()
contentsRecursive path () = loop path
where
loop path = do
contents path () //> \newPath -> do
respond newPath
isDir <- tryIO $ doesDirectoryExist newPath
let isChild = not $ takeFileName newPath `elem` [".", ".."]
when (isDir && isChild) $ loop newPath
applyParser :: (Proxy p, Show (IO J2s)) => String -> Consumer p B.ByteString IO ()
applyParser path = runIdentityP loop
where
loop = do
bs <- request ()
let sc = classify (initPos path) (B8.unpack bs)
lift $ B8.putStrLn (tokensParserToByteString sc)
tokensParserToByteString :: (Show (IO J2s)) => [Token] -> B.ByteString
tokensParserToByteString tokens = B8.pack(show (parseIO pJ2s tokens))
handlerParser :: (CheckP p, Show (IO J2s)) => FilePath -> Session (ExceptionP p) SafeIO ()
handlerParser path = do
canRead <- tryIO $ fmap readable $ getPermissions path
isDir <- tryIO $ doesDirectoryExist path
isValidExtension <- tryIO $ evaluate ((snd (splitExtension path) == ".java" || snd (splitExtension path) == ".mora") && (snd (splitFileName path) /= "EncodeTest.java") && (snd (splitFileName path) /= "T6302184.java") && (snd (splitFileName path) /= "Unmappable.java"))
when (not isDir && canRead && isValidExtension) $
(readFileSP 10240 path >-> try . applyParser) path
readFileSP
:: (CheckP p)
=> Int -> FilePath -> () -> Producer (ExceptionP p) B.ByteString SafeIO ()
readFileSP chunkSize path () =
bracket id (openFile path ReadMode) hClose $ \handle -> do
let loop = do
eof <- tryIO $ hIsEOF handle
unless eof $ do
bs <- tryIO $ B.hGetSome handle chunkSize
respond bs
loop
loop
A signature like Show (IO J2s) => IO () almost never makes sense. What this expresses is basically “provided the universe is crafted such that IO J2s has a Show instance, I give you an IO () action”. Well, if the universe has that property, then give us IO () action right now. Keep nasty chipsconstraints!
Constraints only really make sense if you apply them to type variables, i.e. if you're writing code that's polymorphic over several different, but not all types. (Like with CheckP p). But a constraint applied to concrete types does little more than defer type errors.
IO J2s has no Show instance. And it can't have such an instance: this is an IO action. It could be a complete subprogram that might execute costly computations, call commercial third-party library code, launch some missiles... and only in the very end return a J2s value. How do you expect to pack all the information of something so possibly complex into a simple string?
What possibly does have a Show instance is J2s. If you're in the IO monad anyway and have an IO J2s action, you can at any point fetch the J2s value from it by monad-binding that action (i.e. executing the subprogram) and just showing the J2s value. In your case:
tokensParserToByteString :: [Token] -> IO B.ByteString
tokensParserToByteString tokens = fmap (B8.pack . show) $ parseIO pJ2s tokens
I case you're confused about fmapping in the IO functor, this is equivalent to
tokensParserToByteString :: [Token] -> IO B.ByteString
tokensParserToByteString tokens = do
j2sValue <- parseIO pJ2s tokens
return . B8.pack $ show j2sValue
Of course you then need to adapt applyParser because tokensParserToByteString is now an IO action. Easy enough with the =<< operator:
applyParser :: Proxy p => String -> Consumer p B.ByteString IO ()
applyParser path = runIdentityP loop
where
loop = do
bs <- request ()
let sc = classify (initPos path) (B8.unpack bs)
lift $ B8.putStrLn =<< tokensParserToByteString sc
UPDATE: there is a issue in ghcjs: https://github.com/ghcjs/ghcjs/issues/296
i play with ghcjs and sodium but after 3 seconds my application doesn't emit events anymore.
a minimal example:
a button: emit events
a counter behavior: counts the button clicks
a div: displays the counter behavior
after 3 seconds, the div doesn't update anymore
if i reload the page, the counter updates again - for 3 seconds
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Control.Applicative ((<$>))
import Control.Concurrent (forkIO, threadDelay)
import Control.Monad (forever)
import Data.Default (def)
import Data.Text (Text, pack)
import FRP.Sodium
import JavaScript.JQuery hiding (Event)
main :: IO ()
main = do
body <- select "body"
-- a button
(btn, btnE) <- mkBtnE "Click"
appendJQuery btn body
-- a behavior: counter - increment when btnE (button event) arrive
counterB <- sync $ accum 0 (const (+1) <$> btnE)
-- a div with the counter value
counterView <- mkDiv $ fmap (pack . show) counterB
appendJQuery counterView body
-- wait -> nothing changed
-- forkIO $ forever (threadDelay 1000000000)
return ()
mkBtn :: Text -> IO JQuery
mkBtn label = select "<button/>" >>= setText label
mkBtnE :: Text -> IO (JQuery, Event ())
mkBtnE label = do
(e, t) <- sync newEvent
btn <- mkBtn label
on (const $ sync $ t ()) "click" def btn
return (btn, e)
mkDiv :: Behaviour Text -> IO JQuery
mkDiv b = do
div <- select "<div/>"
sync $ listen (value b) (\t -> setText t div >> return ())
return div
The full example is under https://github.com/j-keck/ghcjs-sodium
thanks
I've read Happstack crashcourse. My web server has almost exact way described in the section Passing multiple AcidState handles around transparently
Problem I have is that, I have value which is non-acidic, but want to access within the Happstack application. Specifically speaking, "PushManager" from push-notify-general library,
What I wanted is:
data Acid = Acid
{ acidCountState :: AcidState CountState
, acidGreetingState :: AcidState GreetingState
, acidPushManager :: AcidState PushManager
}
I couldn't make this work, because 1) PushManager use so many data types internally, and it is not realistic/robust to make underlying data type SafeCopy compatible by calling $(deriveSafeCopy ...). 2) PushManager not only contains simple value, but also function which is SafeCopy compatible.
Other thing I tried is to "Acid" data declaration to carry not only AcidState, but also non-AcidState data. By looking at the definition of runApp, "Acid" is just used for Reading, so I thought that rewriting with State monad may be able to achive my need. - but it turns out that it was not so simple. My tentative code is:
{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving,
TemplateHaskell, TypeFamilies, DeriveDataTypeable,
FlexibleContexts, ScopedTypeVariables,
NamedFieldPuns, DeriveFunctor, StandaloneDeriving, OverloadedStrings #-}
import Control.Applicative ( Applicative, Alternative, (<$>))
import Control.Monad ( MonadPlus )
import Control.Monad.State.Strict ( MonadState, StateT, get, put, evalStateT )
import Control.Monad.Trans ( MonadIO )
import Data.Acid
import Data.Data ( Data, Typeable )
import Happstack.Server
newtype Simple a = Simple { unSimple :: a }
deriving (Show)
data CountState = CountState { count :: Integer }
deriving (Eq, Ord, Data, Typeable, Show)
-- This data is equivalent to the one previously called "Acid"
data States = States {
simpleState :: Simple Int
, acidCountState :: AcidState CountState
}
initialStates :: States
initialStates = States { simpleState = Simple 1, acidCountState = undefined }
newtype App a = App { unApp :: ServerPartT (StateT States IO) a }
deriving ( Functor, Alternative, Applicative, Monad
, MonadPlus, MonadIO, HasRqData, ServerMonad
, WebMonad Response, FilterMonad Response
, Happstack, MonadState States )
class HasSimple m st where
getSimple :: m (Simple st)
putSimple :: (Simple st) -> m ()
instance HasSimple App Int where
getSimple = simpleState <$> get
putSimple input = do
whole <- get
put $ whole {simpleState = input}
simpleQuery :: ( Functor m
, HasSimple m a
, MonadIO m
, Show a
) =>
m a
simpleQuery = do
(Simple a) <- getSimple
return a
simpleUpdate :: ( Functor m
, HasSimple m a
, MonadIO m
, Show a
) =>
a
-> m ()
simpleUpdate a = putSimple (Simple a)
runApp :: States -> App a -> ServerPartT IO a
runApp states (App sp) = do
mapServerPartT (flip evalStateT states) sp
rootDir :: App Response
rootDir = do
intVal <- simpleQuery
let newIntVal :: Int
newIntVal = intVal + 1
simpleUpdate newIntVal
ok $ toResponse $ ("hello number:" ++ (show newIntVal))
main :: IO ()
main = do
simpleHTTP nullConf $ runApp initialStates rootDir
It compiled, but every time web page is requested, the page display same number. Looking at my code again, and I felt that evalStateT in runApp is wrong, because it never use updated state value.
Now, I am reading mapServerPartT and ServerPartT, but that is too complex.
Appreciate if anybody can answer the title line: "How to carry non-Acidic value in Happstack?"
The mapServerPartT would not help you either. The issue here is that the handler function you pass to simpleHTTP gets called in a new thread for each request that comes in. And each time it is going to be calling runApp with the initialStates argument. So not only is the value lost at the end of the request, but if multiple threads are handling requests, they will each have their own separate copy of the state.
Once we realize that we want state that is shared between multiple threads, we realize that the answer must rely on one of the tools for doing interthread communication. A good choice would probably be a TVar, http://hackage.haskell.org/package/stm-2.4.3/docs/Control-Concurrent-STM-TVar.html
main :: IO ()
main = do
states <- atomically $ newTVar initialStates
simpleHTTP nullConf $ runApp states rootDir
Note that we create the TVar before we start listening for incoming connections. We pass the TVar to all the request handling threads, and STM takes care of synchronizing the values between threads.
a TVar is a bit like acid-state without the (D)urability. Since the data does not need to be saved, there is no need for SafeCopy instances, etc.
Based on stepcut's Answer, I was able to carry non-acidic value within Happstack using TVar.
If anybody is interested in, here is simplified code:
https://gist.github.com/anonymous/5686161783fd53c4e413
And this is full version which carries both "AcidState CountState" and "TVar CountState".
{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving,
TemplateHaskell, TypeFamilies, DeriveDataTypeable,
FlexibleContexts, ScopedTypeVariables,
NamedFieldPuns, DeriveFunctor, StandaloneDeriving, OverloadedStrings,
RecordWildCards #-}
import Happstack.Server
import Control.Applicative ( Applicative, Alternative, (<$>))
import Control.Monad ( MonadPlus, msum )
import Control.Monad.Reader ( MonadReader, ReaderT(..), ask)
import Control.Monad.State (get, put)
import Control.Monad.Trans ( MonadIO, liftIO )
import Control.Monad.Trans.Control ( MonadBaseControl )
import Data.Maybe (fromMaybe)
import Control.Exception
import Control.Concurrent.STM
import Control.Concurrent.STM.TVar
import Data.Acid hiding (update)
import Data.Acid.Advanced (query', update')
import Data.Acid.Local
import Data.SafeCopy
import Data.Data ( Data, Typeable )
import System.FilePath ((</>))
data CountState = CountState { count :: Integer }
deriving (Eq, Ord, Data, Typeable, Show)
$(deriveSafeCopy 0 'base ''CountState)
initialCountState :: CountState
initialCountState = CountState { count = 0 }
-- for AcidState
incCount :: Update CountState Integer
incCount =
do (CountState c) <- get
let c' = succ c
put (CountState c')
return c'
$(makeAcidic ''CountState ['incCount])
-- for TVar
incCountState :: App Integer
incCountState = do
(_, CountState newVal) <- updateTVar incCount'
return newVal
where
incCount' :: CountState -> CountState
incCount' (CountState c) = CountState $ succ c
data Aci = Aci
{ acidCountState :: AcidState CountState
, tvarCountState :: TVar CountState
}
withAci :: Maybe FilePath -> (Aci -> IO a) -> IO a
withAci mBasePath action = do
initialTVarCount <- newTVarIO initialCountState
let basePath = fromMaybe "_state" mBasePath
countPath = Just $ basePath </> "count"
in withLocalState countPath initialCountState $ \c ->
action (Aci c initialTVarCount)
-- for AcidState
class HasAcidState m st where
getAcidState :: m (AcidState st)
query :: forall event m.
( Functor m
, MonadIO m
, QueryEvent event
, HasAcidState m (EventState event)
) =>
event
-> m (EventResult event)
query event =
do as <- getAcidState
query' (as :: AcidState (EventState event)) event
update :: forall event m.
( Functor m
, MonadIO m
, UpdateEvent event
, HasAcidState m (EventState event)
) =>
event
-> m (EventResult event)
update event =
do as <- getAcidState
update' (as :: AcidState (EventState event)) event
-- for TVar
class HasTVarState m st where
getTVarState :: m (TVar st)
instance HasTVarState App CountState where
getTVarState = tvarCountState <$> ask
queryTVar :: ( HasTVarState m a
, MonadIO m
) => m a
queryTVar = do
as <- getTVarState
liftIO $ readTVarIO as
updateTVar :: ( HasTVarState m a
, MonadIO m ) =>
(a -> a) -- ^ function to modify value
-> m (a, a) -- ^ return value - "before change" and "after change"
updateTVar func = do
as <- getTVarState
liftIO $ atomically $ do -- STM
prevVal <- readTVar as
let newVal = func prevVal
writeTVar as newVal
return (prevVal, newVal)
-- | same as updateTVar, except no return
updateTVar_ :: ( HasTVarState m a
, MonadIO m ) =>
(a -> a) -- ^ function to modify value
-> m ()
updateTVar_ func = do
as <- getTVarState
liftIO $ atomically $ modifyTVar as func
withLocalState
:: ( IsAcidic st
, Typeable st
) =>
Maybe FilePath -- ^ path to state directory
-> st -- ^ initial state value
-> (AcidState st -> IO a) -- ^ function which uses the
-- `AcidState` handle
-> IO a
withLocalState mPath initialState =
bracket (liftIO $ open initialState)
(liftIO . createCheckpointAndClose)
where
open = maybe openLocalState openLocalStateFrom mPath
newtype App a = App { unApp :: ServerPartT (ReaderT Aci IO) a }
deriving ( Functor, Alternative, Applicative, Monad
, MonadPlus, MonadIO, HasRqData, ServerMonad
, WebMonad Response, FilterMonad Response
, Happstack, MonadReader Aci )
runApp :: Aci -> App a -> ServerPartT IO a
runApp aci (App sp) = do
mapServerPartT (flip runReaderT aci) sp
instance HasAcidState App CountState where
getAcidState = acidCountState <$> ask
acidCounter :: App Response
acidCounter = do
c <- update IncCount -- ^ a CountState event
ok $ toResponse $ ("hello number acid:" ++ (show c))
tvarCounter :: App Response
tvarCounter = do
c <- incCountState
ok $ toResponse $ ("hello number tvar:" ++ (show c))
rootDir :: App Response
rootDir = do
msum
[ dir "favicon.ico" $ notFound (toResponse ())
, dir "acidCounter" acidCounter
, dir "tvarCounter" tvarCounter
, ok $ toResponse ("access /acidCounter or /tvarCounter" :: String)
]
main :: IO ()
main = do
withAci Nothing $ \aci ->
simpleHTTP nullConf $ runApp aci rootDir
I'm processing some audio using portaudio. The haskell FFI bindings call a user defined callback whenever there's audio data to be processed. This callback should be handled very quickly and ideally with no I/O. I wanted to save the audio input and return quickly since my application doesn't need to react to the audio in realtime (right now I'm just saving the audio data to a file; later I'll construct a simple speech recognition system).
I like the idea of pipes and thought I could use that library. The problem is that I don't know how to create a Producer that returns data that came in through a callback.
How do I handle my use case?
Here's what I'm working with right now, in case that helps (the datum mvar isn't working right now but I don't like storing all the data in a seq... I'd rather process it as it came instead of just at the end):
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
module Main where
import Codec.Wav
import Sound.PortAudio
import Sound.PortAudio.Base
import Sound.PortAudio.Buffer
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.C.Types
import Foreign.Storable
import qualified Data.StorableVector as SV
import qualified Data.StorableVector.Base as SVB
import Control.Exception.Base (evaluate)
import Data.Int
import Data.Sequence as Seq
import Control.Concurrent
instance Buffer SV.Vector a where
fromForeignPtr fp = return . SVB.fromForeignPtr fp
toForeignPtr = return . (\(a, b, c) -> (a, c)) . SVB.toForeignPtr
-- | Wrap a buffer callback into the generic stream callback type.
buffCBtoRawCB' :: (StreamFormat input, StreamFormat output, Buffer a input, Buffer b output) =>
BuffStreamCallback input output a b -> StreamCallback input output
buffCBtoRawCB' func = \a b c d e -> do
fpA <- newForeignPtr_ d -- We will not free, as callback system will do that for us
fpB <- newForeignPtr_ e -- We will not free, as callback system will do that for us
storeInp <- fromForeignPtr fpA (fromIntegral $ 1 * c)
storeOut <- fromForeignPtr fpB (fromIntegral $ 0 * c)
func a b c storeInp storeOut
callback :: MVar (Seq.Seq [Int32]) -> PaStreamCallbackTimeInfo -> [StreamCallbackFlag] -> CULong
-> SV.Vector Int32 -> SV.Vector Int32 -> IO StreamResult
callback seqmvar = \timeinfo flags numsamples input output -> do
putStrLn $ "timeinfo: " ++ show timeinfo ++ "; flags are " ++ show flags ++ " in callback with " ++ show numsamples ++ " samples."
print input
-- write data to output
--mapM_ (uncurry $ pokeElemOff output) $ zip (map fromIntegral [0..(numsamples-1)]) datum
--print "wrote data"
input' <- evaluate $ SV.unpack input
modifyMVar_ seqmvar (\s -> return $ s Seq.|> input')
case flags of
[] -> return $ if unPaTime (outputBufferDacTime timeinfo) > 0.2 then Complete else Continue
_ -> return Complete
done doneMVar = do
putStrLn "total done dood!"
putMVar doneMVar True
return ()
main = do
let samplerate = 16000
Nothing <- initialize
print "initialized"
m <- newEmptyMVar
datum <- newMVar Seq.empty
Right s <- openDefaultStream 1 0 samplerate Nothing (Just $ buffCBtoRawCB' (callback datum)) (Just $ done m)
startStream s
_ <- takeMVar m -- wait until our callbacks decide they are done!
Nothing <- terminate
print "let's see what we've recorded..."
stuff <- takeMVar datum
print stuff
-- write out wav file
-- let datum =
-- audio = Audio { sampleRate = samplerate
-- , channelNumber = 1
-- , sampleData = datum
-- }
-- exportFile "foo.wav" audio
print "main done"
The simplest solution is to use MVars to communicate between the callback and Producer. Here's how:
import Control.Proxy
import Control.Concurrent.MVar
fromMVar :: (Proxy p) => MVar (Maybe a) -> () -> Producer p a IO ()
fromMVar mvar () = runIdentityP loop where
loop = do
ma <- lift $ takeMVar mvar
case ma of
Nothing -> return ()
Just a -> do
respond a
loop
Your stream callback will write Just input to the MVar and your finalization callback will write Nothing to terminate the Producer.
Here's a ghci example demonstrating how it works:
>>> mvar <- newEmptyMVar :: IO (MVar (Maybe Int))
>>> forkIO $ runProxy $ fromMVar mvar >-> printD
>>> putMVar mvar (Just 1)
1
>>> putMVar mvar (Just 2)
2
>>> putMVar mvar Nothing
>>> putMVar mvar (Just 3)
>>>
Edit: The pipes-concurrency library now provides this feature, and it even has a section in the tutorial explaining specifically how to use it to get data out of callbacks.
how could one implement a function in concurrent haskell that either returns 'a' successfully or due to timeout 'b'?
timed :: Int → IO a → b → IO (Either a b)
timed max act def = do
Best Regards,
Cetin SertNote: the signature of timed can be completely or slightly different.
Implementing your desired timed on top of System.Timeout.timeout is easy:
import System.Timeout (timeout)
timed :: Int -> IO a -> b -> IO (Either b a)
timed us act def = liftM (maybe (Left def) Right) (timeout us act)
By the way, the common implementation of timeout is closer to this: ($! = seq to try to force evaluation of the returned value in the thread rather than only returning a thunk):
import Control.Concurrent (forkIO, threadDelay, killThread)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import System.IO (hPrint, stderr)
timeout :: Int -> IO a -> IO (Maybe a)
timeout us act = do
mvar <- newEmptyMVar
tid1 <- forkIO $ (putMVar mvar . Just $!) =<< act
tid2 <- forkIO $ threadDelay us >> putMVar mvar Nothing
res <- takeMVar mvar
killThread (maybe tid1 (const tid2) res) `catch` hPrint stderr
return res
The implementation of System.Timeout.timeout in the libraries is a little more complex, handling more exceptional cases.
import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)
import Control.Exception (Exception, handleJust, throwTo, bracket)
import Data.Typeable
import Data.Unique (Unique, newUnique)
data Timeout = Timeout Unique deriving Eq
timeoutTc :: TyCon
timeoutTc = mkTyCon "Timeout"
instance Typeable Timeout where { typeOf _ = mkTyConApp timeoutTc [] }
instance Show Timeout where
show _ = "<<timeout>>"
instance Exception Timeout
timeout n f
| n < 0 = fmap Just f
| n == 0 = return Nothing
| otherwise = do
pid <- myThreadId
ex <- fmap Timeout newUnique
handleJust (\e -> if e == ex then Just () else Nothing)
(\_ -> return Nothing)
(bracket (forkIO (threadDelay n >> throwTo pid ex))
(killThread)
(\_ -> fmap Just f))
Here's the first answer I could come up with. I needed this for a port scanner. o_O Forgot the admin password of my router and wanted to check which ports I had opened on our home server before that I could now repurpose and reuse ^ _ ^" ... This implementation should do the job for the time being.
module Control.Concurrent.Timed (timed) where
import Prelude hiding (take)
import System.IO
import Control.Monad
import System.Process
import System.Timeout
import Control.Concurrent
import System.Environment
timed :: Int → IO a → b → IO (Either b a)
timed max act def = do
w ← new
r ← new
t ← forkIO $ do
a ← act
r ≔ Right a
e ← em w
case e of
False → kill =<< take w
True → return ()
s ← forkIO $ do
(w ≔) =<< mine
wait max
e ← em r
case e of
True → do
kill t
r ≔ Left def
False → return ()
take r
timed_ :: Int → IO a → a → IO a
timed_ max act def = do
r ← timed max act def
return $ case r of
Right a → a
Left a → a
(≔) = putMVar
new = newEmptyMVar
wait = threadDelay
em = isEmptyMVar
kill = killThread
mine = myThreadId
take = takeMVar
or just use System.Timeout.timeout -__-"