PriorityChansConverger-0.1: examples/SimplePCCTestEnvironment/SimplePCCTestEnvironment.hs
{-
Copyright (C) 2009-2010 Andrejs Sisojevs <andrejs.sisojevs@nextmail.ru>
All rights reserved.
For license and copyright information, see the file COPYRIGHT
-}
--------------------------------------------------------------------------
--------------------------------------------------------------------------
{-
abbr. PCC = PriorityChansConverger
Table of content:
1. Let's define system structure first.
1.1. Sources of input to our PCC.
1.2. Output of our PCC reader.
1.3. Put together PCC, it's input sources and it's output reader.
2. Now, when the infrastructure is ready let's define some test cases and run them.
2.1. Test cases set. Not a complete set. If anybody wants to test it seriously, that would be great.
2.2. Running tests.
3. Representations (instances of Show class).
Appendix: Some helper functions.
-------------------------------------------
Direct PCC usage is to be found only in parts 1.1., 1.2. and 1.3.
-}
{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}
module SimplePCCTestEnvironment where
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Concurrent.ConcurrentUISupport -- this module is provided by PCC package
import Control.Concurrent.STM
import Control.Concurrent.PriorityChansConverger -- this module is provided by PCC package
import Control.Monad
import qualified Control.Exception as E
import Data.List
import qualified Data.Map as M
import Data.Map (Map)
import qualified Safe.Failure as SF
import System.IO
import System.IO.Unsafe
__useDumps = True
----------------------------------------------------------------------
----------------------------------------------------------------------
-- 1. Let's define system structure first.
----------------------------------------------------------------------
-- 1.1. Sources of input to our PCC.
type PCCFillerID = Int -- PCC requires anything, that is of class Ord
type PCCFillerState = Int
type PCCFillerOutput = PCCFillerState
type PCCFillerCloser = ThreadFinisher
type MicrosecondsForDelay = Int
type SecondsForDelay = Int
data PCCFiller =
PCCFiller {
pccfInputID :: PCCFillerID -- local type
, pccfStartPriority :: StartPriority -- Int
, pccfChanCapacity :: ChanCapacity -- Int
, pccfPermitToBlock :: PermitToBlock -- Bool
, pccfDelayBetweenIterations :: MicrosecondsForDelay
, pccfStateMV :: MVar PCCFillerState
, pccfStateTransition :: PCCFillerState -> PCCFillerState
, pccfStopFiller :: MVar PCCFillerCloser
}
defaultPCCFiller :: IO PCCFiller
defaultPCCFiller = do
state_mv <- newMVar 1
stopper <- newMVar $ return ()
return PCCFiller {
pccfInputID = undefined
, pccfStartPriority = undefined
, pccfChanCapacity = undefined
, pccfPermitToBlock = undefined
, pccfDelayBetweenIterations = undefined
, pccfStateMV = state_mv
, pccfStateTransition = (+ 1)
, pccfStopFiller = stopper
}
runPCCFiller :: PCCFiller -> PriorityChansConverger PCCFillerID PCCFillerOutput -> ConcurrentUISupport -> IO ()
runPCCFiller pccf pcc cuis = do
when __useDumps $ dump "" ("PCCFiller" ++ show channelID) WriteMode
interrupter_tv <- atomically $ newTVar False
cuisWrite cuis ("PCC filler (ID: " ++ show channelID ++ ") started.")
modifyMVar_
(pccfStopFiller pccf)
(\ _ -> return $ do
cuisWrite cuis ("Signal to finish PCC filler (ID: " ++ show channelID ++ ") is sent.")
atomically $ modifyTVar_ interrupter_tv (const True)
)
_ <- forkIO $ threadCycle interrupter_tv
return ()
where
channelID = pccfInputID pccf
------------
threadCycle :: TVar InterruptShouldWe -> IO ()
threadCycle interrupter_tv = _cycle
where
_cycle :: IO () -- It's possible to make this thread more STMish, use Control.Concurrent.PriorityChansConverger.PriorityChansConvergerSTM directly.
_cycle = do
stop <- atomically $ readTVar interrupter_tv
case stop of
True -> do
cuisWrite cuis ("PCC filler (ID: " ++ show channelID ++ ") finished.")
return () -- exit
False -> do
state <- modifyMVar
(pccfStateMV pccf)
(\ current_state ->
return (pccfStateTransition pccf current_state, current_state)
)
when __useDumps $ reportExceptionIfAny_2 cuis "runPCCFiller:dump1" $ dump2 (return "\n----Before-write-----------------------------\n") ("PCCFiller" ++ show (pccfInputID pccf)) AppendMode
when __useDumps $ reportExceptionIfAny_2 cuis "runPCCFiller:dump2" $ dump2 (showPCC pcc) ("PCCFiller" ++ show (pccfInputID pccf)) AppendMode -- #########################################
br_or_mb_failure <- case pccfPermitToBlock pccf of
True -> stmInterruptableWriteInPCC (readTVar interrupter_tv) channelID state pcc
False -> Right `liftM` writeInPCC False channelID state pcc
when __useDumps $ reportExceptionIfAny_2 cuis "runPCCFiller:dump3" $ dump2 (return "\n----After-write------------------------------\n") ("PCCFiller" ++ show (pccfInputID pccf)) AppendMode
when __useDumps $ reportExceptionIfAny_2 cuis "runPCCFiller:dump4" $ dump2 (showPCC pcc) ("PCCFiller" ++ show (pccfInputID pccf)) AppendMode -- #########################################
case br_or_mb_failure of
Left () -> cuisWrite cuis ("Writing to channel (ID: " ++ show channelID ++ ") was interrupted." )
Right Nothing -> cuisWrite cuis ("Wrote to channel (ID: " ++ show channelID ++ "): " ++ show (channelID, state) )
Right (Just BadKey_FRWPCC) -> cuisWrite cuis ("Write to channel (ID: " ++ show channelID ++ ") FAILED: bad key." )
Right (Just ChanFull_FRWPCC) -> cuisWrite cuis ("Write to channel (ID: " ++ show channelID ++ ") FAILED: not enough space in channel." )
stop2 <- atomically $ readTVar interrupter_tv
unless stop2 $ threadDelay (pccfDelayBetweenIterations pccf)
_cycle
runPCCFillersArray :: [PCCFiller] -> PriorityChansConverger PCCFillerID PCCFillerOutput -> ConcurrentUISupport -> IO ()
runPCCFillersArray pccf_list pcc cuis = mapM_ (\ pccf -> runPCCFiller pccf pcc cuis) pccf_list
stopPCCFiller :: PCCFiller -> IO ()
stopPCCFiller = join . readMVar . pccfStopFiller
stopPCCFillersArray :: [PCCFiller] -> IO ()
stopPCCFillersArray = mapM_ stopPCCFiller
----------------------------------------------------------------------
-- 1.2. Output of our PCC reader.
----------------------------------------------------------------------
type PCCReaderID = Int
data PCCReader =
PCCReader {
pccrReaderID :: PCCReaderID
, pccrPermitToBlock :: PermitToBlock
, pccrMicrosecondsForDelay :: MicrosecondsForDelay
, pccrStopFiller :: MVar PCCFillerCloser
}
defaultPCCReader :: IO PCCReader
defaultPCCReader = do
stopper <- newMVar $ return ()
return PCCReader {
pccrReaderID = undefined
, pccrPermitToBlock = undefined
, pccrMicrosecondsForDelay = undefined
, pccrStopFiller = stopper
}
runPCCReader :: PCCReader -> PriorityChansConverger PCCFillerID PCCFillerOutput -> ConcurrentUISupport -> IO ()
runPCCReader pccr pcc cuis = do
when __useDumps $ dump "" f_name WriteMode
interrupter_tv <- atomically $ newTVar False
cuisWrite cuis ("PCC reader (ID: " ++ show (pccrReaderID pccr) ++ ") started.")
_ <- forkIO $ threadCycle interrupter_tv
modifyMVar_
(pccrStopFiller pccr)
(\ _ -> return $ do
cuisWrite cuis ("Signal to finish PCC reader (ID: " ++ show (pccrReaderID pccr) ++ ") is sent.")
atomically $ modifyTVar_ interrupter_tv (const True)
)
return ()
where
f_name = "PCCReader" ++ show (pccrReaderID pccr)
------------
threadCycle :: TVar InterruptShouldWe -> IO ()
threadCycle interrupter_tv = _cycle
where
_cycle :: IO () -- It's possible to make this thread more STMish, use Control.Concurrent.PriorityChansConverger.PriorityChansConvergerSTM directly.
_cycle = do
stop <- atomically $ readTVar interrupter_tv
case stop of
True -> do
cuisWrite cuis ("PCC reader (ID: " ++ show (pccrReaderID pccr) ++ ") finished.")
return () -- exit
False -> do
when __useDumps $ reportExceptionIfAny_2 cuis "runPCCReader:dump1" $ dump2 (return "\n----Before-read------------------------------\n") f_name AppendMode
when __useDumps $ reportExceptionIfAny_2 cuis "runPCCReader:dump2" $ dump2 (showPCC pcc) f_name AppendMode -- #########################################
br_or_elem <- case pccrPermitToBlock pccr of
True -> stmInterruptableReadFromPCC (readTVar interrupter_tv) pcc
False -> do
mb_r <- readFromPCC False pcc
return $ case mb_r of
Nothing -> Left ()
Just r -> Right r
when __useDumps $ reportExceptionIfAny_2 cuis "runPCCReader:dump3" $ dump2 (return "\n----After-read-------------------------------\n") f_name AppendMode
when __useDumps $ reportExceptionIfAny_2 cuis "runPCCReader:dump4" $ dump2 (showPCC pcc) f_name AppendMode -- #########################################
case (pccrPermitToBlock pccr, br_or_elem) of
(True , Left ()) -> cuisWrite cuis ("Read from PCC (reader ID: " ++ show (pccrReaderID pccr) ++ ") is interrupred.")
(False, Left ()) -> cuisWrite cuis ("Read from PCC (reader ID: " ++ show (pccrReaderID pccr) ++ ") failed: PCC is empty.")
(_ , Right (k, e)) -> cuisWrite cuis ("Read from PCC (reader ID: " ++ show (pccrReaderID pccr) ++ "): " ++ show (k, e))
stop2 <- atomically $ readTVar interrupter_tv
unless stop2 $ threadDelay (pccrMicrosecondsForDelay pccr)
_cycle
stopPCCReader :: PCCReader -> IO ()
stopPCCReader = join . readMVar . pccrStopFiller
runPCCReadersArray :: [PCCReader] -> PriorityChansConverger PCCFillerID PCCFillerOutput -> ConcurrentUISupport -> IO ()
runPCCReadersArray pccr_list pcc cuis = mapM_ (\ pccr -> runPCCReader pccr pcc cuis) pccr_list
stopPCCReadersArray :: [PCCReader] -> IO ()
stopPCCReadersArray = mapM_ stopPCCReader
----------------------------------------------------------------------
-- 1.3. Put together PCC, it's input sources and it's output reader.
----------------------------------------------------------------------
listOfFillers_to_ChansMapToConstructPCC :: [PCCFiller] -> Map PCCFillerID (StartPriority, ChanCapacity)
listOfFillers_to_ChansMapToConstructPCC pccf_list =
M.fromList $ map
(\ pccf ->
( pccfInputID pccf
, (pccfStartPriority pccf
, pccfChanCapacity pccf
) )
)
pccf_list
constructPCC :: [PCCFiller] -> ConcurrentUISupport -> IO (PriorityChansConverger PCCFillerID PCCFillerOutput)
constructPCC pccf_list cuis = newPriorityChansConverger_wCUIS (Just cuis) $ listOfFillers_to_ChansMapToConstructPCC pccf_list
-- When constructing new PCC, it is possible to use 'newPriorityChansConverger'
-- instead of 'newPriorityChansConverger_wCUIS' which isn't using
-- any 'ConcurrentUISupport'
runFillersAndPCCAndReaders :: [PCCFiller] -> [PCCReader] -> ConcurrentUISupport -> IO ThreadFinisher
runFillersAndPCCAndReaders pccf_list pccr_list cuis = do
pcc <- constructPCC pccf_list cuis
runPCCFillersArray pccf_list pcc cuis
runPCCReadersArray pccr_list pcc cuis
interrupter_tv <- atomically $ newTVar False
_ <- forkIO $ do
atomically $ do
stop <- readTVar interrupter_tv
case stop of
True -> return ()
False -> retry
stopPCCFillersArray pccf_list
stopPCCReadersArray pccr_list
return (atomically $ writeTVar interrupter_tv True)
----------------------------------------------------------------------
----------------------------------------------------------------------
-- 2. Now, when the infrastructure is ready let's define
-- some test cases and run them
----------------------------------------------------------------------
----------------------------------------------------------------------
-- 2.1. Test cases set.
-- Not a complete set. If anybody wants to test it seriously,
-- that would be great.
type InputMode = Int
inputChansSet :: InputMode -> IO [PCCFiller]
inputChansSet 1 = sequence []
inputChansSet 2 = sequence [ defaultPCCFiller >>= \ pccf -> return pccf { pccfInputID = 1, pccfStartPriority = 10, pccfChanCapacity = 0, pccfPermitToBlock = False, pccfDelayBetweenIterations = 1000000 } ]
inputChansSet 3 = sequence [ defaultPCCFiller >>= \ pccf -> return pccf { pccfInputID = 1, pccfStartPriority = 10, pccfChanCapacity = 1, pccfPermitToBlock = True, pccfDelayBetweenIterations = 1000000 } ]
inputChansSet 4 = sequence [ defaultPCCFiller >>= \ pccf -> return pccf { pccfInputID = 1, pccfStartPriority = 5, pccfChanCapacity = 3, pccfPermitToBlock = False, pccfDelayBetweenIterations = 900000 }
, defaultPCCFiller >>= \ pccf -> return pccf { pccfInputID = 2, pccfStartPriority = 3, pccfChanCapacity = 5, pccfPermitToBlock = False, pccfDelayBetweenIterations = 1200000 }
]
inputChansSet 5 = sequence [ defaultPCCFiller >>= \ pccf -> return pccf { pccfInputID = 1, pccfStartPriority = 10, pccfChanCapacity = 4, pccfPermitToBlock = True, pccfDelayBetweenIterations = 1000000 }
, defaultPCCFiller >>= \ pccf -> return pccf { pccfInputID = 2, pccfStartPriority = 8, pccfChanCapacity = 6, pccfPermitToBlock = True, pccfDelayBetweenIterations = 1000000 }
, defaultPCCFiller >>= \ pccf -> return pccf { pccfInputID = 3, pccfStartPriority = 6, pccfChanCapacity = 8, pccfPermitToBlock = True, pccfDelayBetweenIterations = 1000000 }
, defaultPCCFiller >>= \ pccf -> return pccf { pccfInputID = 4, pccfStartPriority = 4, pccfChanCapacity = 10, pccfPermitToBlock = True, pccfDelayBetweenIterations = 1000000 }
]
inputChansSet 6 = sequence [ defaultPCCFiller >>= \ pccf -> return pccf { pccfInputID = 1, pccfStartPriority = 10, pccfChanCapacity = 4, pccfPermitToBlock = True, pccfDelayBetweenIterations = 200000 }
, defaultPCCFiller >>= \ pccf -> return pccf { pccfInputID = 2, pccfStartPriority = 8, pccfChanCapacity = 6, pccfPermitToBlock = False, pccfDelayBetweenIterations = 200000 }
, defaultPCCFiller >>= \ pccf -> return pccf { pccfInputID = 3, pccfStartPriority = 6, pccfChanCapacity = 8, pccfPermitToBlock = False, pccfDelayBetweenIterations = 1000000 }
, defaultPCCFiller >>= \ pccf -> return pccf { pccfInputID = 4, pccfStartPriority = 4, pccfChanCapacity = 10, pccfPermitToBlock = True, pccfDelayBetweenIterations = 1000000 }
]
__inputChansSet_lowerBound = 1
__inputChansSet_higherBound = 6
type OutputMode = Int
readerSet :: OutputMode -> IO [PCCReader]
readerSet 1 = sequence [ defaultPCCReader >>= \ pccr -> return pccr { pccrReaderID = 1, pccrPermitToBlock = False, pccrMicrosecondsForDelay = 1000000 } ]
readerSet 2 = sequence [ defaultPCCReader >>= \ pccr -> return pccr { pccrReaderID = 1, pccrPermitToBlock = True, pccrMicrosecondsForDelay = 1000000 } ]
readerSet 3 = sequence [ defaultPCCReader >>= \ pccr -> return pccr { pccrReaderID = 1, pccrPermitToBlock = False, pccrMicrosecondsForDelay = 500000 } ]
readerSet 4 = sequence [ defaultPCCReader >>= \ pccr -> return pccr { pccrReaderID = 1, pccrPermitToBlock = True, pccrMicrosecondsForDelay = 500000 } ]
readerSet 5 = sequence [ defaultPCCReader >>= \ pccr -> return pccr { pccrReaderID = 1, pccrPermitToBlock = False, pccrMicrosecondsForDelay = 1500000 } ]
readerSet 6 = sequence [ defaultPCCReader >>= \ pccr -> return pccr { pccrReaderID = 1, pccrPermitToBlock = True, pccrMicrosecondsForDelay = 1500000 } ]
readerSet 7 = sequence [ defaultPCCReader >>= \ pccr -> return pccr { pccrReaderID = 1, pccrPermitToBlock = False, pccrMicrosecondsForDelay = 500000 }
, defaultPCCReader >>= \ pccr -> return pccr { pccrReaderID = 2, pccrPermitToBlock = True, pccrMicrosecondsForDelay = 500000 }
]
readerSet 8 = sequence [ defaultPCCReader >>= \ pccr -> return pccr { pccrReaderID = 1, pccrPermitToBlock = True, pccrMicrosecondsForDelay = 200000 }
, defaultPCCReader >>= \ pccr -> return pccr { pccrReaderID = 2, pccrPermitToBlock = True, pccrMicrosecondsForDelay = 1500000 }
]
readerSet 9 = sequence [ defaultPCCReader >>= \ pccr -> return pccr { pccrReaderID = 1, pccrPermitToBlock = True, pccrMicrosecondsForDelay = 150000 }
, defaultPCCReader >>= \ pccr -> return pccr { pccrReaderID = 2, pccrPermitToBlock = False, pccrMicrosecondsForDelay = 200000 }
]
__readerConfig_lowerBound = 1
__readerConfig_higherBound = 9
----------------------------------------------------------------------
-- 2.2. Running tests.
----------------------------------------------------------------------
type RunTest = Bool
runTest :: (RunTest, InputMode, OutputMode, SecondsForDelay) -> ConcurrentUISupport -> IO ()
runTest (test_shouldwe, input_mode, output_mode, run_time) cuis =
E.handle
(\ se -> print (se :: E.SomeException))
$ do pccr_list <- readerSet output_mode
pccf_list <- inputChansSet input_mode
case test_shouldwe of
False ->
let str = ""
++ "PCCFillers(" ++ show (length pccf_list) ++ "): \n"
++ (join $ intersperse "\n" $ map show pccf_list)
++ "\n-----------------------------------\n"
++ "PCCReaders(" ++ show (length pccf_list) ++ "): \n"
++ (join $ intersperse "\n" $ map show pccr_list)
in cuisWrite cuis str
True -> do
finisher <- runFillersAndPCCAndReaders pccf_list pccr_list cuis
threadDelay (run_time * 1000000)
finisher
main = do
cuis <- defaultConcurrentUISupportIO_logInFile "PCCTest.log" WriteMode -- provided by the PCC package, Control.Concurrent.SimpleUI
runConcurrentUISupport cuis
cuisWrite cuis ("Welcome to SimplePCCTestEnvironment v0.1!\n ")
_cycle cuis
cuisFinish cuis
where
_cycle :: ConcurrentUISupport -> IO ()
_cycle cuis = do
cuisWrite cuis ("Please input mode (True/False, inputChansSet #{" ++ show __inputChansSet_lowerBound ++ ".." ++ show __inputChansSet_higherBound ++ "}, readerSet #{" ++ show __readerConfig_lowerBound ++ ".." ++ show __readerConfig_higherBound ++ "}, time (in seconds) for how long to run test). ")
cuisWrite cuis ("Or type ':q' for exit.")
cuisWrite cuis ("If first is True, then test is run, otherwise chosen inputChansSet and readerSet are shown.")
cuisWrite cuis ("Second parameter should be index of inputChansSet, third - of readerSet.")
cuisWrite cuis ("Example inputs: (True, 1, 1, 20) or (False,1,2,10), but not (1,2,3,4) nor (True," ++ show (__inputChansSet_lowerBound - 1) ++ "," ++ show (__readerConfig_higherBound + 1) ++ ",-1) nor (True,2,3,4,5)")
cuisWrite cuis ("Input > ")
mode <- cuisReadLn cuis "main thread" -- (True, 5, 9, 20) -- (True, 6, 6, 30)
case mode == ":q" of
True -> return ()
False -> do
err_or_mode <- (E.try $ SF.read mode) :: IO (Either E.SomeException (RunTest, InputMode, OutputMode, SecondsForDelay))
case err_or_mode of
Left se -> cuisWrite cuis (show se) >> cuisNewPage cuis
Right tm@(test_shouldwe, input_mode, output_mode, run_time) ->
let cond_1 = input_mode `betweenI` (__inputChansSet_lowerBound, __inputChansSet_higherBound)
cond_2 = output_mode `betweenI` ( __readerConfig_lowerBound, __readerConfig_higherBound)
cond_3 = run_time > 0
cond = cond_1 && cond_2 && cond_3
in case cond of
False -> return ()
True -> runTest tm cuis >> threadDelay 1000000 >> cuisNewPage cuis
_cycle cuis
----------------------------------------------------------------------
----------------------------------------------------------------------
-- 3. Representations (instances of Show class).
----------------------------------------------------------------------
----------------------------------------------------------------------
instance Show PCCFiller where
show pccf =
"PCCFiller {"
++ "\n ID = " ++ (show $ pccfInputID pccf)
++ "\n StartPriority = " ++ (show $ pccfInputID pccf)
++ "\n ChanCapacity = " ++ (show $ pccfChanCapacity pccf)
++ "\n PermitToBlock = " ++ (show $ pccfPermitToBlock pccf)
++ "\n MicrosecondsForDelay = " ++ (show $ pccfDelayBetweenIterations pccf)
++ "\n PCCFillerState = " ++ (show $ unsafePerformIO $ readMVar $ pccfStateMV pccf)
++ "\n}"
instance Show PCCReader where
show pccr =
"PCCReader {"
++ "\n ID = " ++ (show $ pccrReaderID pccr)
++ "\n MicrosecondsForDelay = " ++ (show $ pccrMicrosecondsForDelay pccr)
++ "\n PermitToBlock = " ++ (show $ pccrPermitToBlock pccr)
++ "}"
----------------------------------------------------------------------
-- Appendix: Some helper functions.
----------------------------------------------------------------------
infixr 1 <<
(<<) :: Monad m => m b -> m a -> m b
f << x = x >> f
betweenI :: Ord a => a -> (a, a) -> Bool
betweenNI :: Ord a => a -> (a, a) -> Bool
betweenI a (l,h) = a >= l && a <= h
betweenNI a (l,h) = a > l && a < h
infixr 1 `countIn`
countIn :: Eq a => a -> [a] -> Int
countIn a list = _count list 0
where
_count [] !i = i
_count (h:t) !i =
case h == a of
True -> _count t (i + 1)
False -> _count t i
modifyTVar_ :: TVar a -> (a -> a) -> STM ()
modifyTVar_ tv f = do
v <- readTVar tv
writeTVar tv (f v)
-- data System.IO.IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
type WhatToDump = String
type FileSuffix = String
dump :: WhatToDump -> FileSuffix -> IOMode -> IO ()
dump a s m = do
h <- openFile ("./dump.out." ++ s ++ ".hs") m
hPutStr h $ show a
hClose h
dump2 :: IO WhatToDump -> FileSuffix -> IOMode -> IO ()
dump2 a s m = do
h <- openFile ("./dump.out." ++ s ++ ".hs") m
a >>= hPutStr h
hClose h
--a >>= putStrLn