parconc-examples 0.4.3 → 0.4.4
raw patch · 9 files changed
+154/−165 lines, 9 filesdep +http-conduitdep −HTTP
Dependencies added: http-conduit
Dependencies removed: HTTP
Files
- GetURL.hs +3/−16
- TMVar.hs +0/−49
- WindowManager.hs +0/−74
- miscmodules.hs +0/−6
- miscmodules/TMVar.hs +49/−0
- miscmodules/WindowManager.hs +74/−0
- miscmodules/miscmodules.hs +6/−0
- other/bingtranslatorconc.hs +0/−4
- parconc-examples.cabal +22/−16
GetURL.hs view
@@ -4,22 +4,9 @@ module GetURL (getURL) where -import Network.HTTP-import Network.Browser-import Network.URI+import Network.HTTP.Conduit import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as L getURL :: String -> IO ByteString-getURL url = do- Network.Browser.browse $ do- setCheckForProxy True- setDebugLog Nothing- setOutHandler (const (return ()))- (_, rsp) <- request (getRequest' (escapeURIString isUnescapedInURI url))- return (rspBody rsp)- where- getRequest' :: String -> Request ByteString- getRequest' urlString =- case parseURI urlString of- Nothing -> error ("getRequest: Not a valid URL - " ++ urlString)- Just u -> mkRequest GET u+getURL url = L.toStrict <$> simpleHttp url
− TMVar.hs
@@ -1,49 +0,0 @@-module TMVar where--import Control.Concurrent.STM hiding (TMVar, takeTMVar)---- <<TMVar-newtype TMVar a = TMVar (TVar (Maybe a))--- >>--newTMVar :: a -> STM (TMVar a)-newTMVar a = do- t <- newTVar (Just a)- return (TMVar t)---- <<newEmptyTMVar-newEmptyTMVar :: STM (TMVar a)-newEmptyTMVar = do- t <- newTVar Nothing- return (TMVar t)--- >>---- <<takeTMVar-takeTMVar :: TMVar a -> STM a-takeTMVar (TMVar t) = do- m <- readTVar t -- <1>- case m of- Nothing -> retry -- <2>- Just a -> do- writeTVar t Nothing -- <3>- return a--- >>---- <<putTMVar-putTMVar :: TMVar a -> a -> STM ()-putTMVar (TMVar t) a = do- m <- readTVar t- case m of- Nothing -> do- writeTVar t (Just a)- return ()- Just _ -> retry--- >>---- <<takeEitherTMVar-takeEitherTMVar :: TMVar a -> TMVar b -> STM (Either a b)-takeEitherTMVar ma mb =- fmap Left (takeTMVar ma)- `orElse`- fmap Right (takeTMVar mb)--- >>
− WindowManager.hs
@@ -1,74 +0,0 @@-module WindowManager where--import Control.Concurrent.STM-import Data.Map as Map-import Data.Set as Set-import Data.Maybe--data Window-instance Eq Window-instance Ord Window--data Desktop-instance Eq Desktop-instance Ord Desktop--type Display = Map Desktop (TVar (Set Window))---- <<moveWindowSTM-moveWindowSTM :: Display -> Window -> Desktop -> Desktop -> STM ()-moveWindowSTM disp win a b = do- wa <- readTVar ma- wb <- readTVar mb- writeTVar ma (Set.delete win wa)- writeTVar mb (Set.insert win wb)- where- ma = disp ! a- mb = disp ! b--- >>---- <<moveWindow-moveWindow :: Display -> Window -> Desktop -> Desktop -> IO ()-moveWindow disp win a b = atomically $ moveWindowSTM disp win a b--- >>---- <<swapWindows-swapWindows :: Display- -> Window -> Desktop- -> Window -> Desktop- -> IO ()-swapWindows disp w a v b = atomically $ do- moveWindowSTM disp w a b- moveWindowSTM disp v b a--- >>--render :: Set Window -> IO ()-render = undefined---- <<UserFocus-type UserFocus = TVar Desktop--- >>---- <<getWindows-getWindows :: Display -> UserFocus -> STM (Set Window)-getWindows disp focus = do- desktop <- readTVar focus- readTVar (disp ! desktop)--- >>---- <<renderThread-renderThread :: Display -> UserFocus -> IO ()-renderThread disp focus = do- wins <- atomically $ getWindows disp focus -- <1>- loop wins -- <2>- where- loop wins = do -- <3>- render wins -- <4>- next <- atomically $ do- wins' <- getWindows disp focus -- <5>- if (wins == wins') -- <6>- then retry -- <7>- else return wins' -- <8>- loop next--- >>-
− miscmodules.hs
@@ -1,6 +0,0 @@-import WindowManager-import TMVar-import TList--main :: IO ()-main = return ()
+ miscmodules/TMVar.hs view
@@ -0,0 +1,49 @@+module TMVar where++import Control.Concurrent.STM hiding (TMVar, takeTMVar)++-- <<TMVar+newtype TMVar a = TMVar (TVar (Maybe a))+-- >>++newTMVar :: a -> STM (TMVar a)+newTMVar a = do+ t <- newTVar (Just a)+ return (TMVar t)++-- <<newEmptyTMVar+newEmptyTMVar :: STM (TMVar a)+newEmptyTMVar = do+ t <- newTVar Nothing+ return (TMVar t)+-- >>++-- <<takeTMVar+takeTMVar :: TMVar a -> STM a+takeTMVar (TMVar t) = do+ m <- readTVar t -- <1>+ case m of+ Nothing -> retry -- <2>+ Just a -> do+ writeTVar t Nothing -- <3>+ return a+-- >>++-- <<putTMVar+putTMVar :: TMVar a -> a -> STM ()+putTMVar (TMVar t) a = do+ m <- readTVar t+ case m of+ Nothing -> do+ writeTVar t (Just a)+ return ()+ Just _ -> retry+-- >>++-- <<takeEitherTMVar+takeEitherTMVar :: TMVar a -> TMVar b -> STM (Either a b)+takeEitherTMVar ma mb =+ fmap Left (takeTMVar ma)+ `orElse`+ fmap Right (takeTMVar mb)+-- >>
+ miscmodules/WindowManager.hs view
@@ -0,0 +1,74 @@+module WindowManager where++import Control.Concurrent.STM+import Data.Map as Map+import Data.Set as Set+import Data.Maybe++data Window+instance Eq Window+instance Ord Window++data Desktop+instance Eq Desktop+instance Ord Desktop++type Display = Map Desktop (TVar (Set Window))++-- <<moveWindowSTM+moveWindowSTM :: Display -> Window -> Desktop -> Desktop -> STM ()+moveWindowSTM disp win a b = do+ wa <- readTVar ma+ wb <- readTVar mb+ writeTVar ma (Set.delete win wa)+ writeTVar mb (Set.insert win wb)+ where+ ma = disp ! a+ mb = disp ! b+-- >>++-- <<moveWindow+moveWindow :: Display -> Window -> Desktop -> Desktop -> IO ()+moveWindow disp win a b = atomically $ moveWindowSTM disp win a b+-- >>++-- <<swapWindows+swapWindows :: Display+ -> Window -> Desktop+ -> Window -> Desktop+ -> IO ()+swapWindows disp w a v b = atomically $ do+ moveWindowSTM disp w a b+ moveWindowSTM disp v b a+-- >>++render :: Set Window -> IO ()+render = undefined++-- <<UserFocus+type UserFocus = TVar Desktop+-- >>++-- <<getWindows+getWindows :: Display -> UserFocus -> STM (Set Window)+getWindows disp focus = do+ desktop <- readTVar focus+ readTVar (disp ! desktop)+-- >>++-- <<renderThread+renderThread :: Display -> UserFocus -> IO ()+renderThread disp focus = do+ wins <- atomically $ getWindows disp focus -- <1>+ loop wins -- <2>+ where+ loop wins = do -- <3>+ render wins -- <4>+ next <- atomically $ do+ wins' <- getWindows disp focus -- <5>+ if (wins == wins') -- <6>+ then retry -- <7>+ else return wins' -- <8>+ loop next+-- >>+
+ miscmodules/miscmodules.hs view
@@ -0,0 +1,6 @@+import WindowManager+import TMVar+import TList++main :: IO ()+main = return ()
other/bingtranslatorconc.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE PatternGuards #-}-import Network.HTTP hiding (postRequest) import Control.Exception import Control.Monad import Text.Printf@@ -9,9 +8,6 @@ import System.Environment import Control.Concurrent import Prelude hiding (catch)-import Network.HTTP-import Network.Browser-import Network.URI import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Text.XML.Light
parconc-examples.cabal view
@@ -1,5 +1,5 @@ name: parconc-examples-version: 0.4.3+version: 0.4.4 synopsis: Examples to accompany the book "Parallel and Concurrent Programming in Haskell" -- description: license: BSD3@@ -465,7 +465,7 @@ other-modules: GetURL build-depends: base >= 4.5 && < 4.9 , containers >= 0.4 && < 0.6- , HTTP ==4000.2.*+ , http-conduit >= 2.1 && < 2.3 , bytestring >= 0.9 && < 0.11 if flag(network26) build-depends: network >= 2.6 && < 2.7@@ -481,7 +481,7 @@ , stm ==2.4.* , bytestring >= 0.9 && < 0.11 , time >= 1.4 && < 1.6- , HTTP ==4000.2.*+ , http-conduit >= 2.1 && < 2.3 if flag(network26) build-depends: network >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7@@ -496,7 +496,7 @@ , stm ==2.4.* , bytestring >= 0.9 && < 0.11 , time >= 1.4 && < 1.6- , HTTP ==4000.2.*+ , http-conduit >= 2.1 && < 2.3 if flag(network26) build-depends: network >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7@@ -511,7 +511,7 @@ , stm ==2.4.* , bytestring >= 0.9 && < 0.11 , time >= 1.4 && < 1.6- , HTTP ==4000.2.*+ , http-conduit >= 2.1 && < 2.3 if flag(network26) build-depends: network >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7@@ -526,7 +526,7 @@ , stm ==2.4.* , bytestring >= 0.9 && < 0.11 , time >= 1.4 && < 1.6- , HTTP ==4000.2.*+ , http-conduit >= 2.1 && < 2.3 if flag(network26) build-depends: network >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7@@ -541,7 +541,7 @@ , stm ==2.4.* , bytestring >= 0.9 && < 0.11 , time >= 1.4 && < 1.6- , HTTP ==4000.2.*+ , http-conduit >= 2.1 && < 2.3 if flag(network26) build-depends: network >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7@@ -559,7 +559,7 @@ , stm ==2.4.* , bytestring >= 0.9 && < 0.11 , time >= 1.4 && < 1.6- , HTTP ==4000.2.*+ , http-conduit >= 2.1 && < 2.3 if flag(network26) build-depends: network >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7@@ -574,7 +574,7 @@ , stm ==2.4.* , bytestring >= 0.9 && < 0.11 , time >= 1.4 && < 1.6- , HTTP ==4000.2.*+ , http-conduit >= 2.1 && < 2.3 if flag(network26) build-depends: network >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7@@ -610,8 +610,14 @@ -- ----------------------------------------------------------------------------- -- conc-stm +-- NB. The book refers to "tmvar.hs" and "windowmanager.hs", so we+-- can't change rename these files. However, we need to use proper+-- upper-case module names, so we use symbolic links from a+-- subdirectory (mismodules) so that the repo remains safe to use on+-- case-insensitive filesystems (#15). executable miscmodules main-is: miscmodules.hs+ hs-source-dirs: miscmodules . other-modules: TMVar, TList, TQueue, TBQueue, WindowManager build-depends: base >= 4.5 && < 4.9 , containers >= 0.4 && < 0.6@@ -625,7 +631,7 @@ , stm ==2.4.* , bytestring >= 0.9 && < 0.11 , time >= 1.4 && < 1.6- , HTTP ==4000.2.*+ , http-conduit >= 2.1 && < 2.3 if flag(network26) build-depends: network >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7@@ -649,7 +655,7 @@ , stm ==2.4.* , bytestring >= 0.9 && < 0.11 , time >= 1.4 && < 1.6- , HTTP ==4000.2.*+ , http-conduit >= 2.1 && < 2.3 if flag(network26) build-depends: network >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7@@ -664,7 +670,7 @@ , stm ==2.4.* , bytestring >= 0.9 && < 0.11 , time >= 1.4 && < 1.6- , HTTP ==4000.2.*+ , http-conduit >= 2.1 && < 2.3 if flag(network26) build-depends: network >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7@@ -679,7 +685,7 @@ , stm ==2.4.* , bytestring >= 0.9 && < 0.11 , time >= 1.4 && < 1.6- , HTTP ==4000.2.*+ , http-conduit >= 2.1 && < 2.3 if flag(network26) build-depends: network >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7@@ -1060,7 +1066,7 @@ build-depends: base >= 4.5 && < 4.9 , bytestring >= 0.9 && < 0.11 , time >= 1.4 && < 1.6- , HTTP ==4000.2.*+ , http-conduit >= 2.1 && < 2.3 , utf8-string >= 0.3 && < 1.1 , xml ==1.3.* if flag(network26)@@ -1077,7 +1083,7 @@ build-depends: base >= 4.5 && < 4.9 , bytestring >= 0.9 && < 0.11 , time >= 1.4 && < 1.6- , HTTP ==4000.2.*+ , http-conduit >= 2.1 && < 2.3 , utf8-string >= 0.3 && < 1.1 , xml ==1.3.* if flag(network26)@@ -1094,7 +1100,7 @@ , stm ==2.4.* , bytestring >= 0.9 && < 0.11 , time >= 1.4 && < 1.6- , HTTP ==4000.2.*+ , http-conduit >= 2.1 && < 2.3 if flag(network26) build-depends: network >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7