IOSpec-0.2.5/0000755000000000000000000000000011720662512011030 5ustar0000000000000000IOSpec-0.2.5/IOSpec.cabal0000644000000000000000000000411411720662512013136 0ustar0000000000000000Name: IOSpec Version: 0.2.5 License: BSD3 License-file: LICENSE Author: Wouter Swierstra, Yusaku Hashimoto Maintainer: Wouter Swierstra Synopsis: A pure specification of the IO monad. Description: This package consists of several modules, that give a pure specification of functions in the IO monad: . * "Test.IOSpec.Fork": a pure specification of 'forkIO'. . * "Test.IOSpec.IORef": a pure specification of most functions that create and manipulate on 'IORefs'. . * "Test.IOSpec.MVar": a pure specification of most functions that create and manipulate and 'MVars'. . * "Test.IOSpec.STM": a pure specification of 'atomically' and the 'STM' monad. . * "Test.IOSpec.Teletype": a pure specification of 'getChar', 'putChar', and several related Prelude functions. . Besides these modules containing the specifications, there are a few other important modules: . * "Test.IOSpec.Types": defines the 'IOSpec' type and several amenities. . * "Test.IOSpec.VirtualMachine": defines a virtual machine on which to execute pure specifications. . * "Test.IOSpec.Surrogate": a drop-in replacement for the other modules. Import this and recompile your code once you've finished testing and debugging. . There are several well-documented examples included with the source distribution. Category: Testing Build-Type: Simple Build-Depends: base >= 2 && < 5, mtl, QuickCheck >= 2 && < 3, Stream Extensions: MultiParamTypeClasses, OverlappingInstances Ghc-options: -Wall Hs-source-dirs: src Extra-source-files: README , examples/Channels.hs , examples/Echo.hs , examples/Queues.hs , examples/Refs.hs , examples/Sudoku.hs Exposed-modules: Test.IOSpec , Test.IOSpec.Fork , Test.IOSpec.IORef , Test.IOSpec.MVar , Test.IOSpec.STM , Test.IOSpec.Surrogate , Test.IOSpec.Teletype , Test.IOSpec.Types , Test.IOSpec.VirtualMachine IOSpec-0.2.5/LICENSE0000644000000000000000000000277411720662512012047 0ustar0000000000000000Copyright Wouter Swierstra 2006. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Wouter Swierstra nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IOSpec-0.2.5/README0000644000000000000000000000213011720662512011704 0ustar0000000000000000IOSpec version 0.2 Author: Wouter Swierstra IOSpec provides a library containing pure, executable specifications of a few functions from the IO monad. Build instructions: $ runhaskell Setup.lhs configure $ runhaskell Setup.lhs build $ runhaskell Setup.lhs install See http://www.haskell.org/ghc/docs/latest/html/Cabal/builders.html for more instructions. Documentation: Please have a look at the latest documentation available from: http://www.cs.nott.ac.uk/~wss/repos/IOSpec To build the Haddock API execute the following command: $ runhaskell Setup.lhs haddock This will require Haddock 2.0 Check out the examples directory for the following examples: * Echo.hs - illustrates how to test the echo function. * Queues.hs - an implementation of queues using IORefs. * Channels.hs - an implementation of channels using MVars. * Sudoku.hs - a parallel Sudoku solver that uses STM and MVars based on Graham Hutton's version of Richard Bird's "Solving Sudoku". Every example contains quite some comments, explaining how to use the library. IOSpec-0.2.5/Setup.lhs0000644000000000000000000000011611720662512012636 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMainIOSpec-0.2.5/examples/0000755000000000000000000000000011720662512012646 5ustar0000000000000000IOSpec-0.2.5/examples/Channels.hs0000644000000000000000000000570211720662512014741 0ustar0000000000000000{-# OPTIONS_GHC -fglasgow-exts #-} import Test.QuickCheck import Control.Monad import Data.Maybe (fromJust, isJust) import Data.List (sort) import Test.IOSpec hiding (Data,putStrLn) import Data.Dynamic -- An implementation of channels using MVars. Simon Peyton Jones's -- paper "Tackling the Awkward Squad" explains this implementation -- of queues in a bit more detail. data Data = Cell Int (MVar Data) deriving Typeable type Channel = (MVar (MVar Data), MVar (MVar Data)) type IOConc a = IOSpec (MVarS :+: ForkS) a newChan :: IOConc Channel newChan = do read <- newEmptyMVar write <- newEmptyMVar hole <- newEmptyMVar putMVar read hole putMVar write hole return (read,write) putChan :: Channel -> Int -> IOConc () putChan (_,write) val = do newHole <- newEmptyMVar oldHole <- takeMVar write putMVar write newHole putMVar oldHole (Cell val newHole) getChan :: Channel -> IOConc Int getChan (read,write) = do headVar <- takeMVar read Cell val newHead <- takeMVar headVar putMVar read newHead return val -- We can now check that data is never lost of duplicated. We fork -- off n threads that write an integer to a channel, together with n -- threads that read from the channel and record the read value in -- an MVar. The main thread waits till all the threads have -- successfully read a value. We can then check that the data -- written to the channel is the same as the data read from it. reader :: Channel -> MVar [Int] -> IOConc () reader channel var = do x <- getChan channel xs <- takeMVar var putMVar var (x:xs) writer :: Channel -> Int -> IOConc () writer channel i = putChan channel i chanTest :: [Int] -> IOConc [Int] chanTest ints = do ch <- newChan result <- newEmptyMVar putMVar result [] forM ints (\i -> forkIO (writer ch i)) replicateM (length ints) (forkIO (reader ch result)) wait result ints wait :: MVar [Int] -> [Int] -> IOConc [Int] wait var xs = do res <- takeMVar var if length res == length xs then return res else putMVar var res >> wait var xs -- When do we consider two Effects equal? In this case, we want the -- same final result, and no other visible effects. (===) :: Eq a => Effect a -> Effect a -> Bool Done x === Done y = x == y _ === _ = False -- To actually run concurrent programs, we must choose the scheduler -- with which to run. At the moment, IOSpec provides a simple -- round-robin scheduler; alternatively we can write our own -- scheduler using "streamSched" that takes a stream of integers to -- a scheduler. -- Using QuickCheck to generate a random stream, we can use the -- streamSched to implement a random scheduler -- thereby testing as -- many interleavings as possible. chanProp :: NonEmptyList Int -> Scheduler -> Bool chanProp (NonEmpty ints) sched = fmap sort (evalIOSpec (chanTest ints) sched) === Done (sort ints) main = do putStrLn "Testing channels..." quickCheck chanPropIOSpec-0.2.5/examples/Echo.hs0000644000000000000000000000423511720662512014064 0ustar0000000000000000-- Note that the Prelude and Test.IOSpec.Teletype both export -- functions called getChar and putChar. To begin with, we hide the -- definitions in the prelude and work with the pure specification. import Prelude hiding (getChar, putChar) import qualified Prelude (putStrLn) import qualified Data.Stream as Stream import Test.IOSpec hiding (putStrLn) import Test.QuickCheck import Data.Char (ord) -- The echo function, as we have always known it echo :: IOSpec Teletype () echo = getChar >>= putChar >> echo -- It should echo any character entered at the teletype. This is -- the behaviour we would expect echo to have. The Output data type -- is defined in Test.IOSpec.Teletype and represents the observable -- behaviour of a teletype interaction. copy :: Effect () copy = ReadChar (\x -> Print x copy) -- An auxiliary function that takes the first n elements printed to -- the teletype. takeOutput :: Int -> Effect () -> String takeOutput 0 _ = "" takeOutput (n + 1) (Print c xs) = c : takeOutput n xs takeOutput _ _ = error "Echo.takeOutput" -- withInput runs an Effect, passing the argument stream of -- characters as the characters entered to stdin. Any effects left -- over will be either Print statements, or a final Done result. withInput :: Stream.Stream Char -> Effect a -> Effect a withInput stdin (Done x) = Done x withInput stdin (Print c e) = Print c (withInput stdin e) withInput stdin (ReadChar f) = withInput (Stream.tail stdin) (f (Stream.head stdin)) -- We can use QuickCheck to test if our echo function meets the -- desired specification: that is that for every input the user -- enters, every finite prefix of runTT echo input and copy input is -- the same. echoProp :: Stream.Stream Char -> Property echoProp input = forAll (choose (1,10000)) $ \n -> takeOutput n (withInput input (evalIOSpec echo singleThreaded)) == takeOutput n (withInput input copy) main = do Prelude.putStrLn "Testing echo..." quickCheck echoProp -- Once we are satisfied with our definition of echo, we can change -- our imports. Rather than importing Test.IOSpec.Teletype, we -- import the "real" getChar and putChar, as defined in the Prelude.IOSpec-0.2.5/examples/Queues.hs0000644000000000000000000001056011720662512014453 0ustar0000000000000000{-# OPTIONS_GHC -fglasgow-exts #-} import Test.QuickCheck import Test.IOSpec hiding (putStrLn) import Prelude hiding (putStrLn) import qualified Prelude (putStrLn) import Data.Dynamic import Control.Monad -- We begin by giving an implementation of queues using our pure -- specification of IORefs. type Queue = (IORef Cell, IORef Cell) data Cell = Cell Int (IORef Cell) | NULL deriving Typeable -- There is one important point here. To use the IORefs in IOSpec, -- we need to make sure that any data we store in an IORef is an -- instance of Typeable. Fortunately, GHC can derive instances of -- Typeable for most data types. -- The implementation of Queues is fairly standard. We use a linked -- list, with special pointers to the head and tail of the queue. emptyQueue :: IOSpec IORefS Queue emptyQueue = do front <- newIORef NULL back <- newIORef NULL return (front,back) enqueue :: Queue -> Int -> IOSpec IORefS () enqueue (front,back) x = do newBack <- newIORef NULL let cell = Cell x newBack c <- readIORef back writeIORef back cell case c of NULL -> writeIORef front cell Cell y t -> writeIORef t cell dequeue :: Queue -> IOSpec IORefS (Maybe Int) dequeue (front,back) = do c <- readIORef front case c of NULL -> return Nothing (Cell x nextRef) -> do next <- readIORef nextRef writeIORef front next return (Just x) -- Besides basic queue operations, we also implement queue reversal. reverseQueue :: Queue -> IOSpec IORefS () reverseQueue (front,back) = do f <- readIORef front case f of NULL -> return () Cell x nextRef -> do flipPointers NULL (Cell x nextRef) f <- readIORef front b <- readIORef back writeIORef front b writeIORef back f flipPointers :: Cell -> Cell -> IOSpec IORefS () flipPointers prev NULL = return () flipPointers prev (Cell x next) = do nextCell <- readIORef next writeIORef next prev flipPointers (Cell x next) nextCell -- A pair of functions that convert lists to queues and vice versa. queueToList :: Queue -> IOSpec IORefS [Int] queueToList = unfoldM dequeue listToQueue :: [Int] -> IOSpec IORefS Queue listToQueue xs = do q <- emptyQueue sequence_ (map (enqueue q) xs) return q unfoldM :: Monad m => (a -> m (Maybe x)) -> a -> m [x] unfoldM f a = do x <- f a case x of Nothing -> return [] Just x -> liftM (x:) (unfoldM f a) -- When do we consider two Effects equal? In this case, we want the -- same final result, and no other visible effects. (===) :: Eq a => Effect a -> Effect a -> Bool Done x === Done y = x == y _ === _ = False -- Now we can state a few properties of queues. inversesProp :: [Int] -> Bool inversesProp xs = (return xs) === evalIOSpec (listToQueue xs >>= queueToList) singleThreaded revRevProp xs = evalIOSpec revRevProg singleThreaded === return xs where revRevProg = do q <- listToQueue xs reverseQueue q reverseQueue q queueToList q revProp xs = evalIOSpec revProg singleThreaded === return (reverse xs) where revProg = do q <- listToQueue xs reverseQueue q queueToList q fifoProp :: [Int] -> Bool fifoProp xs = evalIOSpec enqDeq singleThreaded === return xs where enqDeq :: IOSpec IORefS [Int] enqDeq = do q <- emptyQueue forM_ xs (enqueue q) unfoldM dequeue q queueProp1 x = evalIOSpec queueProg1 singleThreaded === Done (Just x) where queueProg1 = do q <- emptyQueue enqueue q x dequeue q queueProp2 x y = evalIOSpec queueProg2 singleThreaded === Done (Just y) where queueProg2 = do q <- emptyQueue enqueue q x enqueue q y dequeue q dequeue q main = do Prelude.putStrLn "Testing first queue property..." quickCheck queueProp1 Prelude.putStrLn "Testing second queue property..." quickCheck queueProp2 Prelude.putStrLn "Testing queueToList and listToQueue.." quickCheck inversesProp Prelude.putStrLn "Testing that reverseQueue is its own inverse..." quickCheck revRevProp Prelude.putStrLn "Testing reverseQueue matches the spec..." quickCheck revProp -- Once we are satisfied with our implementation, we can import the -- "real" Data.IORef instead of Test.IOSpec.IORef.IOSpec-0.2.5/examples/Refs.hs0000644000000000000000000000112511720662512014100 0ustar0000000000000000import Test.IOSpec import Test.QuickCheck readOnce :: Int -> IOSpec IORefS Int readOnce x = do ref <- newIORef x readIORef ref readTwice :: Int -> IOSpec IORefS Int readTwice x = do ref <- newIORef x readIORef ref readIORef ref readIORefProp :: Int -> Bool readIORefProp x = let once = evalIOSpec (readOnce x) singleThreaded twice = evalIOSpec (readTwice x) singleThreaded in once == twice main = quickCheck readIORefProp instance Eq a => Eq (Effect a) where (Done x) == (Done y) = x == y _ == _ = error "Incomparable effects."IOSpec-0.2.5/examples/Sudoku.hs0000644000000000000000000002152011720662512014454 0ustar0000000000000000{-# OPTIONS_GHC -fglasgow-exts #-} -- Based on Graham Hutton's version of Richard Bird's Sudoku solver. module Main where import Data.List import Control.Monad -- Import these modules to test import Test.IOSpec hiding (putStrLn) import Test.QuickCheck -- Drop the test modules and import these when you want to release -- import Control.Concurrent -- import Control.Concurrent.STM type Grid = Matrix Value type Matrix a = [Row a] type Row a = [TVar a] type Value = Char data Sudoku = Sudoku [[Value]] deriving (Eq,Show) type Concurrency = STMS :+: ForkS :+: MVarS -- Some pure amenities -- The size of the board boxsize :: Int boxsize = 3 -- The possible values of a cell values :: [Value] values = ['1'..'9'] -- A dummy value representing the empty cell empty :: Value -> Bool empty = (== '.') -- When is a cell filled in or not single :: [a] -> Bool single [_] = True single _ = False -- Some functions that return a list of nine rows, columns, or -- boxes of a grid. chop :: Int -> [a] -> [[a]] chop n [] = [] chop n xs = take n xs : chop n (drop n xs) rows :: [[a]] -> [[a]] rows = id cols :: [[a]] -> [[a]] cols = transpose boxes :: [[a]] -> [[a]] boxes = unpack . map cols . pack where pack = split . map split split = chop boxsize unpack = map concat . concat -- When does a list have no duplicates nodups :: Eq a => [a] -> Bool nodups [] = True nodups (x:xs) = not (elem x xs) && nodups xs -- collapse takes a Grid where every cell contains a list of -- possibilities, to a list of Grids where every cell contains a -- single value. collapse :: [[[a]]] -> [[[a]]] collapse = cp . map cp -- cartesian product of a list of lists cp :: [[a]] -> [[a]] cp [] = [[]] cp (xs:xss) = [y:ys | y <- xs, ys <- cp xss] -- The choices function reads in a Sudoku grid, replacing each -- unknown entry by a TVar containing ['1' .. '9'] and each fixed -- entry x by a TVar containing [x]. type Choices = [Value] choices :: [[Value]] -> STM (Matrix Choices) choices vs = mapM (mapM choice) vs choice :: Value -> STM (TVar [Value]) choice v = do newTVar $ if empty v then values else return v -- find all the digits that have been filled in findSingles :: Row Choices -> STM [Value] findSingles [] = return [] findSingles (xs:xss) = do v <- readTVar xs ss <- findSingles xss if single v then return (v ++ ss) else return ss -- cross off all the digits that have been filled in reduce :: Row Choices -> STM () reduce row = do singles <- findSingles row mapM_ (removeSingles singles) row removeSingles :: Choices -> TVar Choices -> STM () removeSingles singles var = do v <- readTVar var writeTVar var (v `minus` singles) -- the prune function prunes the search space, e.g. removing '9' -- from the cells in a row/column/box if there is already a cell -- with a '9' in said row/column/box. Using STM makes the -- concurrency here quite neat - we can prune the rows, columns, and -- boxes at the same time. prune :: Matrix Choices -> IOSpec Concurrency () prune ms = do rowsDone <- newEmptyMVar colsDone <- newEmptyMVar boxesDone <- newEmptyMVar forkIO (pruneBy rowsDone rows ms) forkIO (pruneBy colsDone cols ms) forkIO (pruneBy boxesDone boxes ms) takeMVar rowsDone takeMVar colsDone takeMVar boxesDone pruneBy :: MVar () -> (Matrix Choices -> Matrix Choices) -> Matrix Choices -> IOSpec Concurrency () pruneBy mvar f m = do atomically $ mapM_ reduce (f m) putMVar mvar () -- When is a matrix completely filled in? complete :: Matrix Choices -> STM Bool complete m = liftM (all (all single)) (mapM (mapM readTVar) m) -- When are we 'stuck', i.e. when there is a cell with no possible -- choices left. void :: Matrix Choices -> STM Bool void m = liftM (any (any null)) (mapM (mapM readTVar) m) minus :: Choices -> Choices -> Choices xs `minus` ys = if single xs then xs else xs \\ ys -- A board is consistent if there are no duplicates in every row, -- column, and box. isInconsistent :: Matrix Choices -> STM Bool isInconsistent cm = do rowC <- liftM (all consistent) (mapM (mapM readTVar) (rows cm)) colC <- liftM (all consistent) (mapM (mapM readTVar) (cols cm)) boxC <- liftM (all consistent) (mapM (mapM readTVar) (boxes cm)) return (not (rowC && colC && boxC)) consistent :: [[Value]] -> Bool consistent = nodups . concat . filter single -- A board is blocked if it is void or inconsistent blocked :: Matrix Choices -> STM Bool blocked m = liftM2 (||) (void m) (isInconsistent m) -- The search function checks -- -- * if the board is blocked, we cannot make any progress in this -- thread -- -- * if the board is complete, we are done and fill in the MVar -- waiting for the result. -- -- * otherwise, expand the cell with the smallest number of -- remaining choices to make a list of boards, corresponding to the -- possible ways to fill in that cell. We then fork off a thread to -- try and find a solution for every board in that list. search :: MVar [[Value]] -> Matrix Choices -> IOSpec Concurrency () search mvar m = do isBlocked <- atomically $ blocked m isComplete <- atomically $ complete m if isBlocked then return () else if isComplete then do result <- atomically $ liftM collapse (mapM (mapM readTVar) m) putMVar mvar (head result) else do ms <- expand m mapM_ (\m -> forkIO (prune m >> search mvar m)) ms expand :: Matrix Choices -> IOSpec Concurrency ([Matrix Choices]) expand matrix = do ms <- atomically $ mapM (mapM readTVar) matrix let mms = expand' ms atomically $ mapM (mapM (mapM newTVar)) mms expand' :: [[Choices]] -> [[[Choices]]] expand' m = [rows1 ++ [row1 ++ [c] : row2] ++ rows2 | c <- cs] where (rows1,row:rows2) = break (any p) m (row1,cs:row2) = break p row p xs = length xs == minLength minLength = minimum (filter (> 1) (concatMap (map length) m)) -- The solve function makes an empty MVar, reads in the board, -- prunes it, and searches for solutions. Once a solution is found, -- it will be written to the MVar and returned. solve :: Sudoku -> IOSpec Concurrency Sudoku solve (Sudoku grid) = do solution <- newEmptyMVar matrix <- atomically $ choices grid prune matrix search solution matrix sol <- takeMVar solution return (Sudoku sol) -- Examples easy :: Sudoku easy = Sudoku ["2....1.38", "........5", ".7...6...", ".......13", ".981..257", "31....8..", "9..8...2.", ".5..69784", "4..25...."] gentle :: Sudoku gentle = Sudoku [".1.42...5", "..2.71.39", ".......4.", "2.71....6", "....4....", "6....74.3", ".7.......", "12.73.5..", "3...82.7."] diabolical :: Sudoku diabolical = Sudoku [".9.7..86.", ".31..5.2.", "8.6......", "..7.5...6", "...3.7...", "5...1.7..", "......1.9", ".2.6..35.", ".54..8.7."] solution :: [[Value]] solution = ["295743861", "431865927", "876192543", "387459216", "612387495", "549216738", "763524189", "928671354", "154938672"] -- Given a sudoku puzzle, solve it and check that your solution is ok. unsolved :: Sudoku -> Int unsolved (Sudoku xs) = length $ filter (== '.') (concat xs) correctProp sudoku sched = let (Done computed) = evalIOSpec (solve sudoku) sched in collect (unsolved sudoku) (isSolution computed) -- Determines when a sudoku has been filled in properly. isSolution :: Sudoku -> Bool isSolution (Sudoku grid) = isOk (boxes grid) && isOk (cols grid) && isOk (rows grid) where isOk xss = all (== values) (map sort xss) -- To generate a random sudoku puzzle, we delete a number of cells -- from a solved grid. instance Arbitrary Sudoku where arbitrary = do xs <- arbitrary return (Sudoku $ blankOut xs (concat solution)) blankOut :: [Int] -> [Value] -> [[Value]] blankOut [] grid = chop (boxsize * boxsize) grid blankOut (x:xs) grid = let y = x `mod` 81 in blankOut xs (replace y '.' grid) replace :: Eq a => Int -> a -> [a] -> [a] replace n x xs = take n xs ++ [x] ++ drop (n+1) xs main = do putStrLn "Running QuickCheck tests..." -- A few unit tests putStrLn "Solving easy..." quickCheck (correctProp easy) putStrLn "Solving gentle..." quickCheck (correctProp gentle) putStrLn "Solving diabolical..." quickCheck (correctProp diabolical) -- -- QuickCheck the solver putStrLn "Solving random tests..." quickCheck correctProp IOSpec-0.2.5/src/0000755000000000000000000000000011720662512011617 5ustar0000000000000000IOSpec-0.2.5/src/Test/0000755000000000000000000000000011720662512012536 5ustar0000000000000000IOSpec-0.2.5/src/Test/IOSpec.hs0000644000000000000000000000102611720662512014213 0ustar0000000000000000module Test.IOSpec ( -- * The specifications module Test.IOSpec.Fork , module Test.IOSpec.MVar , module Test.IOSpec.IORef , module Test.IOSpec.STM , module Test.IOSpec.Teletype -- * The basic types , module Test.IOSpec.Types -- * The virtual machine , module Test.IOSpec.VirtualMachine ) where import Test.IOSpec.Fork import Test.IOSpec.MVar import Test.IOSpec.IORef import Test.IOSpec.STM import Test.IOSpec.Teletype import Test.IOSpec.Types (IOSpec, (:+:)(..), inject, (:<:)) import Test.IOSpec.VirtualMachine IOSpec-0.2.5/src/Test/IOSpec/0000755000000000000000000000000011720662512013660 5ustar0000000000000000IOSpec-0.2.5/src/Test/IOSpec/Fork.hs0000644000000000000000000000175711720662512015127 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification, FlexibleContexts, TypeOperators #-} -- | A pure specification of 'forkIO'. module Test.IOSpec.Fork ( ForkS , forkIO ) where import Test.IOSpec.VirtualMachine import Test.IOSpec.Types -- The 'ForkS' data type and its instances. -- -- | An expression of type @IOSpec ForkS a@ corresponds to an 'IO' -- computation that uses 'forkIO' and returns a value of -- type 'a'. -- -- By itself, 'ForkS' is not terribly useful. You will probably want -- to use @IOSpec (ForkS :+: MVarS)@ or @IOSpec (ForkS :+: STMS)@. data ForkS a = forall f b . Executable f => Fork (IOSpec f b) (ThreadId -> a) instance Functor ForkS where fmap f (Fork l io) = Fork l (f . io) -- | The 'forkIO' function forks off a new thread. forkIO :: (Executable f, ForkS :<: g) => IOSpec f a -> IOSpec g ThreadId forkIO p = inject (Fork p return) instance Executable ForkS where step (Fork t p) = do tid <- freshThreadId updateSoup tid t return (Step (p tid)) IOSpec-0.2.5/src/Test/IOSpec/IORef.hs0000644000000000000000000000443111720662512015162 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, TypeOperators #-} -- | A pure specification of mutable variables. module Test.IOSpec.IORef ( -- * The 'IORefS' spec IORefS -- * Manipulation and creation of IORefs , IORef , newIORef , readIORef , writeIORef , modifyIORef ) where import Data.Dynamic import Data.Maybe (fromJust) import Test.IOSpec.Types import Test.IOSpec.VirtualMachine -- The 'IORefS' spec. -- | An expression of type @IOSpec IORefS a@ corresponds to an @IO@ -- computation that uses mutable references and returns a value of -- type @a@. data IORefS a = NewIORef Data (Loc -> a) | ReadIORef Loc (Data -> a) | WriteIORef Loc Data a instance Functor IORefS where fmap f (NewIORef d io) = NewIORef d (f . io) fmap f (ReadIORef l io) = ReadIORef l (f . io) fmap f (WriteIORef l d io) = WriteIORef l d (f io) -- | A mutable variable storing a value of type a. Note that the -- types stored by an 'IORef' are assumed to be @Typeable@. newtype IORef a = IORef Loc -- | The 'newIORef' function creates a new mutable variable. newIORef :: (Typeable a, IORefS :<: f) => a -> IOSpec f (IORef a) newIORef d = inject $ NewIORef (toDyn d) (return . IORef) -- | The 'readIORef' function reads the value stored in a mutable variable. readIORef :: (Typeable a, IORefS :<:f ) => IORef a -> IOSpec f a readIORef (IORef l) = inject $ ReadIORef l (return . fromJust . fromDynamic) -- | The 'writeIORef' function overwrites the value stored in a -- mutable variable. writeIORef :: (Typeable a, IORefS :<: f) => IORef a -> a -> IOSpec f () writeIORef (IORef l) d = inject $ WriteIORef l (toDyn d) (return ()) -- | The 'modifyIORef' function applies a function to the value stored in -- and 'IORef'. modifyIORef :: (Typeable a, IORefS :<: f) => IORef a -> (a -> a) -> IOSpec f () modifyIORef ref f = readIORef ref >>= \x -> writeIORef ref (f x) -- | The 'Executable' instance for the `IORefS' monad. instance Executable IORefS where step (NewIORef d t) = do loc <- alloc updateHeap loc d return (Step (t loc)) step (ReadIORef l t) = do Just d <- lookupHeap l return (Step (t d)) step (WriteIORef l d t) = do updateHeap l d return (Step t) IOSpec-0.2.5/src/Test/IOSpec/MVar.hs0000644000000000000000000000500511720662512015061 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, TypeOperators #-} -- | A pure specification of basic operations on MVars. module Test.IOSpec.MVar ( -- * The 'MVarS' spec MVarS -- * Supported functions , MVar , newEmptyMVar , takeMVar , putMVar ) where import Data.Dynamic import Data.Maybe (fromJust) import Test.IOSpec.Types import Test.IOSpec.VirtualMachine -- The 'MVarS' data type and its instances. -- -- | An expression of type @IOSpec MVarS a@ corresponds to an @IO@ -- computation that uses shared, mutable variables and returns a -- value of type @a@. -- -- By itself, 'MVarS' is not terribly useful. You will probably want -- to use @IOSpec (ForkS :+: MVarS)@. data MVarS a = NewEmptyMVar (Loc -> a) | TakeMVar Loc (Data -> a) | PutMVar Loc Data a instance Functor MVarS where fmap f (NewEmptyMVar io) = NewEmptyMVar (f . io) fmap f (TakeMVar l io) = TakeMVar l (f . io) fmap f (PutMVar l d io) = PutMVar l d (f io) -- | An 'MVar' is a shared, mutable variable. newtype MVar a = MVar Loc deriving Typeable -- | The 'newEmptyMVar' function creates a new 'MVar' that is initially empty. newEmptyMVar :: (Typeable a, MVarS :<: f) => IOSpec f (MVar a) newEmptyMVar = inject $ NewEmptyMVar (return . MVar) -- | The 'takeMVar' function removes the value stored in an -- 'MVar'. If the 'MVar' is empty, the thread is blocked. takeMVar :: (Typeable a, MVarS :<: f) => MVar a -> IOSpec f a takeMVar (MVar l) = inject $ TakeMVar l (return . fromJust . fromDynamic) -- | The 'putMVar' function fills an 'MVar' with a new value. If the -- 'MVar' is not empty, the thread is blocked. putMVar :: (Typeable a, MVarS :<: f) => MVar a -> a -> IOSpec f () putMVar (MVar l) d = inject $ PutMVar l (toDyn d) (return ()) instance Executable MVarS where step (NewEmptyMVar t) = do loc <- alloc emptyLoc loc return (Step (t loc)) step (TakeMVar loc t) = do var <- lookupHeap loc case var of Nothing -> return Block Just x -> do emptyLoc loc return (Step (t x)) step (PutMVar loc d t) = do var <- lookupHeap loc case var of Nothing -> do updateHeap loc d return (Step t) Just _ -> return Block IOSpec-0.2.5/src/Test/IOSpec/STM.hs0000644000000000000000000001017211720662512014660 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification, FlexibleContexts, TypeOperators #-} module Test.IOSpec.STM ( -- * The specification of STM STMS -- * Atomically , atomically -- * The STM monad , STM , TVar , newTVar , readTVar , writeTVar , retry , orElse , check ) where import Test.IOSpec.VirtualMachine import Test.IOSpec.Types import Data.Dynamic import Data.Maybe (fromJust) import Control.Monad.State -- The 'STMS' data type and its instances. -- -- | An expression of type @IOSpec 'STMS' a@ corresponds to an 'IO' -- computation that may use 'atomically' and returns a value of type -- @a@. -- -- By itself, 'STMS' is not terribly useful. You will probably want -- to use @IOSpec (ForkS :+: STMS)@. data STMS a = forall b . Atomically (STM b) (b -> a) instance Functor STMS where fmap f (Atomically s io) = Atomically s (f . io) -- | The 'atomically' function atomically executes an 'STM' action. atomically :: (STMS :<: f) => STM a -> IOSpec f a atomically stm = inject $ Atomically stm (return) instance Executable STMS where step (Atomically stm b) = do state <- get case runStateT (executeSTM stm) state of Done (Nothing,_) -> return Block Done (Just x,finalState) -> put finalState >> return (Step (b x)) _ -> internalError "Unsafe usage of STM" -- The 'STM' data type and its instances. data STM a = STMReturn a | NewTVar Data (Loc -> STM a) | ReadTVar Loc (Data -> STM a) | WriteTVar Loc Data (STM a) | Retry | OrElse (STM a) (STM a) instance Functor STM where fmap f (STMReturn x) = STMReturn (f x) fmap f (NewTVar d io) = NewTVar d (fmap f . io) fmap f (ReadTVar l io) = ReadTVar l (fmap f . io) fmap f (WriteTVar l d io) = WriteTVar l d (fmap f io) fmap _ Retry = Retry fmap f (OrElse io1 io2) = OrElse (fmap f io1) (fmap f io2) instance Monad STM where return = STMReturn STMReturn a >>= f = f a NewTVar d g >>= f = NewTVar d (\l -> g l >>= f) ReadTVar l g >>= f = ReadTVar l (\d -> g d >>= f) WriteTVar l d p >>= f = WriteTVar l d (p >>= f) Retry >>= _ = Retry OrElse p q >>= f = OrElse (p >>= f) (q >>= f) -- | A 'TVar' is a shared, mutable variable used by STM. newtype TVar a = TVar Loc -- | The 'newTVar' function creates a new transactional variable. newTVar :: Typeable a => a -> STM (TVar a) newTVar d = NewTVar (toDyn d) (STMReturn . TVar) -- | The 'readTVar' function reads the value stored in a -- transactional variable. readTVar :: Typeable a => TVar a -> STM a readTVar (TVar l) = ReadTVar l (STMReturn . fromJust . fromDynamic) -- | The 'writeTVar' function overwrites the value stored in a -- transactional variable. writeTVar :: Typeable a => TVar a -> a -> STM () writeTVar (TVar l) d = WriteTVar l (toDyn d) (STMReturn ()) -- | The 'retry' function abandons a transaction and retries at some -- later time. retry :: STM a retry = Retry -- | The 'check' function checks if its boolean argument holds. If -- the boolean is true, it returns (); otherwise it calls 'retry'. check :: Bool -> STM () check True = return () check False = retry -- | The 'orElse' function takes two 'STM' actions @stm1@ and @stm2@ and -- performs @stm1@. If @stm1@ calls 'retry' it performs @stm2@. If @stm1@ -- succeeds, on the other hand, @stm2@ is not executed. orElse :: STM a -> STM a -> STM a orElse p q = OrElse p q executeSTM :: STM a -> VM (Maybe a) executeSTM (STMReturn x) = return (return x) executeSTM (NewTVar d io) = do loc <- alloc updateHeap loc d executeSTM (io loc) executeSTM (ReadTVar l io) = do (Just d) <- lookupHeap l executeSTM (io d) executeSTM (WriteTVar l d io) = do updateHeap l d executeSTM io executeSTM Retry = return Nothing executeSTM (OrElse p q) = do state <- get case runStateT (executeSTM p) state of Done (Nothing,_) -> executeSTM q Done (Just x,s) -> put s >> return (Just x) _ -> internalError "Unsafe usage of STM" internalError :: String -> a internalError msg = error ("IOSpec.STM: " ++ msg) IOSpec-0.2.5/src/Test/IOSpec/Surrogate.hs0000644000000000000000000000135611720662512016174 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls, TypeOperators #-} -- | This module contains a few type signatures to help replace pure -- specifications by their effectful counterparts. module Test.IOSpec.Surrogate ( -- * The IOSpec type IOSpec -- * The specifications , ForkS , MVarS , IORefS , STMS , Teletype , (:+:) ) where -- | The @IOSpec f a@ is merely type synonym for @IO a@. Once you've -- tested a module, you can use these definitions to avoid having to -- change your type signatures. -- -- Note that because this definition of 'IOSpec' ignores its @f@ -- argument, each of 'ForkS', 'MVarS', etc., is simply an empty data -- type. type IOSpec f a = IO a data ForkS data MVarS data IORefS data STMS data Teletype data (f :+: g) IOSpec-0.2.5/src/Test/IOSpec/Teletype.hs0000644000000000000000000000345211720662512016013 0ustar0000000000000000{-# LANGUAGE FlexibleContexts, TypeOperators #-} -- | A pure specification of getChar and putChar. module Test.IOSpec.Teletype ( -- * The IOTeletype monad Teletype -- * Pure getChar and putChar , getChar , putChar , putStr , putStrLn , getLine ) where import Prelude hiding (getChar, putChar, putStr, putStrLn, getLine) import Control.Monad (forM_) import Test.IOSpec.Types import Test.IOSpec.VirtualMachine -- The 'Teletype' specification. -- -- | An expression of type 'IOSpec' 'Teletype' @a@ corresponds to an @IO@ -- computation that may print to or read from stdout and stdin -- respectively. -- -- There is a minor caveat here. I assume that stdin and stdout are -- not buffered. This is not the standard behaviour in many Haskell -- compilers. data Teletype a = GetChar (Char -> a) | PutChar Char a instance Functor Teletype where fmap f (GetChar tt) = GetChar (f . tt) fmap f (PutChar c tt) = PutChar c (f tt) -- | The 'getChar' function can be used to read a character from the -- teletype. getChar :: (:<:) Teletype f => IOSpec f Char getChar = inject (GetChar return) -- | The 'getChar' function can be used to print a character to the -- teletype. putChar :: (Teletype :<: f) => Char -> IOSpec f () putChar c = inject (PutChar c (return ())) instance Executable Teletype where step (GetChar f) = do c <- readChar return (Step (f c)) step (PutChar c a) = do printChar c return (Step a) putStr :: (Teletype :<: f) => String -> IOSpec f () putStr str = forM_ str putChar putStrLn :: (Teletype :<: f) => String -> IOSpec f () putStrLn str = putStr str >> putChar '\n' getLine :: (Teletype :<: f) => IOSpec f String getLine = do c <- getChar if c == '\n' then return [] else getLine >>= \line -> return (c : line) IOSpec-0.2.5/src/Test/IOSpec/Types.hs0000644000000000000000000000347211720662512015326 0ustar0000000000000000{-# LANGUAGE OverlappingInstances, TypeOperators, FlexibleInstances #-} -- | This module contains the basic data types underlying the -- 'IOSpec' library. Most of the types and classes in this module -- are described in -- . module Test.IOSpec.Types ( -- * The 'IOSpec' type. IOSpec(..) , foldIOSpec -- * Coproducts of functors , (:+:)(..) -- * Injections from one functor to another , (:<:) , inject ) where -- | A value of type 'IOSpec' @f@ @a@ is either a pure value of type @a@ -- or some effect, determined by @f@. Crucially, 'IOSpec' @f@ is a -- monad, provided @f@ is a functor. data IOSpec f a = Pure a | Impure (f (IOSpec f a)) instance (Functor f) => Functor (IOSpec f) where fmap f (Pure x) = Pure (f x) fmap f (Impure t) = Impure (fmap (fmap f) t) instance (Functor f) => Monad (IOSpec f) where return = Pure (Pure x) >>= f = f x (Impure t) >>= f = Impure (fmap (>>= f) t) -- | The fold over 'IOSpec' values. foldIOSpec :: Functor f => (a -> b) -> (f b -> b) -> IOSpec f a -> b foldIOSpec pure _ (Pure x) = pure x foldIOSpec pure impure (Impure t) = impure (fmap (foldIOSpec pure impure) t) -- | The coproduct of functors data (f :+: g) x = Inl (f x) | Inr (g x) infixr 5 :+: instance (Functor f, Functor g) => Functor (f :+: g) where fmap f (Inl x) = Inl (fmap f x) fmap f (Inr y) = Inr (fmap f y) -- | The (:<:) class class (Functor sub, Functor sup) => sub :<: sup where inj :: sub a -> sup a instance Functor f => (:<:) f f where inj = id instance (Functor f, Functor g) => (:<:) f (f :+: g) where inj = Inl instance ((:<:) f g, Functor f, Functor g, Functor h) => (:<:) f (h :+: g) where inj = Inr . inj inject :: (g :<: f) => g (IOSpec f a) -> IOSpec f a inject = Impure . injIOSpec-0.2.5/src/Test/IOSpec/VirtualMachine.hs0000644000000000000000000002627611720662512017144 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification, TypeOperators #-} -- | The virtual machine on which the specifications execute. module Test.IOSpec.VirtualMachine ( -- * The Virtual Machine VM , Data , Loc , Scheduler , Store , ThreadId , initialStore -- * Primitive operations on the VM , alloc , emptyLoc , freshThreadId , finishThread , lookupHeap , mainTid , printChar , readChar , updateHeap , updateSoup -- * The observable effects on the VM , Effect (..) -- * Sample schedulers -- $schedulerDoc , roundRobin , singleThreaded -- * Executing code on the VM , Executable(..) , Step(..) , runIOSpec , evalIOSpec , execIOSpec ) where import Control.Monad.State import Data.Dynamic import Data.List import qualified Data.Stream as Stream import Test.IOSpec.Types import Test.QuickCheck type Data = Dynamic type Loc = Int type Heap = Loc -> Maybe Data newtype ThreadId = ThreadId Int deriving (Eq, Show) instance Arbitrary ThreadId where arbitrary = liftM ThreadId arbitrary instance CoArbitrary ThreadId where coarbitrary (ThreadId k) = coarbitrary k newtype Scheduler = Scheduler (Int -> (Int, Scheduler)) instance Arbitrary Scheduler where arbitrary = liftM streamSched arbitrary instance Show Scheduler where show _ = "Test.IOSpec.Scheduler" data ThreadStatus = forall f b . Executable f => Running (IOSpec f b) | Finished type ThreadSoup = ThreadId -> ThreadStatus data Store = Store { fresh :: Loc , heap :: Heap , nextTid :: ThreadId , blockedThreads :: [ThreadId] , finishedThreads :: [ThreadId] , scheduler :: Scheduler , threadSoup :: ThreadSoup } initialStore :: Scheduler -> Store initialStore sch = Store { fresh = 0 , heap = internalError "Access of unallocated memory " , nextTid = ThreadId 1 , blockedThreads = [] , finishedThreads = [] , scheduler = sch , threadSoup = internalError "Unknown thread scheduled" } -- Auxiliary functions modifyFresh :: (Loc -> Loc) -> VM () modifyFresh f = do s <- get put (s {fresh = f (fresh s)}) modifyHeap :: (Heap -> Heap) -> VM () modifyHeap f = do s <- get put (s {heap = f (heap s)}) modifyNextTid :: (ThreadId -> ThreadId) -> VM () modifyNextTid f = do s <- get put (s {nextTid = f (nextTid s)}) modifyBlockedThreads :: ([ThreadId] -> [ThreadId]) -> VM () modifyBlockedThreads f = do s <- get put (s {blockedThreads = f (blockedThreads s)}) modifyFinishedThreads :: ([ThreadId] -> [ThreadId]) -> VM () modifyFinishedThreads f = do s <- get put (s {finishedThreads = f (finishedThreads s)}) modifyScheduler :: (Scheduler -> Scheduler) -> VM () modifyScheduler f = do s <- get put (s {scheduler = f (scheduler s)}) modifyThreadSoup :: (ThreadSoup -> ThreadSoup) -> VM () modifyThreadSoup f = do s <- get put (s {threadSoup = f (threadSoup s)}) -- | The 'VM' monad is essentially a state monad, modifying the -- store. Besides returning pure values, various primitive effects -- may occur, such as printing characters or failing with an error -- message. type VM a = StateT Store Effect a -- | The 'alloc' function allocate a fresh location on the heap. alloc :: VM Loc alloc = do loc <- gets fresh modifyFresh ((+) 1) return loc -- | The 'emptyLoc' function removes the data stored at a given -- location. This corresponds, for instance, to emptying an @MVar@. emptyLoc :: Loc -> VM () emptyLoc l = modifyHeap (update l Nothing) -- | The 'freshThreadId' function returns a previously unallocated 'ThreadId'. freshThreadId :: VM ThreadId freshThreadId = do t <- gets nextTid modifyNextTid (\(ThreadId n) -> ThreadId (n+1)) return t -- | The 'finishThread' function kills the thread with the specified -- 'ThreadId'. finishThread :: ThreadId -> VM () finishThread tid = do modifyFinishedThreads (tid:) modifyThreadSoup (update tid Finished) -- | The 'blockThread' method is used to record when a thread cannot -- make progress. blockThread :: ThreadId -> VM () blockThread tid = modifyBlockedThreads (tid:) -- | When progress is made, the 'resetBlockedThreads' function -- | ensures that any thread can be scheduled. resetBlockedThreads :: VM () resetBlockedThreads = modifyBlockedThreads (const []) -- | The 'lookupHeap' function returns the data stored at a given -- heap location, if there is any. lookupHeap :: Loc -> VM (Maybe Data) lookupHeap l = do h <- gets heap return (h l) -- | The 'mainTid' constant is the 'ThreadId' of the main process. mainTid :: ThreadId mainTid = ThreadId 0 -- | The 'readChar' and 'printChar' functions are the primitive -- counterparts of 'getChar' and 'putChar' in the 'VM' monad. readChar :: VM Char readChar = StateT (\s -> (ReadChar (\c -> (Done (c,s))))) printChar :: Char -> VM () printChar c = StateT (\s -> (Print c (Done ((),s)))) -- | The 'updateHeap' function overwrites a given location with -- new data. updateHeap :: Loc -> Data -> VM () updateHeap l d = modifyHeap (update l (Just d)) -- | The 'updateSoup' function updates the process associated with a -- given 'ThreadId'. updateSoup :: Executable f => ThreadId -> IOSpec f a -> VM () updateSoup tid p = modifyThreadSoup (update tid (Running p)) update :: Eq a => a -> b -> (a -> b) -> (a -> b) update l d h k | l == k = d | otherwise = h k -- | The 'Effect' type contains all the primitive effects that are -- observable on the virtual machine. data Effect a = Done a | ReadChar (Char -> Effect a) | Print Char (Effect a) | Fail String instance Functor Effect where fmap f (Done x) = Done (f x) fmap f (ReadChar t) = ReadChar (\c -> fmap f (t c)) fmap f (Print c t) = Print c (fmap f t) fmap _ (Fail msg) = Fail msg instance Monad Effect where return = Done (Done x) >>= f = f x (ReadChar t) >>= f = ReadChar (\c -> t c >>= f) (Print c t) >>= f = Print c (t >>= f) (Fail msg) >>= _ = Fail msg instance Eq a => Eq (Effect a) where (Done x) == (Done y) = x == y (ReadChar f) == (ReadChar g) = all (\x -> f x == g x) [minBound .. maxBound] (Print c t) == (Print d u) = c == d && t == u (Fail s) == (Fail t) = s == t _ == _ = False -- $schedulerDoc -- -- There are two example scheduling algorithms 'roundRobin' and -- 'singleThreaded'. Note that 'Scheduler' is also an instance of -- @Arbitrary@. Using QuickCheck to generate random schedulers is a -- great way to maximise the number of interleavings that your tests -- cover. -- | The 'roundRobin' scheduler provides a simple round-robin scheduler. roundRobin :: Scheduler roundRobin = streamSched (Stream.unfold (\k -> (k, k+1)) 0) -- | The 'singleThreaded' scheduler will never schedule forked -- threads, always scheduling the main thread. Only use this -- scheduler if your code is not concurrent. singleThreaded :: Scheduler singleThreaded = streamSched (Stream.repeat 0) streamSched :: Stream.Stream Int -> Scheduler streamSched (Stream.Cons x xs) = Scheduler (\k -> (x `mod` k, streamSched xs)) -- | The 'Executable' type class captures all the different types of -- operations that can be executed in the 'VM' monad. class Functor f => Executable f where step :: f a -> VM (Step a) data Step a = Step a | Block instance (Executable f, Executable g) => Executable (f :+: g) where step (Inl x) = step x step (Inr y) = step y -- The 'execVM' function essentially schedules a thread and allows -- it to perform a single step. If the main thread is finished, it -- returns the final result of the comptuation. execVM :: Executable f => IOSpec f a -> VM a execVM main = do (tid,t) <- schedule main case t of (Main (Pure x)) -> resetBlockedThreads >> return x (Main (Impure p)) -> do x <- step p case x of Step y -> resetBlockedThreads >> execVM y Block -> blockThread mainTid >> execVM main (Aux (Pure _)) -> do finishThread tid execVM main (Aux (Impure p)) -> do x <- step p case x of Step y -> resetBlockedThreads >> updateSoup tid y >> execVM main Block -> blockThread tid >> execVM main -- A Process is the result of a call to the scheduler. data Process a = forall f . Executable f => Main (IOSpec f a) | forall f b . Executable f => Aux (IOSpec f b) -- Gets the ThreadId of the next thread to schedule. getNextThreadId :: VM ThreadId getNextThreadId = do Scheduler sch <- gets scheduler (ThreadId total) <- gets nextTid let allTids = [ThreadId i | i <- [0 .. total - 1]] blockedTids <- gets blockedThreads finishedTids <- gets finishedThreads let activeThreads = allTids \\ (blockedTids `union` finishedTids) let (i,s) = sch (length activeThreads) modifyScheduler (const s) return (activeThreads !! i) -- The 'schedule' function tries to schedule an active thread, -- returning the scheduled thread's ThreadId and the process -- associated with that id. schedule :: Executable f => IOSpec f a -> VM (ThreadId, Process a) schedule main = do tid <- getNextThreadId if tid == mainTid then return (mainTid, Main main) else do tsoup <- gets threadSoup case tsoup tid of Finished -> internalError "Scheduled finished thread." Running p -> return (tid, Aux p) -- | The 'runIOSpec' function is the heart of this library. Given -- the scheduling algorithm you want to use, it will run a value of -- type 'IOSpec' @f@ @a@, returning the sequence of observable effects -- together with the final store. runIOSpec :: Executable f => IOSpec f a -> Scheduler -> Effect (a, Store) runIOSpec io sched = runStateT (execVM io) (initialStore sched) -- | The 'execIOSpec' returns the final 'Store' after executing a -- computation. -- -- /Beware/: this function assumes that your computation will -- succeed, without any other visible 'Effect'. If your computation -- reads a character from the teletype, for instance, it will return -- an error. execIOSpec :: Executable f => IOSpec f a -> Scheduler -> Store execIOSpec io sched = case runIOSpec io sched of Done (_,s) -> s _ -> error $ "Failed application of Test.IOSpec.execIOSpec.\n" ++ "Probable cause: your function uses functions such as " ++ "putChar and getChar. Check the preconditions for calling " ++ "this function in the IOSpec documentation." -- | The 'evalIOSpec' function returns the effects a computation -- yields, but discards the final state of the virtual machine. evalIOSpec :: Executable f => IOSpec f a -> Scheduler -> Effect a evalIOSpec io sched = fmap fst (runIOSpec io sched) internalError :: String -> a internalError msg = error ("IOSpec.VirtualMachine: " ++ msg)