Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Review and compiled with ghc 7.4.1

  • Loading branch information...
commit 0b91c65442700c98e56c846c1d9860ae84c45f2e 1 parent e1a950b
@toschoo authored
Showing with 246 additions and 287 deletions.
  1. +3 −3 src/patterns/Makefile
  2. +4 −0 src/patterns/examples/basic/pairs/ping.hs
  3. +4 −0 src/patterns/examples/basic/pipes/worker.hs
  4. +4 −0 src/patterns/examples/basic/pubsub/sporadic.hs
  5. +4 −0 src/patterns/examples/basic/pubsub/wuclient.hs
  6. +4 −0 src/patterns/examples/basic/pubsub/wufile.hs
  7. +4 −0 src/patterns/examples/basic/pubsub/wuissue.hs
  8. +4 −0 src/patterns/examples/basic/pubsub/wuserver.hs
  9. +25 −2 src/patterns/examples/basic/servers/db.hs
  10. +1 −1  src/patterns/examples/basic/servers/frost.hs
  11. +8 −0 src/patterns/examples/device/fork.hs
  12. +4 −0 src/patterns/examples/device/forward.hs
  13. +4 −0 src/patterns/examples/device/ifc.hs
  14. +4 −0 src/patterns/examples/device/pipe.hs
  15. +4 −0 src/patterns/examples/device/queue.hs
  16. +17 −16 src/patterns/patterns.cabal
  17. +0 −1  src/patterns/src/Factory.hs
  18. +8 −8 src/patterns/src/Network/Mom/Patterns/Basic.hs
  19. +2 −2 src/patterns/src/Network/Mom/Patterns/Device.hs
  20. +129 −0 src/patterns/test/suite/Common.hs
  21. +3 −96 src/patterns/test/suite/basic.hs
  22. +4 −89 src/patterns/test/suite/device.hs
  23. +2 −69 src/patterns/test/suite/enum.hs
