We've seen a few functions that "return" any type
undefined :: a
error :: String -> a
These functions throw language-level exceptions
Control.Exception
as follows:import Prelude hiding (catch) -- not necessary with new GHCs
import Control.Exception
Older Prelude
s have an old, less general version of catch
you should avoid (hiding
keyword prevents import of specific symbols)
Control.Exception
gives you access to the following symbols:
class (Typeable e, Show e) => Exception e where ...
throw :: Exception e => e -> a
throwIO :: Exception e => e -> IO a
catch :: Exception e => IO a -> (e -> IO a) -> IO a
{-# LANGUAGE DeriveDataTypeable #-}
import Prelude hiding (catch)
import Control.Exception
import Data.Typeable
data MyError = MyError String deriving (Show, Typeable)
instance Exception MyError
catcher :: IO a -> IO (Maybe a)
catcher action = fmap Just action `catch` handler
where handler (MyError msg) = do putStrLn msg; return Nothing
*Main> catcher $ readFile "/dev/null"
Just ""
*Main> catcher $ throwIO $ MyError "something bad"
something bad
Nothing
DeriveDataTypeable
language pragma (later lecture)handler
's type cannot be inferred (use constructor or type signature)
e@(SomeException _)
catches all exceptionscatcher
around an IO actionthrow
exceptions in pure code, yet catch
them only in IO
(error "one") + (error "two")
?catch
is restricted to the IO
MonadIn IO
, use throwIO
(not throw
) to make exception sequencing precise
do x <- throwIO (MyError "one") -- this exception thrown
y <- throwIO (MyError "two") -- this code not reached
return $ x + y
throw
only where you can't use throwIO
Pure exceptions quite useful for errors & unimplemented code, E.g.:
-- Simplified version of functions in standard Prelude:
error :: String -> a
error a = throw (ErrorCall a)
undefined :: a
undefined = error "Prelude.undefined"
Consider the following function
pureCatcher :: a -> IO (Maybe a)
pureCatcher a = (a `seq` return (Just a))
`catch` \(SomeException _) -> return Nothing
pureCatcher $ 1 + 1
Just 2
*Main> pureCatcher $ 1 `div` 0
Nothing
*Main> pureCatcher (undefined :: String)
Nothing
What happens if you do this?
*Main> pureCatcher (undefined:undefined :: String)
Consider the following function
pureCatcher :: a -> IO (Maybe a)
pureCatcher a = (a `seq` return (Just a))
`catch` \(SomeException _) -> return Nothing
pureCatcher $ 1 + 1
Just 2
*Main> pureCatcher $ 1 `div` 0
Nothing
*Main> pureCatcher (undefined :: String)
Nothing
What happens if you do this?
*Main> pureCatcher (undefined:undefined :: String)
Just "*** Exception: Prelude.undefined
Consider the following function
pureCatcher :: a -> IO (Maybe a)
pureCatcher a = (a `seq` return (Just a))
`catch` \(SomeException _) -> return Nothing
pureCatcher $ 1 + 1
Just 2
*Main> pureCatcher $ 1 `div` 0
Nothing
*Main> pureCatcher (undefined :: String)
Nothing
What happens if you do this?
*Main> pureCatcher (undefined:undefined :: String)
Just "*** Exception: Prelude.undefined
catch
only catches exceptions when thunks actually evaluated!
Evaluating a list does not evaluate the head or tail
*Main> seq (undefined:undefined) ()
()
(:)
or []
)Exercise: Force evaluation of every element of a list
seq
-like function with the following signature, that evaluates every element of list before evaluating second argumentseqList :: [a] -> b -> b
*Main> seqList [1, 2, 3] ()
()
*Main> seqList [1, 2, 3, undefined] ()
*** Exception: Prelude.undefined
seqList :: [a] -> b -> b
seqList [] b = b
seqList (a:as) b = seq a $ seqList as b
deepseq
in library of same name that does this for many common data typestry
returns Right a
normally, Left e
if an exception occurred
try :: Exception e => IO a -> IO (Either e a)
finally
and onException
run an clean-up action
finally :: IO a -> IO b -> IO a -- cleanup always
onException :: IO a -> IO b -> IO a -- after exception
b
) is discardedcatchJust
catches only exceptions matching a predicate on value
catchJust :: Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
readFileIfExists f = catchJust p (readFile f) (\_ -> return "")
where p e = if isDoesNotExistError e then Just e else Nothing
*Main> readFileIfExists "/nosuchfile"
""
*Main> readFileIfExists "/etc/shadow"
*** Exception: /etc/shadow: openFile: permission denied ...
IO
actions
IO
monadIO
also can't catch exceptionsMaybe
Monad, where can use Nothing
to indicate failureinstance Monad Maybe where
(Just x) >>= k = k x
Nothing >>= _ = Nothing
return = Just
fail _ = Nothing
fail
method called when bind pattern matches fail in do
block*Main> (do 1 <- return 2; return 3) :: Maybe Int
Nothing
Haskell implements user-level threads in Control.Concurrent
forkIO
call creates a new thread:
forkIO :: IO () -> IO ThreadId -- creates a new thread
A few other very useful thread functions:
throwTo :: Exception e => ThreadId -> e -> IO ()
killThread :: ThreadId -> IO () -- = flip throwTo ThreadKilled
threadDelay :: Int -> IO () -- sleeps for # of µsec
myThreadId :: IO ThreadId
IO
action, or abort after # of µsec
System.Timeout
has a slightly better version of this functiondata TimedOut = TimedOut UTCTime deriving (Eq, Show, Typeable)
instance Exception TimedOut
timeout :: Int -> IO a -> IO (Maybe a)
timeout usec action = do
-- Create unique exception val (for nested timeouts):
expired <- fmap TimedOut getCurrentTime
ptid <- myThreadId
let child = do threadDelay usec
throwTo ptid expired
parent = do ctid <- forkIO child
result <- action
killThread ctid
return $ Just result
catchJust (\e -> if e == expired then Just e else Nothing)
parent
(\_ -> return Nothing)
MVar
sThe MVar
type lets threads communicate via shared variables
MVar t
is a mutable variable of type t
that is either full or emptynewEmptyMVar :: IO (MVar a) -- create empty MVar
newMVar :: a -> IO (MVar a) -- create full MVar given val
takeMVar :: MVar a -> IO a
putMVar :: MVar a -> a -> IO ()
MVar
is full, takeMVar
makes it empty and returns former contentsMVar
is empty, putMVar
fills it with a valueMVar
or putting a full one puts thread to sleep until MVar
becomes availableMVar
MVar
callstryTakeMVar :: MVar a -> IO (Maybe a) -- Nothing if empty
tryPutMVar :: MVar a -> a -> IO Bool -- False if full
import Control.Concurrent
import Control.Exception
import Control.Monad
pingpong :: Bool -> Int -> IO ()
pingpong v n = do
mvc <- newEmptyMVar -- MVar read by child
mvp <- newEmptyMVar -- MVar read by parent
let parent n | n > 0 = do when v $ putStr $ " " ++ show n
putMVar mvc n
takeMVar mvp >>= parent
| otherwise = return ()
child = do n <- takeMVar mvc
putMVar mvp (n - 1)
child
tid <- forkIO child
parent n `finally` killThread tid
when v $ putStrLn ""
*Main> pingpong True 10
10 9 8 7 6 5 4 3 2 1
import Criterion.Main
...
main :: IO ()
main = defaultMain [
bench "thread switch test" mybench
]
where mybench = pingpong False 10000
$ ghc -O pingpong.hs
[1 of 1] Compiling Main ( pingpong.hs, pingpong.o )
Linking pingpong ...
$ ./pingpong
...
benchmarking thread switch test
mean: 3.774590 ms, lb 3.739223 ms, ub 3.808865 ms, ci 0.950
...
-threaded
to allow OS threads (pthread_create
) as wellforkOS
call creates Haskell thread bound to a new OS thread
forkOS :: IO () -> IO ThreadId
-threaded
, initial thread is boundWhoa... what happened? -threaded
30 times slower?
$ rm pingpong
$ ghc -threaded -O pingpong.hs
Linking pingpong ...
$ ./pingpong
...
mean: 121.1729 ms, lb 120.5601 ms, ub 121.7044 ms, ci 0.950
...
-threaded
, all Haskell threads run in one OS thread
-threaded
introduces multiple OS-level threads
unbound
haskell threads have same performance as w/o -threaded
forkIO
to make it unboundwrap :: IO a -> IO a
wrap action = do
mv <- newEmptyMVar
_ <- forkIO $ (action >>= putMVar mv) `catch`
\e@(SomeException _) -> putMVar mv (throw e)
takeMVar mv
runInUnboundThread
safe
and unsafe
-threaded
, GHC ensures safe
FFI calls run in separate OS threadunsafe
FFI calls from unbound threads can block other threadspthread_getspecific
can get confused if called from a migrated unbound threadforkOn
Some handy MVar
utility functions for updating a value
modifyMVar :: MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
modifyMVar x (\n -> return (n+1, n))
" like "x++
" in CHow would you implement modifyMVar
?
modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
modifyMVar m action = do
v0 <- takeMVar m
(v, r) <- action v0 `onException` putMVar m v0
putMVar m v
return r
throwTo
, killThread
)Some handy MVar
utility functions for updating a value
modifyMVar :: MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
modifyMVar x (\n -> return (n+1, n))
" like "x++
" in CHow would you implement modifyMVar
?
modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
modifyMVar m action = do
v0 <- takeMVar m -- -------------- oops, race condition
(v, r) <- action v0 `onException` putMVar m v0
putMVar m v
return r
killThread
on the current thread while current thread between takeMVar
and onException
timeout
and wrap
functions from a few slides ago have same problemThe mask
function can sidestep such race conditions
mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b
RankNTypes
. For now, ignore "forall a.
"--just makes function more flexiblemask $ \f -> b
runs action b
with asynchronous exceptions maskedf
allows exceptions to be unmasked again for an actiontakeMVar
)Example: Fixing modifyMVar
modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
modifyMVar m action = mask $ \unmask -> do
v0 <- takeMVar m -- automatically unmasked while waiting
(v, r) <- unmask (action v0) `onException` putMVar m v0
putMVar m v
return r
forkIO
preserves the current mask state
unmask
function in child threadwrap
functionwrap :: IO a -> IO a -- Fixed version of wrap
wrap action = do
mv <- newEmptyMVar
mask $ \unmask -> do
tid <- forkIO $ (unmask action >>= putMVar mv) `catch`
\e@(SomeException _) -> putMVar mv (throw e)
let loop = takeMVar mv `catch` \e@(SomeException _) ->
throwTo tid e >> loop
loop
unmask
in parent thread
loop
will sleep on takeMVar
, which implicitly unmasksbracket
functionmask
is tricky, but library function bracket
simplifies use
bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
Example: process file without leaking handle
bracket (openFile "/etc/mtab" ReadMode) -- first
hClose -- last
(\h -> hGetContents h >>= doit) -- main
Example: fix parent
function from our timeout
example
parent = do ctid <- forkIO child -- old code,
result <- action -- bad if async
killThread ctid -- exception
return $ Just result
parent = bracket (forkIO child) killThread $ -- new code
\_ -> fmap Just action
MVar
sMVar
s work just fine as a mutex:
-- type introduces type alias (like typedef in C)
type Mutex = MVar ()
mutex_create :: IO Mutex
mutex_create = newMVar ()
mutex_lock, mutex_unlock :: Mutex -> IO ()
mutex_lock = takeMVar
mutex_unlock mv = putMVar mv ()
mutex_synchronize :: Mutex -> IO a -> IO a
mutex_synchronize mv action =
bracket (mutex_lock mv) (\_ -> mutex_unlock mv)
(\_ -> action)
Mutex
if it is locked
Mutex
Use full MVar
rather than empty to mean lock held
type Mutex = MVar ThreadId
mutex_create :: IO Mutex
mutex_create = newEmptyMVar
mutex_lock, mutex_unlock :: Mutex -> IO ()
mutex_lock mv = myThreadId >>= putMVar mv
mutex_unlock mv = do mytid <- myThreadId
lockTid <- tryTakeMVar mv
unless (lockTid == Just mytid) $
error "mutex_unlock"
ThreadId
of lock owner in MVar
mask
for this question...data Cond = Cond (MVar [MVar ()])
cond_create :: IO Cond
cond_create = liftM Cond $ newMVar []
-- liftM is fmap for Monads (i.e., no required Functor instance):
-- liftM f m1 = do x <- m1; return (f m1)
cond_wait :: Mutex -> Cond -> IO ()
cond_wait m (Cond waiters) = do
me <- newEmptyMVar
modifyMVar_ waiters $ \others -> return $ others ++ [me]
mutex_unlock m -- note we don't care if preempted after this
takeMVar me `finally` mutex_lock m
cond_signal, cond_broadcast :: Cond -> IO ()
cond_signal (Cond waiters) = modifyMVar_ waiters wakeone
where wakeone [] = return []
wakeone (w:ws) = putMVar w () >> return ws
cond_broadcast (Cond waiters) = modifyMVar_ waiters wakeall
where wakeall ws = do mapM_ (flip putMVar ()) ws
return []
MVar
s inside MVar
s is very powerfulControl.Concurrent.Chan
provides unbounded channels
MVar
s -- for read and and write end of Stream
data Item a = Item a (Stream a)
type Stream a = MVar (Item a)
data Chan a = Chan (MVar (Stream a)) (MVar (Stream a))
data Item a = Item a (Stream a)
type Stream a = MVar (Item a)
data Chan a = Chan (MVar (Stream a)) (MVar (Stream a))
newChan :: IO (Chan a)
newChan = do
empty <- newEmptyMVar
liftM2 Chan (newMVar empty) (newMVar empty)
-- liftM2 is like liftM for functions of two arguments:
-- liftM2 f m1 m2 = do x1 <- m1; x2 <- m2; return (f x1 x2)
writeChan :: Chan a -> a -> IO ()
writeChan (Chan _ w) a = do
empty <- newEmptyMVar
modifyMVar_ w $ \oldEmpty -> do
putMVar oldEmpty (Item a empty)
return empty
readChan :: Chan a -> IO a
readChan (Chan r _) =
modifyMVar r $ \full -> do
(Item a newFull) <- takeMVar full
return (newFull, a)
High-level Stream (TCP & Unix-domain) socket support in Network
connectTo :: HostName -> PortID -> IO Handle
listenOn :: PortID -> IO Socket
accept :: Socket -> (Handle, HostName, PortNumber)
sClose :: Socket -> IO ()
hClose :: Handle -> IO ()
Exercise: Network-enabled rock-paper-scissors. Define:
withClient :: PortID -> (Handle -> IO a) -> IO a
This accepts connection, plays single game, exits
*Main> withClient (PortNumber 1617) (computerVsUser Rock)
$ nc localhost 1617
Please enter one of [Rock,Paper,Scissors]
Rock
You Tie
Start with last week's code: wget
cs240h.stanford.edu/rock2.hs
withClient :: PortID -> (Handle -> IO a) -> IO a
withClient listenPort fn =
bracket (listenOn listenPort) sClose $ \s -> do
bracket (accept s) (\(h, _, _) -> hClose h) $
\(h, host, port) -> do
putStrLn $ "Connection from host " ++ host
++ " port " ++ show port
fn h
Build a program netrock
that plays two users against one another and exits after one game
$ nc localhost 1617
Please enter one of [Rock,Paper,Scissors]
Rock
You Win
$ nc localhost 1617
Please enter one of [Rock,Paper,Scissors]
Scissors
You Lose
Start here: wget
cs240h.stanford.edu/netrock.hs
, implement:
netrock :: PortID -> IO ()
You may find it useful to define and use:
play :: MVar Move -> MVar Move
-> (Handle, HostName, PortNumber) -> IO ()
play myMoveMVar opponentMoveMVar (h, host, port) = do
If your OS is missing nc
: wget
cs240h.stanford.edu/netcat.hs
play :: MVar Move -> MVar Move
-> (Handle, HostName, PortNumber) -> IO ()
play myMoveMVar opponentMoveMVar (h, host, port) = do
putStrLn $ "Connection from host " ++ host ++ " port " ++ show port
myMove <- getMove h
putMVar myMoveMVar myMove
opponentMove <- takeMVar opponentMoveMVar
let o = outcome myMove opponentMove
hPutStrLn h $ "You " ++ show o
netrock :: PortID -> IO ()
netrock listenPort =
bracket (listenOn listenPort) sClose $ \s -> do
mv1 <- newEmptyMVar
mv2 <- newEmptyMVar
let cleanup mv (h,_,_) = do
tryPutMVar mv (error "something blew up")
hClose h
wait <- newEmptyMVar
forkIO $ bracket (accept s) (cleanup mv1) (play mv1 mv2)
`finally` putMVar wait ()
bracket (accept s) (cleanup mv2) (play mv2 mv1)
takeMVar wait
Also have low-level BSD socket support in Network.Socket
socket :: Family -> SocketType -> ProtocolNumber -> IO Socket
connect :: Socket -> SockAddr -> IO ()
bindSocket :: Socket -> SockAddr -> IO ()
listen :: Socket -> Int -> IO ()
accept :: Socket -> IO (Socket, SockAddr)
getAddrInfo
looks up hostnames just like [RFC3493] (returns [
AddrInfo
]
)getAddrInfo :: Maybe AddrInfo
-> Maybe HostName -> Maybe ServiceName
-> IO [AddrInfo]
SockAddr
for talking to web server:webServerAddr :: String -> IO SockAddr
webServerAddr name = do
addrs <- getAddrInfo Nothing (Just name) (Just "www")
return $ addrAddress $ head $ addrs
netcat :: String -> String -> IO ()
netcat host port = do
-- Extract address from first AddrInfo in list
AddrInfo{ addrAddress = addr, addrFamily = family }:_
<- getAddrInfo Nothing (Just host) (Just port)
-- Create a TCP socket connected to server
s <- socket family Stream 0
connect s addr
-- Convert socket to handle
h <- socketToHandle s ReadWriteMode
hSetBuffering h NoBuffering -- THIS IS IMPORTANT
-- Punt on complex locale stuff
hSetBinaryMode stdout True
-- Copy data back and forth taking advantage of laziness
done <- newEmptyMVar
forkIO $ (hGetContents h >>= putStr) `finally` putMVar done ()
getContents >>= hPutStr h
takeMVar done