Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

various tweaks and fixes

  • Loading branch information...
commit a24b0f984090f70657a535e55f06244a6d69cf99 1 parent 4b04723
@simonmar authored
View
72 TChan.hs
@@ -0,0 +1,72 @@
+import Control.Concurrent.STM (STM, TVar, newTVar, readTVar, writeTVar, retry, atomically)
+
+-- <<TChan
+data TChan a = TChan (TVar (TVarList a))
+ (TVar (TVarList a))
+
+type TVarList a = TVar (TList a)
+data TList a = TNil | TCons a (TVarList a)
+
+newTChan :: STM (TChan a)
+newTChan = do
+ hole <- newTVar TNil
+ read <- newTVar hole
+ write <- newTVar hole
+ return (TChan read write)
+
+readTChan :: TChan a -> STM a
+readTChan (TChan readVar _) = do
+ listHead <- readTVar readVar
+ head <- readTVar listHead
+ case head of
+ TNil -> retry
+ TCons val tail -> do
+ writeTVar readVar tail
+ return val
+
+writeTChan :: TChan a -> a -> STM ()
+writeTChan (TChan _ writeVar) a = do
+ newListEnd <- newTVar TNil
+ listEnd <- readTVar writeVar
+ writeTVar writeVar newListEnd
+ writeTVar listEnd (TCons a newListEnd)
+-- >>
+
+-- <<dupTChan
+dupTChan :: TChan a -> STM (TChan a)
+dupTChan (TChan _ writeVar) = do
+ hole <- readTVar writeVar
+ newReadVar <- newTVar hole
+ return (TChan newReadVar writeVar)
+-- >>
+
+-- <<unGetTChan
+unGetTChan :: TChan a -> a -> STM ()
+unGetTChan (TChan readVar _) a = do
+ listHead <- readTVar readVar
+ newHead <- newTVar (TCons a listHead)
+ writeTVar readVar newHead
+-- >>
+
+-- <<isEmptyTChan
+isEmptyTChan :: TChan a -> STM Bool
+isEmptyTChan (TChan read _write) = do
+ listhead <- readTVar read
+ head <- readTVar listhead
+ case head of
+ TNil -> return True
+ TCons _ _ -> return False
+-- >>
+
+main = do
+ c <- atomically $ newTChan
+ atomically $ writeTChan c 'a'
+ atomically (readTChan c) >>= print
+ atomically (isEmptyTChan c) >>= print
+ atomically $ unGetTChan c 'a'
+ atomically (isEmptyTChan c) >>= print
+ atomically (readTChan c) >>= print
+ c2 <- atomically $ dupTChan c
+ atomically $ writeTChan c 'b'
+ atomically (readTChan c) >>= print
+ atomically (readTChan c2) >>= print
View
5 TList.hs
@@ -20,6 +20,7 @@ readTList (TList v) = do
xs <- readTVar v
case xs of
[] -> retry
- (x:xs') -> do writeTVar v xs'
- return x
+ (x:xs') -> do
+ writeTVar v xs'
+ return x
-- >>
View
5 catch-mask2.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
import System.IO
import System.IO.Error
import System.Environment
@@ -7,8 +8,8 @@ import Control.Exception
main = do
fs <- getArgs
let
- loop n [] = return n
- loop n (f:fs) = do
+ loop !n [] = return n
+ loop !n (f:fs) = do
getMaskingState >>= print
r <- Control.Exception.try (openFile f ReadMode)
case r of
View
4 chan2.hs
@@ -41,7 +41,7 @@ readChan (Chan readVar _) = do
-- <<dupChan
dupChan :: Chan a -> IO (Chan a)
dupChan (Chan _ writeVar) = do
- hole <- takeMVar writeVar
+ hole <- takeMVar writeVar
putMVar writeVar hole
newReadVar <- newMVar hole
return (Chan newReadVar writeVar)
@@ -60,7 +60,7 @@ main = do
c <- newChan
writeChan c 'a'
readChan c >>= print
- c2 <- dupChan c
+ c2 <- duCphan c
writeChan c 'b'
readChan c >>= print
readChan c2 >>= print
View
12 chanbench.hs
@@ -25,13 +25,13 @@ newc = newTChanIO
readc c = atomically $ readTChan c
writec c x = atomically $ writeTChan c x
#elif defined(TQUEUE)
-newc = atomically $ newTQueue
-readc c = atomically $ readTQueue c
-writec c x = atomically $ writeTQueue c x
+newc = atomically $ TQueue.newTQueue
+readc c = atomically $ TQueue.readTQueue c
+writec c x = atomically $ TQueue.writeTQueue c x
#elif defined(TBQUEUE)
-newc = atomically $ newTBQueue 4096
-readc c = atomically $ readTBQueue c
-writec c x = atomically $ writeTBQueue c x
+newc = atomically $ TBQueue.newTBQueue 4096
+readc c = atomically $ TBQueue.readTBQueue c
+writec c x = atomically $ TBQueue.writeTBQueue c x
#endif
main = do
View
15 geturlsfirst.hs
@@ -85,13 +85,16 @@ sites = ["http://www.google.com",
"http://www.wikipedia.com/wiki/Shovel"]
-- <<main
+main :: IO ()
main = do
+ let
+ download url = do
+ r <- getURL url
+ return (url, r)
+
as <- mapM (async . download) sites
- (url,_) <- waitAny as
- printf "%s was first\n" url
+
+ (url, r) <- waitAny as
+ printf "%s was first (%d bytes)\n" url (B.length r)
mapM_ wait as
- where
- download url = do
- contents <- getURL url
- return (url, contents)
-- >>
View
6 parconc-examples.cabal
@@ -373,6 +373,12 @@ executable geturlsfirst
, network ==2.3.*
default-language: Haskell2010
+executable TChan
+ main-is: TChan.hs
+ build-depends: base >= 4.5 && < 4.7
+ , stm ==2.4.*
+ default-language: Haskell2010
+
executable TList
main-is: TList.hs
build-depends: base >= 4.5 && < 4.7
View
6 windowman.hs
@@ -23,8 +23,8 @@ moveWindowSTM disp win a b = do
writeTVar ma (Set.delete win wa)
writeTVar mb (Set.insert win wb)
where
- ma = fromJust (Map.lookup a disp)
- mb = fromJust (Map.lookup b disp)
+ ma = disp ! a
+ mb = disp ! b
-- >>
-- <<moveWindow
@@ -53,7 +53,7 @@ type UserFocus = TVar Desktop
getWindows :: Display -> UserFocus -> STM (Set Window)
getWindows disp focus = do
desktop <- readTVar focus
- readTVar (fromJust (Map.lookup desktop disp))
+ readTVar (disp ! desktop)
-- >>
-- <<renderThread
Please sign in to comment.
Something went wrong with that request. Please try again.