View
6 src/patterns/Makefile
@@ -35,13 +35,13 @@ run:
$(TDIR)/basic
$(TDIR)/device
-$(TDIR)/enum: $(TDIR)/enum.hs $(SUBSRC)
+$(TDIR)/enum: $(TDIR)/enum.hs $(TDIR)/Common.hs $(SUBSRC)
$(GHC) $(FLGS) $(INC) $@
-$(TDIR)/basic: $(TDIR)/basic.hs $(SUBSRC)
+$(TDIR)/basic: $(TDIR)/basic.hs $(TDIR)/Common.hs $(SUBSRC)
$(GHC) $(FLGS) $(INC) $@
-$(TDIR)/device: $(TDIR)/device.hs $(SUBSRC)
+$(TDIR)/device: $(TDIR)/device.hs $(TDIR)/Common.hs $(SUBSRC)
$(GHC) $(FLGS) $(INC) $@
smoke: $(SMOKEDIR)/db \
View
4 src/patterns/examples/basic/pairs/ping.hs
@@ -1,6 +1,10 @@
module Main
where
+ ------------------------------------------------------------------------
+ -- Playing ping pong
+ ------------------------------------------------------------------------
+
import Network.Mom.Patterns
import qualified Data.Enumerator as E
import qualified Data.ByteString.Char8 as B
View
4 src/patterns/examples/basic/pipes/worker.hs
@@ -1,6 +1,10 @@
module Main
where
+ ------------------------------------------------------------------------
+ -- Simple puller
+ ------------------------------------------------------------------------
+
import Helper (getOs, address, onErr_,
output, untilInterrupt)
import Network.Mom.Patterns
View
4 src/patterns/examples/basic/pubsub/sporadic.hs
@@ -1,6 +1,10 @@
module Main
where
+ ------------------------------------------------------------------------
+ -- Simple sporadic subscriber (just writing to stdout)
+ ------------------------------------------------------------------------
+
import Helper (getOs, address, untilInterrupt)
import Network.Mom.Patterns
import qualified Data.ByteString.Char8 as B
View
4 src/patterns/examples/basic/pubsub/wuclient.hs
@@ -1,6 +1,10 @@
module Main
where
+ ------------------------------------------------------------------------
+ -- Simple weather report subscriber
+ ------------------------------------------------------------------------
+
import Helper (getOs, address, output, onErr_, untilInterrupt)
import Network.Mom.Patterns
import qualified Data.ByteString.Char8 as B
View
4 src/patterns/examples/basic/pubsub/wufile.hs
@@ -1,5 +1,9 @@
module Main
where
+
+ ------------------------------------------------------------------------
+ -- Simple weather report subscriber that writes to a file
+ ------------------------------------------------------------------------
import Helper (getOs, address, untilInterrupt, onErr_)
import Network.Mom.Patterns
View
4 src/patterns/examples/basic/pubsub/wuissue.hs
@@ -1,6 +1,10 @@
module Main
where
+ ------------------------------------------------------------------------
+ -- Simple weather report publisher, using "issue"
+ ------------------------------------------------------------------------
+
import Helper (getOs, address)
import Network.Mom.Patterns
View
4 src/patterns/examples/basic/pubsub/wuserver.hs
@@ -1,6 +1,10 @@
module Main
where
+ ------------------------------------------------------------------------
+ -- Simple weather report publisher
+ ------------------------------------------------------------------------
+
import Helper(getOs, address, untilInterrupt, onErr_)
import Network.Mom.Patterns
import qualified Data.ByteString.Char8 as B
View
27 src/patterns/examples/basic/servers/db.hs
@@ -1,6 +1,11 @@
module Main
where
+ ------------------------------------------------------------------------
+ -- Reads data from a database table (ignoring client input)
+ -- and sends the data back, one message per row
+ ------------------------------------------------------------------------
+
import Helper (getOs, address, onErr,
dbFetcher, untilInterrupt)
import Network.Mom.Patterns
@@ -13,7 +18,9 @@ where
main = do
(l, p, _) <- getOs
withContext 1 $ \ctx -> do
- c <- connectODBC "DSN=jose"
+ c <- connectODBC "DSN=jose" -- jose is a chess database
+ -- here, we use ODBC to connect
+ -- to a mysql server
s <- prepare c "select Id, substr(Name, 1, 30) Name from Player"
withServer ctx "Player" noparam 5
(address l "tcp" "localhost" p []) l
@@ -25,4 +32,20 @@ where
iconv :: InBound [SqlValue]
iconv = return . convRow . B.unpack
where convRow :: String -> [SqlValue]
- convRow _ = [] -- no input parameter, in fact
+ convRow _ = []
+
+ ------------------------------------------------------------------------
+ -- ODBC example configuration (/etc/odbc.ini)
+ ------------------------------------------------------------------------
+ -- [jose]
+ -- Driver = /usr/lib/i386-linux-gnu/odbc/libmyodbc.so
+ -- Description = MyODBC 3.51 Driver DSN
+ -- SERVER = localhost
+ -- PORT =
+ -- USER = jose
+ -- Password = jose
+ -- Database = jose
+ -- OPTION = 3
+ -- SOCKET =
+ ------------------------------------------------------------------------
+
View
2  src/patterns/examples/basic/servers/frost.hs
@@ -1,7 +1,7 @@
module Main
where
------------------------------------------------------------------------
- -- Sends the poem "Stopping by Woods on a Snowy Evening on request
+ -- Sends the poem "Stopping by Woods on a Snowy Evening" on request
------------------------------------------------------------------------
import Helper (getOs, address, onErr,
View
8 src/patterns/examples/device/fork.hs
@@ -1,6 +1,14 @@
module Main
where
+ ------------------------------------------------------------------------
+ -- Device that sends data streams coming from a connected publisher
+ -- to all connected subscribers;
+ -- subscribers can be connected and removed through the "ifc" program.
+ -- The program cannot be stopped by the INT signal.
+ -- Instead, it is stopped by using the "stop" command with ifc.
+ ------------------------------------------------------------------------
+
import Command
import Helper (getPorts, address, onErr_, onErr)
import Network.Mom.Patterns
View
4 src/patterns/examples/device/forward.hs
@@ -1,6 +1,10 @@
module Main
where
+ ------------------------------------------------------------------------
+ -- A simple forwarder (Publisher -> Subscriber)
+ ------------------------------------------------------------------------
+
import Helper (getPorts, address, untilInterrupt, onErr_)
import Network.Mom.Patterns
import Control.Concurrent
View
4 src/patterns/examples/device/ifc.hs
@@ -1,6 +1,10 @@
module Main
where
+ ------------------------------------------------------------------------
+ -- Client to send commands to the "fork" program
+ ------------------------------------------------------------------------
+
import Command
import Helper
import Network.Mom.Patterns
View
4 src/patterns/examples/device/pipe.hs
@@ -1,6 +1,10 @@
module Main
where
+ ------------------------------------------------------------------------
+ -- A simple pipeline (pusher -> puller)
+ ------------------------------------------------------------------------
+
import Helper (getPorts, address, onErr_, untilInterrupt)
import Network.Mom.Patterns
import Control.Concurrent
View
4 src/patterns/examples/device/queue.hs
@@ -1,6 +1,10 @@
module Main
where
+ ------------------------------------------------------------------------
+ -- Simple queue (client <-> server)
+ ------------------------------------------------------------------------
+
import Helper (getPorts, untilInterrupt, address, onErr_)
import Network.Mom.Patterns
import Control.Concurrent
View
33 src/patterns/patterns.cabal
@@ -1,24 +1,23 @@
Name: patterns
-Version: 0.0.2
-Cabal-Version: >= 1.8
+Version: 0.0.3
+Cabal-Version: >= 1.14.0
Copyright: Copyright (c) Tobias Schoofs, 2011 - 2012
License: LGPL
license-file: license/lgpl-3.0.txt
Author: Tobias Schoofs
Maintainer: tobias dot schoofs at gmx dot net
Category: Network, Message-oriented Middleware, zeromq
-Homepage: http://github.com/toschoo/mom/src/patterns
+Homepage: http://github.com/toschoo/mom
Build-Type: Simple
Synopsis: Common patterns in message-oriented applications
Description:
- There are common patterns often reused
- - or, in fact, reimplemented,
- in many distributed, message-oriented applications,
+ In distributed, message-oriented applications,
+ similar communication patterns are used over and over again,
such as Server\/Client (a.k.a Request\/Response),
- Publish\/Subscribe,
- Pipline (a.k.a. Push\/Pull) and
- Exclusive Pair (a.k.a. Peer-to-Peer).
+ Publish\/Subscribe,
+ Pipline (a.k.a. Push\/Pull) and
+ Exclusive Pair (a.k.a. Peer-to-Peer).
The Patterns package implements those patterns based on zeromq.
More information on zeromq can be found at
@@ -28,14 +27,16 @@ Description:
on <http://github.com/toschoo/mom>.
Library
- Build-Depends: base >= 4.0 && <= 5.0,
- bytestring >= 0.9.1.9,
- utf8-string >= 0.3.6,
- containers >= 0.3.0.0,
- zeromq-haskell >= 0.8.3,
- enumerator >= 0.4.11,
+ Build-Depends: base >= 4.5 && <= 5.0,
+ bytestring >= 0.9.2.1,
+ utf8-string >= 0.3.7,
+ containers >= 0.4.2.1,
+ zeromq-haskell >= 0.8.4,
+ enumerator >= 0.4.18,
mtl >= 2.0.1.0,
- time >= 1.1.4
+ time >= 1.4
+
+ default-language: Haskell98
hs-source-dirs: src/Network/Mom, src
View
1  src/patterns/src/Factory.hs
@@ -1,4 +1,3 @@
-{-# OPTIONS -fglasgow-exts -fno-cse #-}
module Factory (
mkUniqueId)
where
View
16 src/patterns/src/Network/Mom/Patterns/Basic.hs
@@ -212,8 +212,8 @@ where
(String -> E.Iteratee c IO i) ->
Fetch i o ->
(Service -> IO a) -> IO a
- withServer ctx name param n ac t iconv oconv onerr build fetch action =
- withService ctx name param service action
+ withServer ctx name param n ac t iconv oconv onerr build fetch =
+ withService ctx name param service
where service = serve n ac t iconv oconv onerr
build fetch
@@ -633,8 +633,8 @@ where
OnError_ ->
Fetch_ o ->
(Service -> IO a) -> IO a
- withPeriodicPub ctx name param period ac oconv onerr fetch action =
- withService ctx name param service action
+ withPeriodicPub ctx name param period ac oconv onerr fetch =
+ withService ctx name param service
where service = publish period ac oconv onerr fetch
------------------------------------------------------------------------
@@ -728,8 +728,8 @@ where
InBound i -> OnError_ ->
Dump i ->
(Service -> IO a) -> IO a
- withSub ctx name param sub ac iconv onErr dump action =
- withService ctx name param service action
+ withSub ctx name param sub ac iconv onErr dump =
+ withService ctx name param service
where service = subscribe sub ac iconv onErr dump
subscribe :: [Topic] ->
@@ -893,8 +893,8 @@ where
OnError_ ->
Dump i ->
(Service -> IO a) -> IO a
- withPuller ctx name param ac iconv onerr dump action =
- withService ctx name param service action
+ withPuller ctx name param ac iconv onerr dump =
+ withService ctx name param service
where service = pull ac iconv onerr dump
pull :: AccessPoint ->
View
4 src/patterns/src/Network/Mom/Patterns/Device.hs
@@ -89,8 +89,8 @@ where
(Parameter -> OnTimeout) ->
(Parameter -> Transformer o) ->
(Service -> IO a) -> IO a
- withDevice ctx name param tmo acs iconv oconv onerr ontmo trans action =
- withService ctx name param service action
+ withDevice ctx name param tmo acs iconv oconv onerr ontmo trans =
+ withService ctx name param service
where service = device_ tmo acs iconv oconv onerr ontmo trans
------------------------------------------------------------------------
View
129 src/patterns/test/suite/Common.hs
@@ -0,0 +1,129 @@
+module Common
+where
+
+ import Helper
+ import qualified System.ZMQ as Z
+ import Test.QuickCheck
+ import Test.QuickCheck.Monadic
+ import Network.Mom.Patterns
+ import qualified Data.Enumerator as E
+ import qualified Data.Enumerator.List as EL
+ import Data.Enumerator (($$))
+ import Control.Applicative ((<$>))
+ import Control.Concurrent
+ import Control.Monad.Trans (liftIO)
+ import Control.Exception (try, SomeException)
+
+ ------------------------------------------------------------------------
+ -- For debugging it's much nicer to work with digits
+ ------------------------------------------------------------------------
+ data Digit = Digit Int
+ deriving (Read, Eq, Ord)
+
+ instance Show Digit where
+ show (Digit d) = show d
+
+ instance Arbitrary Digit where
+ arbitrary = Digit <$> elements [0..9]
+
+ ------------------------------------------------------------------------
+ -- Ease working with either
+ ------------------------------------------------------------------------
+ infixl 9 ~>
+ (~>) :: IO Bool -> IO Bool -> IO Bool
+ x ~> f = x >>= \t -> if t then f else return False
+
+ ------------------------------------------------------------------------------
+ -- Generic Tests
+ ------------------------------------------------------------------------------
+ testContext :: Eq a => a ->
+ (Context -> IO (Either SomeException a)) -> Property
+ testContext ss action = monadicIO $ do
+ ei <- run $ withContext 1 action
+ case ei of
+ Left e -> run (print e) >> assert False
+ Right x -> assert (x == ss)
+
+ ------------------------------------------------------------------------------
+ -- Generic Server Tests
+ ------------------------------------------------------------------------------
+ testServer :: Z.Context -> [String] -> (Service -> IO a) -> IO a
+ testServer ctx ss =
+ withServer ctx "Test" noparam 1
+ (Address "inproc://srv" []) Bind
+ inString outString onErr
+ (\_ -> one "") -- ignore
+ (\_ _ _ -> mkStream ss)
+
+ ------------------------------------------------------------------------------
+ -- Connect without giving up
+ ------------------------------------------------------------------------------
+ trycon :: Z.Socket a -> String -> IO ()
+ trycon s a = do ei <- try $ Z.connect s a
+ case ei of
+ Left e -> do threadDelay 1000
+ let _ = show (e::SomeException)
+ trycon s a
+ Right _ -> return ()
+
+ ------------------------------------------------------------------------
+ -- stream from list
+ ------------------------------------------------------------------------
+ mkStream :: [a] -> E.Enumerator a IO b
+ mkStream ss step =
+ case step of
+ (E.Continue k) ->
+ if null ss then E.continue k
+ else mkStream (tail ss) $$ k (E.Chunks [head ss])
+ _ -> E.returnI step
+
+ ------------------------------------------------------------------------------
+ -- Just build up a list and store it in MVar
+ ------------------------------------------------------------------------------
+ makeList :: MVar [Int] -> E.Iteratee Int IO ()
+ makeList m = do
+ mb <- EL.head
+ case mb of
+ Nothing -> return ()
+ Just i -> tryIO (modifyMVar_ m (\l -> return (i:l))) >> makeList m
+
+ ------------------------------------------------------------------------------
+ -- return a list in an MVar
+ ------------------------------------------------------------------------------
+ dump :: MVar [a] -> Dump a
+ dump m _ _ = EL.consume >>= liftIO . putMVar m
+
+ -------------------------------------------------------------
+ -- controlled quickcheck, arbitrary tests
+ -------------------------------------------------------------
+ deepCheck :: (Testable p) => p -> IO Result
+ deepCheck = quickCheckWithResult stdArgs{maxSuccess=100,
+ maxDiscard=500}
+
+ -------------------------------------------------------------
+ -- do just one test
+ -------------------------------------------------------------
+ oneCheck :: (Testable p) => p -> IO Result
+ oneCheck = quickCheckWithResult stdArgs{maxSuccess=1,
+ maxDiscard=1}
+
+ -------------------------------------------------------------
+ -- combinator, could be a monad...
+ -------------------------------------------------------------
+ applyTest :: IO Result -> IO Result -> IO Result
+ applyTest r f = do
+ r' <- r
+ case r' of
+ Success {} -> f
+ x -> return x
+
+ infixr ?>
+ (?>) :: IO Result -> IO Result -> IO Result
+ (?>) = applyTest
+
+ -------------------------------------------------------------
+ -- Name tests
+ -------------------------------------------------------------
+ runTest :: String -> IO Result -> IO Result
+ runTest s t = putStrLn ("Test: " ++ s) >> t
+
View
99 src/patterns/test/suite/basic.hs
@@ -2,6 +2,7 @@ module Main
where
import Helper
+ import Common
import System.Exit
import System.Timeout
import System.IO (stdout, hFlush)
@@ -21,12 +22,7 @@ where
import Control.Concurrent
import Control.Monad.Loops
import Control.Monad.Trans (liftIO)
- import Control.Exception (try, throwIO, AssertionFailed(..), SomeException)
-
- ------------------------------------------------------------------------------
- -- All
- -- - change option
- ------------------------------------------------------------------------------
+ import Control.Exception (throwIO, AssertionFailed(..), SomeException)
------------------------------------------------------------------------------
-- Simple synchronous request
@@ -822,95 +818,6 @@ where
else
issue p (just x) >> issueN p s (x-1)
- ------------------------------------------------------------------------
- -- Ease working with either
- ------------------------------------------------------------------------
- infixl 9 ~>
- (~>) :: IO Bool -> IO Bool -> IO Bool
- x ~> f = x >>= \t -> if t then f else return False
-
-
- ------------------------------------------------------------------------------
- -- Generic Tests
- ------------------------------------------------------------------------------
- testContext :: Eq a => a ->
- (Context -> IO (Either SomeException a)) -> Property
- testContext ss action = monadicIO $ do
- ei <- run $ withContext 1 action
- case ei of
- Left e -> run (print e) >> assert False
- Right x -> assert (x == ss)
-
- ------------------------------------------------------------------------------
- -- Generic Server Tests
- ------------------------------------------------------------------------------
- testServer :: Z.Context -> [String] -> (Service -> IO a) -> IO a
- testServer ctx ss =
- withServer ctx "Test" noparam 1
- (Address "inproc://srv" []) Bind
- inString outString onErr
- (\_ -> one "") -- ignore
- (\_ _ _ -> mkStream ss)
-
- trycon :: Z.Socket a -> String -> IO ()
- trycon s a = do ei <- try $ Z.connect s a
- case ei of
- Left e -> do threadDelay 1000
- let _ = show (e::SomeException)
- trycon s a
- Right _ -> return ()
-
- ------------------------------------------------------------------------
- -- stream from list
- ------------------------------------------------------------------------
- mkStream :: [a] -> E.Enumerator a IO b
- mkStream ss step =
- case step of
- (E.Continue k) ->
- if null ss then E.continue k
- else mkStream (tail ss) $$ k (E.Chunks [head ss])
- _ -> E.returnI step
-
- ------------------------------------------------------------------------------
- -- return a list in an MVar
- ------------------------------------------------------------------------------
- dump :: MVar [a] -> Dump a
- dump m _ _ = EL.consume >>= liftIO . putMVar m
-
- -------------------------------------------------------------
- -- controlled quickcheck, arbitrary tests
- -------------------------------------------------------------
- deepCheck :: (Testable p) => p -> IO Result
- deepCheck = quickCheckWithResult stdArgs{maxSuccess=100,
- maxDiscard=500}
-
- -------------------------------------------------------------
- -- do just one test
- -------------------------------------------------------------
- oneCheck :: (Testable p) => p -> IO Result
- oneCheck = quickCheckWithResult stdArgs{maxSuccess=1,
- maxDiscard=1}
-
- -------------------------------------------------------------
- -- combinator, could be a monad...
- -------------------------------------------------------------
- applyTest :: IO Result -> IO Result -> IO Result
- applyTest r f = do
- r' <- r
- case r' of
- Success _ -> f
- x -> return x
-
- infixr ?>
- (?>) :: IO Result -> IO Result -> IO Result
- (?>) = applyTest
-
- -------------------------------------------------------------
- -- Name tests
- -------------------------------------------------------------
- runTest :: String -> IO Result -> IO Result
- runTest s t = putStrLn ("Test: " ++ s) >> t
-
checkAll :: IO ()
checkAll = do
let good = "OK. All Tests passed."
@@ -989,7 +896,7 @@ where
(deepCheck prp_hwm)
case r of
- Success _ -> do
+ Success {} -> do
putStrLn good
exitSuccess
_ -> do
View
93 src/patterns/test/suite/device.hs
@@ -1,6 +1,7 @@
module Main
where
+ import Common
import Helper
import System.IO
import System.Exit
@@ -11,7 +12,6 @@ where
import Network.Mom.Patterns
import qualified Data.Enumerator as E
import qualified Data.Enumerator.List as EL
- import Data.Enumerator (($$))
import qualified Data.Sequence as S
import Data.Sequence ((|>))
import qualified Data.ByteString.Char8 as B
@@ -22,19 +22,7 @@ where
import Control.Monad (unless)
import Control.Monad.Trans (liftIO)
import Control.Exception (AssertionFailed(..),
- try, throwIO, SomeException)
-
- ------------------------------------------------------------------------
- -- For debugging it's much nicer to work with digits
- ------------------------------------------------------------------------
- data Digit = Digit Int
- deriving (Read, Eq, Ord)
-
- instance Show Digit where
- show (Digit d) = show d
-
- instance Arbitrary Digit where
- arbitrary = Digit <$> elements [0..9]
+ throwIO, SomeException)
------------------------------------------------------------------------------
-- pass all gets all
@@ -100,7 +88,7 @@ where
prp_onTmo = monadicIO $ run (withContext 1 tstDevice) >>= assert
where go d m _ = do
now <- getCurrentTime
- threadDelay $ 2 * (fromIntegral d)
+ threadDelay $ 2 * fromIntegral d
t <- readMVar m
if t > now && t <= uToNominal (3 * fromIntegral d)
`addUTCTime` now
@@ -275,10 +263,6 @@ where
issue pub (mkStream ss)
tstReceive m1 (Just ss) ~>
tstReceive m2 (Just ss))
-
- infixr ~>
- (~>) :: IO Bool -> IO Bool -> IO Bool
- x ~> y = x >>= \r -> if r then y else return False
------------------------------------------------------------------------------
-- unicode
@@ -430,41 +414,6 @@ where
if m
then go (x:ls)
else return (x:ls)
-
- trycon :: Z.Socket a -> String -> IO ()
- trycon s a = do ei <- try $ Z.connect s a
- case ei of
- Left e -> do threadDelay 1000
- let _ = show (e::SomeException)
- trycon s a
- Right _ -> return ()
-
- ------------------------------------------------------------------------
- -- stream from list
- ------------------------------------------------------------------------
- mkStream :: [a] -> E.Enumerator a IO b
- mkStream ss step =
- case step of
- (E.Continue k) ->
- if null ss then E.continue k
- else mkStream (tail ss) $$ k (E.Chunks [head ss])
- _ -> E.returnI step
-
- ------------------------------------------------------------------------------
- -- Just build up a list and store it in MVar
- ------------------------------------------------------------------------------
- makeList :: MVar [Int] -> E.Iteratee Int IO ()
- makeList m = do
- mb <- EL.head
- case mb of
- Nothing -> return ()
- Just i -> tryIO (modifyMVar_ m (\l -> return (i:l))) >> makeList m
-
- ------------------------------------------------------------------------------
- -- return a list in an MVar
- ------------------------------------------------------------------------------
- dump :: MVar [a] -> Dump a
- dump m _ _ = EL.consume >>= liftIO . putMVar m
------------------------------------------------------------------------------
-- return a list in an MVar
@@ -562,40 +511,6 @@ where
else emit s trg os ignoreStream
trg = filterTargets s (/= getStreamSource s)
- -------------------------------------------------------------
- -- controlled quickcheck, arbitrary tests
- -------------------------------------------------------------
- deepCheck :: (Testable p) => p -> IO Result
- deepCheck = quickCheckWithResult stdArgs{maxSuccess=100,
- maxDiscard=500}
-
- -------------------------------------------------------------
- -- do just one test
- -------------------------------------------------------------
- oneCheck :: (Testable p) => p -> IO Result
- oneCheck = quickCheckWithResult stdArgs{maxSuccess=1,
- maxDiscard=1}
-
- -------------------------------------------------------------
- -- combinator, could be a monad...
- -------------------------------------------------------------
- applyTest :: IO Result -> IO Result -> IO Result
- applyTest r f = do
- r' <- r
- case r' of
- Success _ -> f
- x -> return x
-
- infixr ?>
- (?>) :: IO Result -> IO Result -> IO Result
- (?>) = applyTest
-
- -------------------------------------------------------------
- -- Name tests
- -------------------------------------------------------------
- runTest :: String -> IO Result -> IO Result
- runTest s t = putStrLn ("Test: " ++ s) >> t
-
checkAll :: IO ()
checkAll = do
let good = "OK. All Tests passed."
@@ -622,7 +537,7 @@ where
runTest "Start/Pause" (deepCheck prp_Pause) ?>
runTest "add" (deepCheck prp_add)
case r of
- Success _ -> do
+ Success {} -> do
putStrLn good
exitSuccess
_ -> do
View
71 src/patterns/test/suite/enum.hs
@@ -1,6 +1,7 @@
module Main
where
+ import Common
import System.Exit
import Test.QuickCheck
import Test.QuickCheck.Monadic
@@ -8,23 +9,10 @@ where
import qualified Data.Enumerator as E
import qualified Data.Enumerator.List as EL
import Data.Enumerator (($$))
- import Control.Applicative ((<$>))
import Control.Concurrent
import Control.Exception (throwIO, AssertionFailed(..))
import Data.List (intercalate)
- ------------------------------------------------------------------------
- -- For debugging it's much nicer to work with digits
- ------------------------------------------------------------------------
- data Digit = Digit Int
- deriving (Read, Eq, Ord)
-
- instance Show Digit where
- show (Digit d) = show d
-
- instance Arbitrary Digit where
- arbitrary = Digit <$> elements [0..9]
-
------------------------------------------------------------------------------
-- enumWith stops on Nothing
------------------------------------------------------------------------------
@@ -353,61 +341,6 @@ where
else E.continue k
_ -> E.returnI step
- ------------------------------------------------------------------------
- -- stream from list
- ------------------------------------------------------------------------
- mkStream :: [a] -> E.Enumerator a IO b
- mkStream ss step =
- case step of
- (E.Continue k) ->
- if null ss then E.continue k
- else mkStream (tail ss) $$ k (E.Chunks [head ss])
- _ -> E.returnI step
-
- ------------------------------------------------------------------------------
- -- Just build up a list and store it in MVar
- ------------------------------------------------------------------------------
- makeList :: MVar [Int] -> E.Iteratee Int IO ()
- makeList m = do
- mb <- EL.head
- case mb of
- Nothing -> return ()
- Just i -> tryIO (modifyMVar_ m (\l -> return (i:l))) >> makeList m
-
- -------------------------------------------------------------
- -- controlled quickcheck, arbitrary tests
- -------------------------------------------------------------
- deepCheck :: (Testable p) => p -> IO Result
- deepCheck = quickCheckWithResult stdArgs{maxSuccess=100,
- maxDiscard=500}
-
- -------------------------------------------------------------
- -- do just one test
- -------------------------------------------------------------
- oneCheck :: (Testable p) => p -> IO Result
- oneCheck = quickCheckWithResult stdArgs{maxSuccess=1,
- maxDiscard=1}
-
- -------------------------------------------------------------
- -- combinator, could be a monad...
- -------------------------------------------------------------
- applyTest :: IO Result -> IO Result -> IO Result
- applyTest r f = do
- r' <- r
- case r' of
- Success _ -> f
- x -> return x
-
- infixr ?>
- (?>) :: IO Result -> IO Result -> IO Result
- (?>) = applyTest
-
- -------------------------------------------------------------
- -- Name tests
- -------------------------------------------------------------
- runTest :: String -> IO Result -> IO Result
- runTest s t = putStrLn ("Test: " ++ s) >> t
-
checkAll :: IO ()
checkAll = do
let good = "OK. All Tests passed."
@@ -463,7 +396,7 @@ where
runTest "Source is closed on Error (sinkI)"
(deepCheck prp_sinkIErr)
case r of
- Success _ -> do
+ Success {} -> do
putStrLn good
exitSuccess
_ -> do
Please sign in to comment.
Something went wrong with that request. Please try again.