diff --git a/Control/Concurrent/CHP/Alt.hs b/Control/Concurrent/CHP/Alt.hs
--- a/Control/Concurrent/CHP/Alt.hs
+++ b/Control/Concurrent/CHP/Alt.hs
@@ -28,9 +28,8 @@
 -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 
--- | A module containing the ALT constructs.  An ALT (a term inherited from
--- occam) is a choice between several alternate events.  In CHP, we say that an event
--- must support alting to be a valid choice.  Events that /do/ support alting are:
+-- | A module containing constructs for choice, or alting.  An ALT (a term inherited from
+-- occam) is a choice between several alternate events.  Events that inherently support choice are:
 --
 -- * 'Control.Concurrent.CHP.Monad.skip'
 --
@@ -38,11 +37,11 @@
 -- 
 -- * 'Control.Concurrent.CHP.Monad.waitFor'
 -- 
--- * Reading from a channel (including extended reads): that is, calls to 'Control.Concurrent.CHP.Channels.readChannel'
--- and 'Control.Concurrent.CHP.Channels.extReadChannel'
+-- * Reading from a channel (including extended reads): that is, calls to 'Control.Concurrent.CHP.Channels.Communication.readChannel'
+-- and 'Control.Concurrent.CHP.Channels.Communication.extReadChannel'
 -- 
--- * Writing to a channel (including extended writes): that is, calls to 'Control.Concurrent.CHP.Channels.writeChannel'
--- and 'Control.Concurrent.CHP.Channels.extWriteChannel'
+-- * Writing to a channel (including extended writes): that is, calls to 'Control.Concurrent.CHP.Channels.Communication.writeChannel'
+-- and 'Control.Concurrent.CHP.Channels.Communication.extWriteChannel'
 -- 
 -- * Synchronising on a barrier (using 'Control.Concurrent.CHP.Barriers.syncBarrier')
 -- 
@@ -55,7 +54,8 @@
 -- * A call to 'every', which joins together several items (see the documentation
 -- on 'every').
 --
--- Examples of events that do /NOT/ support alting are:
+-- There are several other events that can occur in CHP; these are assumed to be
+-- always-ready when they are included in a choice.  Examples include:
 --
 -- * Enrolling and resigning with a barrier
 -- 
@@ -69,60 +69,44 @@
 --
 -- * Claiming a shared channel (yet...)
 --
--- It is not easily possible to represent this at the type level (while still
--- making CHP easy to use).  Therefore it is left to you to not try to alt
--- over something that does not support it.  Given how much of the library
--- does support alting, that should hopefully be straightforward.
+-- * A return statement by itself
 --
 -- Here are some examples of using alting:
 --
 -- * Wait for an integer channel, or 1 second to elapse:
 --
--- > liftM Just (readChannel c) <-> (waitFor 1000000 >> return Nothing)
+-- > liftM Just (readChannel c) <|> (waitFor 1000000 >> return Nothing)
 --
--- * Check if a channel is ready, otherwise return immediately.  Note that you must use the
--- alt operator with priority here, otherwise your skip guard might be chosen,
--- even when the channel is ready.
+-- * Check if a channel is ready, otherwise return immediately; this can be done
+-- using the 'optional' function from "Control.Applicative":
 -- 
--- > liftM Just (readChannel c) </> (skip >> return Nothing)
+-- > optional (readChannel c)
 --
 -- * Wait for input from one of two (identically typed) channels
 -- 
--- > readChannel c0 <-> readChannel c1
+-- > readChannel c0 <|> readChannel c1
 --
 -- * Check if a channel is ready; if so send, it on, otherwise return immediately:
 -- 
--- > (readChannel c >>= writeChannel d) </> skip
+-- > (readChannel c >>= writeChannel d) <|> skip
 --
 -- Note that if you wait for a sequential composition:
 --
--- > (readChannel c >>= writeChannel d) <-> (writeChannel e 6 >> readChannel f)
+-- > (readChannel c >>= writeChannel d) <|> (writeChannel e 6 >> readChannel f)
 --
 -- This only waits for the first action in both (reading from channel c, or writing
 -- to channel e), not for all of the actions (as, for example, an STM transaction
 -- would).
 module Control.Concurrent.CHP.Alt (alt, (<->), priAlt, (</>), every, every_, (<&>)) where
 
-import Control.Applicative
-import Control.Arrow
-import Control.Concurrent
-import Control.Concurrent.STM
-import Control.Monad.Reader
-import Data.List
-import qualified Data.Map as Map
-import Data.Maybe
-import Data.Monoid
-import qualified Data.Set as Set
-import Data.Unique
-import System.IO
+import Control.Applicative ((<$>), (<|>))
+import Data.Monoid (mappend)
 
-import Control.Concurrent.CHP.Base
-import Control.Concurrent.CHP.Event
-import Control.Concurrent.CHP.Guard
-import Control.Concurrent.CHP.Monad
-import Control.Concurrent.CHP.Parallel
-import Control.Concurrent.CHP.Poison
-import Control.Concurrent.CHP.Traces.Base
+import Control.Concurrent.CHP.Base (CHP(..), CHP'(..), liftIO_CHP, makeAltable', priAlt, throwPoison, wrapPoison)
+import Control.Concurrent.CHP.Guard (Guard(..))
+import Control.Concurrent.CHP.Monad (skip)
+import Control.Concurrent.CHP.Parallel (runParallel)
+import Control.Concurrent.CHP.Poison (WithPoison(..))
 
 -- | An alt between several actions, with arbitrary priority.  The first
 -- available action is chosen (with an arbitrary choice if many actions are
@@ -130,51 +114,6 @@
 alt :: [CHP a] -> CHP a
 alt = priAlt
 
--- | An alt between several actions, with descending priority.  The first
--- available action is chosen (biased towards actions nearest the beginning
--- of the list), its body run, and its value returned.
---
--- What priority means here is a difficult thing, and in some ways a historical
--- artifact.  We can group the guards into three categories:
---
--- 1. synchronisation guards (reading from and writing to channels, and synchronising
--- on barriers)
---
--- 2. time-out guards (such as 'Control.Concurrent.CHP.Monad.waitFor')
---
--- 3. dummy guards ('Control.Concurrent.CHP.Monad.skip' and 'Control.Concurrent.CHP.Monad.stop')
---
--- There exists priority when comparing dummy guards to anything else.  So for
--- example,
---
--- > priAlt [ skip, x ]
---
--- Will always select the first guard, whereas:
---
--- > priAlt [ x , skip ]
---
--- Is an effective way to poll and see if x is ready, otherwise the 'Control.Concurrent.CHP.Monad.skip' will
--- be chosen.  However, there is no priority between synchronisation guards and
--- time-out guards.  So the two lines:
---
--- > priAlt [ x, y ]
--- > priAlt [ y, x ]
---
--- May have the same or different behaviour (when x and y are not dummy guards),
--- there is no guarantee either way.  The reason behind this is that if you ask
--- for:
---
--- > priAlt [ readChannel c, writeChannel d 6 ]
---
--- And the process at the other end is asking for:
---
--- > priAlt [ readChannel d, writeChannel c 8 ]
---
--- Whichever channel is chosen by both processes will not satisfy the priority
--- at one end (if such priority between channels was supported).
-priAlt :: [CHP a] -> CHP a
-priAlt = unwrapPoison . priAlt' . map wrapPoison
-
 -- | A useful operator to perform an 'alt'.  This operator is associative,
 -- and has arbitrary priority.  When you have lots of guards, it is probably easier
 -- to use the 'alt' function.  'alt' /may/ be more efficent than
@@ -187,8 +126,11 @@
 -- left-biased).  When you have lots of actions, it is probably easier
 -- to use the 'priAlt' function.  'priAlt' /may/ be more efficent than
 -- foldl1 (\<\/\>)
+--
+-- Since version 2.2.0, this operator is deprecated in favour of the (<|>) operator
+-- from the Alternative type-class.
 (</>) :: CHP a -> CHP a -> CHP a
-(</>) a b = priAlt [a,b]
+(</>) = (<|>)
 
 infixl </>
 infixl <->
@@ -288,36 +230,31 @@
 -- behaviour as x.
 --
 -- Added in version 1.1.0
-every :: forall a. [CHP a] -> CHP [a]
+every :: [CHP a] -> CHP [a]
 every [] = skip >> return []
-every xs = liftPoison (AltableT (liftM ((:[]) . flip (,) (return True)) $ gs >>= foldM1 merge) (return
-   False)) >>= \b -> if b then runParallel (map (unwrapPoison . liftTrace) bodies) else alt [every xs]
+every xs = makeAltable' (\tr -> let gs = map fst $ getAltable tr
+  in [(foldl1 merge gs, return $ NoPoison ())]) >> wrapped
   where
-    both :: Either String [(Guard, TraceT IO (WithPoison a))]
-    both = mapM (checkSingle . pullOutAltable . wrapPoison) xs
-    gs :: Either String [Guard]
-    gs = liftM (map fst) both
-    bodies = map snd $ fromRight both
-    fromRight (Right x) = x
-    fromRight _ = error "Reached unreachable code in every; bodies executed after bad guard"
+    wrapped = PoisonT $ \t f -> let bodies = map snd $ getAltable t
+      in wrapPoison t (runParallel (map wrap bodies)) >>= f
 
-    checkSingle (Left err) = Left err
-    checkSingle (Right []) = Left "Bad guard in every"
-    checkSingle (Right [x]) = Right x
-    checkSingle (Right _) = Left "Alt inside every"
+    wrap m = liftIO_CHP m >>= \v -> case v of
+      PoisonItem -> throwPoison
+      NoPoison x -> return x
 
-    merge :: Guard -> Guard -> Either String Guard
-    merge SkipGuard g = return g
-    merge g SkipGuard = return g
-    merge StopGuard _ = return StopGuard
-    merge _ StopGuard = return StopGuard
+    getAltable tr = flip map xs $ \x -> case runPoisonT x tr return of
+      Altable _ [ga] -> ga
+      _ -> error "Bad item in every"
+
+    merge :: Guard -> Guard -> Guard
+    merge SkipGuard g = g
+    merge g SkipGuard = g
+    merge StopGuard _ = StopGuard
+    merge _ StopGuard = StopGuard
     merge (EventGuard recx actx esx) (EventGuard recy acty esy)
-      = return $ EventGuard (\n -> recx n ++ recy n) (actx `mappend` acty) (esx ++ esy)
-    merge _ _ = badGuard "merging unsupported guards"
+      = EventGuard (\n -> recx n ++ recy n) (actx `mappend` acty) (esx ++ esy)
+    merge _ _ = error "every: merging unsupported guards"
 
-    foldM1 :: Monad m => (b -> b -> m b) -> [b] -> m b
-    foldM1 f (y:ys) = foldM f y ys
-    foldM1 _ _ = error "Reached unreachable code in every; guards empty in non-empty case"
 
 -- | Like 'every' but discards the results.
 --
@@ -330,7 +267,7 @@
 -- to join with this operator, it's probably easier to use the 'every' function.
 --
 -- Added in version 1.1.0
-(<&>) :: forall a b. CHP a -> CHP b -> CHP (a, b)
+(<&>) :: CHP a -> CHP b -> CHP (a, b)
 (<&>) a b = merge <$> every [Left <$> a, Right <$> b]
   where
     merge :: [Either a b] -> (a, b)
@@ -338,138 +275,4 @@
     merge [Right y, Left x] = (x, y)
     merge _ = error "Invalid merge possibility in <&>"
 
--- ALTing is implemented as follows in CHP.  The CHP monad has [Int] in its
--- state.  When you choose between N events, you form one body, that pulls
--- the next number from the head of the state and executes the body for the
--- event corresponding to that index.  Nested ALTs prepend to the list.
--- So for example, if you choose between:
---
--- > (a <-> b) <-> c
---
--- The overall number corresponding to a is [0,0], b is [0,1], c is [1].  The
--- outer choice peels off the head of the list.  On 1 it executes c; on 0 it
--- descends to the nested choice, which takes the next number in the list and
--- executes a or b given 0 or 1 respectively.
---
--- If an event is poisoned, an integer (of arbitrary value) is /appended/ to
--- the list.  Thus when an event-based guard is executed, if the list in the
--- state is non-empty, it knows it has been poisoned.
---
--- I did try implementing this in a more functional manner, making each event
--- in the monad take [Int] and return the body, rather than using state.  However,
--- I had some memory efficiency problems so I went with the state-monad-based
--- approach instead.
 
-priAlt' :: forall a. [CHP' (WithPoison a)] -> CHP' (WithPoison a)
-priAlt' items
-  -- Our guard is a nested guard of all our sub-guards.
-  -- Our action-if-not-guard is to do the selection ourselves.
-  = AltableT flattenedGuards (selectFromGuards flattenedGuards)
-  where
-    -- The list of guards without any NestedGuards or StopGuards:
-    flattenedGuards :: Either String [(Guard, TraceT IO (WithPoison a))]
-    flattenedGuards = liftM (filter (not . isStopGuard . fst)) altStuff
-      where
-        altStuff :: Either String [(Guard, TraceT IO (WithPoison a))]
-        altStuff = liftM concat $ mapM pullOutAltable items
-
--- Performs the select operation on all the guards, and then executes the body
-selectFromGuards :: forall a. (Either String [(Guard, TraceT IO (WithPoison a))]) -> TraceT IO (WithPoison a)
-selectFromGuards (Left str) =
-           let err = "ALTing not supported on given guard: " ++ str
-           in liftIO $ do hPutStrLn stderr err
-                          ioError $ userError err
-selectFromGuards (Right both)
-        | null (eventGuards $ map fst both) =
-           join $ liftM snd $ liftIO $ waitNormalGuards both Nothing
-        | otherwise =
-           do let (guards, _bodies) = unzip both
-                  earliestReady = findIndex isSkipGuard guards
-                  recordAndRun :: WithPoison ([RecordedIndivEvent Unique], TraceT
-                    IO (WithPoison a)) -> TraceT IO (WithPoison a)
-                  recordAndRun PoisonItem = return PoisonItem
-                  recordAndRun (NoPoison (r, m)) = recordEvent r >> m
-                  guardsAndRec :: [(Guard, WithPoison ([RecordedIndivEvent Unique], TraceT IO (WithPoison a)))]
-                  guardsAndRec = map (second (NoPoison . (,) [])) both
-                  getRec :: (SignalValue, Map.Map Unique (Integer, RecordedEventType))
-                         -> WithPoison ([RecordedIndivEvent Unique], TraceT IO (WithPoison a))
-                  getRec (Signal PoisonItem, _) = PoisonItem
-                  getRec (Signal (NoPoison n), m)
-                    = case both !! n of
-                        (EventGuard recF _ _, body) ->
-                          NoPoison (recF (makeLookup m), body)
-                        (_, body) -> NoPoison ([], body)
-              tv <- liftIO $ newTVarIO Nothing
-              pid <- getProcessId
-              tr <- ask
-              tid <- liftIO myThreadId
-              mn <- liftIO . atomically $ do
-                      ret <- enableEvents tv (tid, pid)
-                        (maybe id take earliestReady $ eventGuards guards)
-                        (isNothing earliestReady)
-                      either (const $ return ())
-                            (\((sigVal,_),es) -> do
-                               recordEventLast (nub es) tr
-                               case sigVal of
-                                 Signal PoisonItem -> return ()
-                                 Signal (NoPoison n) ->
-                                   let EventGuard _ act _ = guards !! n
-                                   in actWhenLast act (Map.fromList $ map (snd *** Set.size) es)
-                            )
-                            ret
-                      return $ either Left (Right . getRec . fst) ret
-              case (mn, earliestReady) of
-                -- An event -- and we were the last person to arrive:
-                -- The event must have been higher priority than any other
-                -- ready guards
-                (Right r, _) -> recordAndRun r
-                -- No events were ready, but there was an available normal
-                -- guards.  Re-run the normal guards; at least one will be ready
-                (Left _, Just _) ->
-                  join $ liftM snd $ liftIO $ waitNormalGuards both Nothing
-                -- No events ready, no other guards ready either
-                -- Events will have been enabled; wait for everything:
-                (Left disable, Nothing) ->
-                    do (wasAltingBarrier, pr) <- liftIO $ waitNormalGuards
-                         guardsAndRec $ Just $ liftM getRec $ waitAlting tv
-                       if wasAltingBarrier
-                         then recordAndRun pr -- It was a barrier, all done
-                         else
-                            -- Another guard fired, but we must check in case
-                            -- we have meanwhile been committed to taking an
-                            -- event:
-                            do mn' <- liftIO . atomically $ disable
-                               case mn' of
-                                 -- An event overrides our non-event choice:
-                                 Just pr' -> recordAndRun $ getRec pr'
-                                 -- Go with the original option, no events
-                                 -- became ready:
-                                 Nothing -> recordAndRun pr
-
-waitAlting :: SignalVar -> STM (SignalValue, Map.Map Unique (Integer, RecordedEventType))
-waitAlting tv = do b <- readTVar tv
-                   case b of
-                     Nothing -> retry
-                     Just ns -> return ns
-
-makeLookup :: Map.Map Unique (Integer, RecordedEventType) -> Unique -> (Integer,
-  RecordedEventType)
-makeLookup m u = fromMaybe (error "CHP: Unique not found in alt") $ Map.lookup u m
-
--- The alting barrier guards:
-eventGuards :: [Guard] -> [((SignalValue, STM ()), [Event])]
-eventGuards guards = [((Signal $ NoPoison n, actAlways acts), ab)
-                     | (n, EventGuard _ acts ab) <- zip [0..] guards]
-
-
--- Waits for one of the normal (non-alting barrier) guards to be ready,
--- or the given transaction to complete
-waitNormalGuards :: [(Guard, b)] -> Maybe (STM b) -> IO (Bool, b)
-waitNormalGuards guards extra
-  = do enabled <- sequence $ mapMaybe enable guards
-       atomically $ foldr orElse retry $ maybe id ((:) . liftM ((,) True)) extra $ enabled
-  where
-    enable :: (Guard, b) -> Maybe (IO (STM (Bool, b)))
-    enable (SkipGuard, x) = Just $ return $ return (False, x)
-    enable (TimeoutGuard g, x) = Just $ liftM (>> return (False, x)) g
-    enable _ = Nothing -- This effectively ignores other guards
diff --git a/Control/Concurrent/CHP/Barriers.hs b/Control/Concurrent/CHP/Barriers.hs
--- a/Control/Concurrent/CHP/Barriers.hs
+++ b/Control/Concurrent/CHP/Barriers.hs
@@ -69,7 +69,7 @@
     syncBarrier, getBarrierIdentifier) where
 
 import Control.Concurrent.STM
-import Control.Monad.State
+import Control.Monad (liftM, unless, when)
 import Data.Unique
 
 import Control.Concurrent.CHP.Base
@@ -93,7 +93,7 @@
     
 -- | Finds out the current phase a barrier is on.
 currentPhase :: Enrolled PhasedBarrier phase -> CHP phase
-currentPhase (Enrolled (Barrier (_, tv, _))) = liftIO $ atomically $ readTVar tv
+currentPhase (Enrolled (Barrier (_, tv, _))) = liftSTM $ readTVar tv
 
 repeatUntil :: (Monad m) => (a -> Bool) -> m a -> m ()
 repeatUntil target comp = do x <- comp
@@ -172,10 +172,10 @@
 
 -- | Like 'newPhasedBarrier' but allows you to customise the options.
 newPhasedBarrier' :: phase -> BarOpts phase -> CHP (PhasedBarrier phase)
-newPhasedBarrier' ph (BarOpts incPh pri showPh label) = liftPoison $ liftTrace $ do
-  tv <- liftIO $ atomically $ newTVar ph
-  e <- liftIO $ newBarrierEvent showPh pri tv
-  maybe (return ()) (labelEvent e) label
+newPhasedBarrier' ph (BarOpts incPh pri showPh label) = getTrace >>= \tr -> liftIO_CHP $ do
+  tv <- atomically $ newTVar ph
+  e <- newBarrierEvent showPh pri tv
+  maybe (return ()) (labelEvent tr e) label
   return $ Barrier (e, tv, incPh)
 
 -- | Creates a new barrier with no processes enrolled and labels it in traces
diff --git a/Control/Concurrent/CHP/Base.hs b/Control/Concurrent/CHP/Base.hs
--- a/Control/Concurrent/CHP/Base.hs
+++ b/Control/Concurrent/CHP/Base.hs
@@ -35,19 +35,20 @@
 
 import Control.Applicative
 import Control.Arrow
+import Control.Concurrent (myThreadId, threadDelay)
 import Control.Concurrent.STM
 import qualified Control.Exception.Extensible as C
-import Control.Monad.Error
-import Control.Monad.LoopWhile
-import Control.Monad.Reader
-import Control.Monad.State
-import Control.Monad.Writer
+import Control.Monad
 import Data.Function (on)
+import Data.List (findIndex, nub)
 import qualified Data.Map as Map
+import Data.Maybe (fromMaybe, isNothing, mapMaybe)
+import qualified Data.Set as Set
 import Data.Unique
 import System.IO
 import qualified Text.PrettyPrint.HughesPJ
 
+import Control.Concurrent.CHP.Event
 import Control.Concurrent.CHP.Guard
 import Control.Concurrent.CHP.Poison
 import Control.Concurrent.CHP.ProcessId
@@ -57,9 +58,6 @@
 -- Types:
 -- ======
 
--- | An internal dummy type for poison errors
-newtype PoisonError = PoisonError ()
-
 -- | An enrolled wrapper for barriers that shows at the type-level whether
 -- you are enrolled on a barrier.  Enrolled Barriers should never be passed
 -- to two (or more) processes running in parallel; if two processes synchronise
@@ -70,18 +68,43 @@
 -- 'Control.Concurrent.CHP.Monad.runCHP' and
 -- 'Control.Concurrent.CHP.Monad.runCHP_' to execute programs in this
 -- monad.
-newtype CHP a = PoisonT (ErrorT PoisonError CHP' a)
-  deriving (Functor, Monad, MonadIO)
+--
+-- The Alternative instance was added in version 2.2.0.
+newtype CHP a = PoisonT {runPoisonT :: forall b. TraceStore -> (a -> CHP' b) -> CHP' b}
+--  deriving (Functor, Monad, MonadIO)
 
+instance Functor CHP where
+  fmap f m = PoisonT $ \t c -> runPoisonT m t (c . f)
+
+instance Monad CHP where
+  return a = PoisonT $ const ($ a)
+  m >>= k  = PoisonT $ \t c -> runPoisonT m t (\a -> runPoisonT (k a) t c)
+            
 instance Applicative CHP where
   pure = return
   (<*>) = ap
 
-data CHP' a = AltableTRet a | AltableT {
+instance Alternative CHP where
+  empty = stop
+  a <|> b = priAlt [a, b]
+  -- Like the default definition but makes clear
+  -- which the leading action is:
+--  some p = do x <- p
+--              xs <- many p
+--              return (x : xs)
+
+-- | An implementation of liftIO for the CHP monad; this function lifts IO actions
+-- into the CHP monad.
+--
+-- Added in version 2.2.0.
+liftIO_CHP :: IO a -> CHP a
+liftIO_CHP m = PoisonT $ const $ \f -> (Standard (liftM NoPoison m) >>= f)
+
+data CHP' a = Return a 
   -- The guard, and body to execute after the guard
-  getAltable :: Either String [(Guard, TraceT IO a)],
+  | Altable TraceStore [(Guard, IO (WithPoison a))]
   -- The body to execute without a guard
-  getStandard :: TraceT IO a }
+  | Standard (IO (WithPoison a))
 
 -- ========
 -- Classes:
@@ -90,7 +113,7 @@
 -- | A monad transformer class that is very similar to 'MonadIO'.  This can be
 -- useful if you want to add monad transformers (such as 'StateT', 'ReaderT') on
 -- top of the 'CHP' monad.
-class MonadIO m => MonadCHP m where
+class Monad m => MonadCHP m where
   liftCHP :: CHP a -> m a
 
 -- | A class representing a type of trace.  The main useful function is 'runCHPAndTrace',
@@ -127,32 +150,31 @@
 -- Functions: 
 -- ==========
 
-pullOutStandard :: CHP' a -> TraceT IO a
-pullOutStandard m = case m of
-  AltableTRet x -> return x
-  AltableT _ st -> st
+makeAltable :: [(Guard, IO (WithPoison a))] -> CHP a
+makeAltable gas = PoisonT $ \t f -> Altable t (map (second (&>>= pullOutStandard . f)) gas)
 
-pullOutAltable :: CHP' a -> Either String [(Guard, TraceT IO a)]
-pullOutAltable m = case m of
-  AltableTRet _ -> badGuard "return"
-  AltableT alt _ -> alt
+makeAltable' :: (TraceStore -> [(Guard, IO (WithPoison a))]) -> CHP a
+makeAltable' gas = PoisonT $ \t f -> Altable t (map (second (&>>= pullOutStandard . f)) (gas t))
 
-liftTrace :: TraceT IO a -> CHP' a
-liftTrace = AltableT (badGuard "lifted action")
+pullOutStandard :: CHP' a -> IO (WithPoison a)
+pullOutStandard (Return x) = return (NoPoison x)
+pullOutStandard (Altable tr gas) = selectFromGuards tr gas
+pullOutStandard (Standard m) = m
 
-wrapPoison :: CHP a -> CHP' (WithPoison a)
-wrapPoison (PoisonT m) = either (const PoisonItem) NoPoison <$> runErrorT m
+wrapPoison :: TraceStore -> CHP a -> CHP' a
+wrapPoison t (PoisonT m) = m t return
 
-unwrapPoison :: CHP' (WithPoison a) -> CHP a
-unwrapPoison m = PoisonT (lift m) >>= checkPoison
+--unwrapPoison :: (TraceStore -> CHP' a) -> CHP a
+--unwrapPoison m = PoisonT $ \t f -> m t >>= f
 
+  
 -- | Checks for poison, and either returns the value, or throws a poison exception
 checkPoison :: WithPoison a -> CHP a
 checkPoison (NoPoison x) = return x
-checkPoison PoisonItem = PoisonT $ throwError $ PoisonError ()
+checkPoison PoisonItem = PoisonT $ \_ _ -> Standard $ return PoisonItem
 
-liftPoison :: CHP' a -> CHP a
-liftPoison = PoisonT . lift
+liftPoison :: (TraceStore -> CHP' a) -> CHP a
+liftPoison m = PoisonT ((>>=) . m)
 
 -- | Throws a poison exception.
 throwPoison :: CHP a
@@ -167,8 +189,16 @@
 -- does so).  If you want to rethrow (and actually, you'll find you usually
 -- do), use 'onPoisonRethrow'
 onPoisonTrap :: CHP a -> CHP a -> CHP a
-onPoisonTrap (PoisonT body) (PoisonT handler) = PoisonT $ body `catchError` (const handler)
+onPoisonTrap (PoisonT body) (PoisonT handler)
+  = PoisonT $ \t f ->
+     let trap PoisonItem = pullOutStandard $ handler t f
+         trap (NoPoison x) = pullOutStandard $ f x in
+    case body t return of
+      Return x -> f x
+      Altable tr gas -> Altable tr (map (second (>>= trap)) gas)
+      Standard m -> Standard $ m >>= trap
 
+
 -- | Like 'onPoisonTrap', this function allows you to provide a handler
 --  for poison.  The difference with this function is that even if the
 --  poison handler does not throw, the poison exception will always be
@@ -179,35 +209,36 @@
 -- > foo `onPoisonRethrow` throwPoison
 -- > foo `onPoisonRethrow` return ()
 onPoisonRethrow :: CHP a -> CHP () -> CHP a
-onPoisonRethrow (PoisonT body) (PoisonT handler) = PoisonT $
-  body `catchError` (\err -> handler >> throwError err)
+onPoisonRethrow (PoisonT body) (PoisonT handler)
+  = PoisonT $ \t f ->
+     let handle PoisonItem = PoisonItem <$ (pullOutStandard $ handler t return)
+         handle (NoPoison x) = pullOutStandard $ f x in
+    case body t return of
+      Return x -> f x
+      Altable tr gas -> Altable tr (map (second (>>= handle)) gas)
+      Standard m -> Standard $ m >>= handle
 
 -- | Poisons all the given items.  A handy shortcut for @mapM_ poison@.
 poisonAll :: (Poisonable c, MonadCHP m) => [c] -> m ()
 poisonAll = mapM_ poison
 
+getTrace :: CHP TraceStore
+getTrace = PoisonT (flip ($))
 
-liftSTM :: MonadIO m => STM a -> m a
-liftSTM = liftIO . atomically
+liftSTM :: STM a -> CHP a
+liftSTM = liftIO_CHP . atomically
 
-getProcessId :: TraceT IO ProcessId
-getProcessId = do x <- ask
-                  case x of
-                    Trace (pid,_,_) -> return pid
-                    NoTrace pid -> return pid
+getProcessId :: TraceStore -> ProcessId
+getProcessId (Trace (pid,_,_)) = pid
+getProcessId (NoTrace pid) = pid
 
-wrapProcess :: CHP a -> (CHP' (Either PoisonError a) -> IO (Either PoisonError a)) -> IO (Maybe (Either () a))
-wrapProcess (PoisonT proc) unwrapInner
-  = do let inner = runErrorT proc
-       x <- liftM Just (unwrapInner inner) `C.catches` allHandlers
-       case x of
-         Nothing -> return Nothing
-         Just (Left _) -> return $ Just $ Left ()
-         Just (Right y) -> return $ Just $ Right y
+wrapProcess :: CHP a -> TraceStore -> (CHP' a -> IO (WithPoison a)) -> IO (Maybe (WithPoison a))
+wrapProcess (PoisonT proc) t unwrapInner
+  = (Just <$> unwrapInner (proc t return)) `C.catches` allHandlers
   where
     response :: C.Exception e => e -> IO (Maybe a)
-    response x = liftIO (hPutStrLn stderr $ "(CHP) Thread terminated with: " ++ show x)
-                   >> return Nothing
+    response x = do hPutStrLn stderr $ "(CHP) Thread terminated with: " ++ show x
+                    return Nothing
 
     allHandlers = [C.Handler (response :: C.IOException -> IO (Maybe a))
                   ,C.Handler (response :: C.AsyncException -> IO (Maybe a))
@@ -222,15 +253,11 @@
 
 runCHPProgramWith :: TraceStore -> CHP a -> IO (Maybe a)
 runCHPProgramWith start p
-  = do r <- wrapProcess p run
+  = do r <- wrapProcess p start pullOutStandard
        case r of
-         Nothing -> return Nothing
-         Just (Left _) -> return Nothing
-         Just (Right x) -> return (Just x)
-  where
-    run :: CHP' (Either PoisonError a) -> IO (Either PoisonError a)
-    run = flip runReaderT start . pullOutStandard
-    --run m = runStateT ({-liftM (either (const Nothing) Just) $ -} pullOutStandard m) start
+         Nothing -> putStrLn "Deadlock" >> return Nothing
+         Just PoisonItem -> putStrLn "Uncaught Poison" >> return Nothing
+         Just (NoPoison x) -> return (Just x)
 
 runCHPProgramWith' :: SubTraceStore -> (ChannelLabels Unique -> IO t) -> CHP a -> IO (Maybe a, t)
 runCHPProgramWith' subStart f p
@@ -283,41 +310,207 @@
 -- Instances: 
 -- ==========
 
-instance Error PoisonError where
-  noMsg = PoisonError ()
-
-instance (Error e, MonadCHP m) => MonadCHP (ErrorT e m) where
-  liftCHP = lift . liftCHP
-
-instance MonadCHP m => MonadCHP (ReaderT r m) where
-  liftCHP = lift . liftCHP
-
-instance MonadCHP m => MonadCHP (StateT s m) where
-  liftCHP = lift . liftCHP
-
-instance (Monoid w, MonadCHP m) => MonadCHP (WriterT w m) where
-  liftCHP = lift . liftCHP
-
 instance MonadCHP CHP where
   liftCHP = id
 
-instance MonadCHP m => MonadCHP (LoopWhileT m) where
-  liftCHP = lift . liftCHP
-
 -- The monad is lazy, and very similar to the writer monad
 instance Monad CHP' where
   -- m :: AltableT g m a
   -- f :: a -> AltableT g m b
   m >>= f = case m of
-             AltableTRet x -> f x
-             AltableT altBody nonAlt ->
-              let altBody' = liftM (map $ second (>>= pullOutStandard . f)) altBody
-                  nonAlt' = nonAlt >>= pullOutStandard . f
-              in AltableT altBody' nonAlt'
-  return = AltableTRet
+             Return x -> f x
+             Altable tr altBody -> Altable tr $ map (second (&>>= pullOutStandard . f)) altBody
+             Standard s -> Standard $ s &>>= pullOutStandard . f
+  return = Return
 
 instance Functor CHP' where
   fmap = liftM
 
-instance MonadIO CHP' where
-  liftIO = liftTrace . liftIO
+infixr 8 &>>=
+(&>>=) :: IO (WithPoison a) -> (a -> IO (WithPoison b)) -> IO (WithPoison b)
+(&>>=) m f = do v <- m
+                case v of
+                  PoisonItem -> return PoisonItem
+                  NoPoison x -> f x
+
+
+-- ====
+-- Alt:
+-- ====
+
+-- Performs the select operation on all the guards, and then executes the body
+selectFromGuards :: forall a. TraceStore -> [(Guard, IO (WithPoison a))] -> IO (WithPoison a)
+selectFromGuards tr items
+  | null (eventGuards guards)
+     = join $ liftM snd $ waitNormalGuards items Nothing
+  | otherwise = do
+      tv <- newTVarIO Nothing
+      tid <- myThreadId
+      mn <- atomically $ do
+              ret <- enableEvents tv (tid, pid)
+                (maybe id take earliestReady $ eventGuards guards)
+                (isNothing earliestReady)
+              either (const $ return ()) whenLast ret
+              return $ either Left (Right . getRec . fst) ret
+      case (mn, earliestReady) of
+        -- An event -- and we were the last person to arrive:
+        -- The event must have been higher priority than any other
+        -- ready guards
+        (Right r, _) -> recordAndRun r
+        -- No events were ready, but there was an available normal
+        -- guards.  Re-run the normal guards; at least one will be ready
+        (Left _, Just _) ->
+          join $ liftM snd $ waitNormalGuards items Nothing
+        -- No events ready, no other guards ready either
+        -- Events will have been enabled; wait for everything:
+        (Left disable, Nothing) ->
+            do (wasAltingBarrier, pr) <- waitNormalGuards
+                 guardsAndRec $ Just $ liftM getRec $ waitAlting tv
+               if wasAltingBarrier
+                 then recordAndRun pr -- It was a barrier, all done
+                 else
+                    -- Another guard fired, but we must check in case
+                    -- we have meanwhile been committed to taking an
+                    -- event:
+                    do mn' <- atomically $ disable
+                       case mn' of
+                         -- An event overrides our non-event choice:
+                         Just pr' -> recordAndRun $ getRec pr'
+                         -- Go with the original option, no events
+                         -- became ready:
+                         Nothing -> recordAndRun pr
+  where
+    guards = map fst items
+    earliestReady = findIndex isSkipGuard guards
+
+    recordAndRun :: WithPoison ([RecordedIndivEvent Unique], IO (WithPoison a)) -> IO (WithPoison a)
+    recordAndRun PoisonItem = return PoisonItem
+    recordAndRun (NoPoison (r, m)) = recordEvent r tr >> m
+
+    guardsAndRec :: [(Guard, WithPoison ([RecordedIndivEvent Unique], IO (WithPoison a)))]
+    guardsAndRec = map (second (NoPoison . (,) [])) items
+
+    getRec :: (SignalValue, Map.Map Unique (Integer, RecordedEventType))
+           -> WithPoison ([RecordedIndivEvent Unique], IO (WithPoison a))
+    getRec (Signal PoisonItem, _) = PoisonItem
+    getRec (Signal (NoPoison n), m)
+      = case items !! n of
+          (EventGuard recF _ _, body) ->
+            NoPoison (recF (makeLookup m), body)
+          (_, body) -> NoPoison ([], body)
+
+    whenLast ((sigVal,_),es)
+      = do recordEventLast (nub es) tr
+           case sigVal of
+             Signal PoisonItem -> return ()
+             Signal (NoPoison n) ->
+               let EventGuard _ act _ = guards !! n
+               in actWhenLast act (Map.fromList $ map (snd *** Set.size) es)
+
+    pid = getProcessId tr
+
+waitAlting :: SignalVar -> STM (SignalValue, Map.Map Unique (Integer, RecordedEventType))
+waitAlting tv = do b <- readTVar tv
+                   case b of
+                     Nothing -> retry
+                     Just ns -> return ns
+
+makeLookup :: Map.Map Unique (Integer, RecordedEventType) -> Unique -> (Integer,
+  RecordedEventType)
+makeLookup m u = fromMaybe (error "CHP: Unique not found in alt") $ Map.lookup u m
+
+-- The alting barrier guards:
+eventGuards :: [Guard] -> [((SignalValue, STM ()), [Event])]
+eventGuards guards = [((Signal $ NoPoison n, actAlways acts), ab)
+                     | (n, EventGuard _ acts ab) <- zip [0..] guards]
+
+
+-- Waits for one of the normal (non-alting barrier) guards to be ready,
+-- or the given transaction to complete
+waitNormalGuards :: [(Guard, b)] -> Maybe (STM b) -> IO (Bool, b)
+waitNormalGuards guards extra
+  = do enabled <- sequence $ mapMaybe enable guards
+       atomically $ foldr orElse retry $ maybe id ((:) . liftM ((,) True)) extra $ enabled
+  where
+    enable :: (Guard, b) -> Maybe (IO (STM (Bool, b)))
+    enable (SkipGuard, x) = Just $ return $ return (False, x)
+    enable (TimeoutGuard g, x) = Just $ liftM (>> return (False, x)) g
+    enable _ = Nothing -- This effectively ignores other guards
+
+
+
+
+-- | An alt between several actions, with descending priority.  The first
+-- available action is chosen (biased towards actions nearest the beginning
+-- of the list), its body run, and its value returned.
+--
+-- What priority means here is a difficult thing, and in some ways a historical
+-- artifact.  We can group the guards into three categories:
+--
+-- 1. synchronisation guards (reading from and writing to channels, and synchronising
+-- on barriers)
+--
+-- 2. time-out guards (such as 'Control.Concurrent.CHP.Monad.waitFor')
+--
+-- 3. dummy guards ('Control.Concurrent.CHP.Monad.skip', 'Control.Concurrent.CHP.Monad.stop'
+-- and things like IO actions)
+--
+-- There exists priority when comparing dummy guards to anything else.  So for
+-- example,
+--
+-- > priAlt [ skip, x ]
+--
+-- Will always select the first guard (the skip guard), whereas:
+--
+-- > priAlt [ x , skip ]
+--
+-- Is an effective way to poll and see if x is ready, otherwise the 'Control.Concurrent.CHP.Monad.skip' will
+-- be chosen.  However, there is no priority between synchronisation guards and
+-- time-out guards.  So the two lines:
+--
+-- > priAlt [ x, y ]
+-- > priAlt [ y, x ]
+--
+-- May have the same or different behaviour (when x and y are not dummy guards),
+-- there is no guarantee either way.  The reason behind this is that if you ask
+-- for:
+--
+-- > priAlt [ readChannel c, writeChannel d 6 ]
+--
+-- And the process at the other end is asking for:
+--
+-- > priAlt [ readChannel d, writeChannel c 8 ]
+--
+-- Whichever channel is chosen by both processes will not satisfy the priority
+-- at one end (if such priority between channels was supported).  If you do want
+-- priority that is globally consistent, look at the channel and barrier creation
+-- methods for ways to set priority on events.
+priAlt :: [CHP a] -> CHP a
+priAlt xs = PoisonT $ \t f -> priAlt' t (map (wrapPoison t) xs) >>= f
+
+priAlt' :: TraceStore -> [CHP' a] -> CHP' a
+priAlt' tr = Altable tr . filter (not . isStopGuard . fst) . concatMap getAltable
+  where
+    getAltable :: CHP' a -> [(Guard, IO (WithPoison a))]
+    getAltable (Return x) = [(SkipGuard, return $ NoPoison x)]
+    getAltable (Altable _ gs) = gs
+    getAltable (Standard m) = [(SkipGuard, m)]
+
+
+-- | The stop guard.  Its main use is that it is never ready in a choice, so
+-- can be used to mask out guards.  If you actually execute 'stop', that process
+-- will do nothing more.  Any parent process waiting for it to complete will
+-- wait forever.
+--
+-- The type of this function was generalised in CHP 1.6.0.
+stop :: CHP a
+stop = makeAltable [(stopGuard, hang)]
+  where
+    -- Strangely, I can't work out a good way to actually implement stop.
+    -- If you wait on a variable that will never be ready, GHC will wake
+    -- you up with an exception.  If you loop doing that, you'll burn the
+    -- CPU.  Throwing an exception would be caught and terminate the
+    -- process, which is not the desired behaviour.  The only thing I can think
+    -- to do is to repeatedly wait for a very long time.
+    hang :: IO a
+    hang = forever $ threadDelay maxBound
diff --git a/Control/Concurrent/CHP/CSP.hs b/Control/Concurrent/CHP/CSP.hs
--- a/Control/Concurrent/CHP/CSP.hs
+++ b/Control/Concurrent/CHP/CSP.hs
@@ -32,38 +32,36 @@
 -- TODO rename this module.
 module Control.Concurrent.CHP.CSP where
 
+import Control.Applicative
 import Control.Concurrent.STM
 import Control.Exception
-import Control.Monad.Reader
+import Control.Monad (when)
 import Data.List
 import qualified Data.Map as Map
 import Data.Unique
 
-import Control.Concurrent.CHP.Alt
 import Control.Concurrent.CHP.Base
 import qualified Control.Concurrent.CHP.Event as Event
 import Control.Concurrent.CHP.Enroll
 import Control.Concurrent.CHP.Guard
+import Control.Concurrent.CHP.Poison
 import Control.Concurrent.CHP.Traces.Base
 
 -- First engages in event, then executes the body.  The returned value is suitable
 -- for use in an alt
-buildOnEventPoison :: (Unique -> (Unique -> (Integer, Event.RecordedEventType)) -> [RecordedIndivEvent Unique]) -> Event.Event -> EventActions -> CHP a -> CHP a
+buildOnEventPoison :: (Unique -> (Unique -> (Integer, Event.RecordedEventType)) -> [RecordedIndivEvent Unique]) -> Event.Event -> EventActions -> IO (WithPoison a) -> CHP a
 buildOnEventPoison recE e act body
-  = liftPoison (AltableT (Right [(theGuard, return True)])
-                   (return False))
-    >>= \b -> if b then body else
-      alt [liftPoison $ AltableT (Right [(theGuard, return ())]) (return ())] >> body
-    where
-      theGuard = EventGuard (recE (Event.getEventUnique e)) act [e]
+  = makeAltable [(theGuard, body)]
+  where
+    theGuard = EventGuard (recE (Event.getEventUnique e)) act [e]
 
 scopeBlock :: CHP a -> (a -> CHP b) -> IO () -> CHP b
 scopeBlock start body errorEnd
     = do x <- start
-         tr <- liftPoison $ liftTrace ask
-         y <- liftIO $ bracketOnError (return ()) (const errorEnd) $ const
-           $ runReaderT (pullOutStandard (wrapPoison $ body x)) tr
-         checkPoison y `onPoisonRethrow` (liftIO errorEnd)
+         tr <- getTrace
+         y <- liftIO_CHP $ bracketOnError (return ()) (const errorEnd) $ const
+           $ pullOutStandard (wrapPoison tr $ body x)
+         checkPoison y `onPoisonRethrow` (liftIO_CHP errorEnd)
 
 wrapIndiv :: (Unique -> (Unique -> Integer) -> String -> [RecordedIndivEvent Unique])
           -> Unique -> (Unique -> (Integer, Event.RecordedEventType))
@@ -76,7 +74,7 @@
   -> (Int -> STM ()) -> Enrolled PhasedBarrier phase -> CHP phase
 syncBarrierWith recE storeN (Enrolled (Barrier (e,tv, fph)))
     = buildOnEventPoison (wrapIndiv recE) e (EventActions incPhase (return ()))
-        (liftIO $ atomically $ readTVar tv)
+        (NoPoison <$> (atomically $ readTVar tv))
     where
       incPhase :: Map.Map Unique Int -> STM ()
       incPhase m = do readTVar tv >>= writeTVar tv . fph
@@ -112,13 +110,13 @@
     = do liftSTM (Event.enrollEvent e) >>= checkPoison
          x <- f $ Enrolled b
          liftSTM (Event.resignEvent e) >>= checkPoison >>= (\es ->
-           do tr <- liftPoison $ liftTrace ask
+           do tr <- getTrace
               when (not $ null es) $ liftSTM $ recordEventLast (nub es) tr)
          return x
 
   resign (Enrolled (Barrier (e, _, _))) m
     = do liftSTM (Event.resignEvent e) >>= checkPoison >>= (\es ->
-           do tr <- liftPoison $ liftTrace ask
+           do tr <- getTrace
               when (not $ null es) $ liftSTM $ recordEventLast (nub es) tr)
          x <- m
          liftSTM (Event.enrollEvent e) >>= checkPoison
@@ -126,7 +124,7 @@
 
 instance Poisonable (Enrolled PhasedBarrier phase) where
   poison (Enrolled (Barrier (e, _, _)))
-    = liftSTM $ Event.poisonEvent e
+    = liftCHP . liftSTM $ Event.poisonEvent e
   checkForPoison (Enrolled (Barrier (e, _, _)))
     = liftCHP $ liftSTM (Event.checkEventForPoison e) >>= checkPoison
 
diff --git a/Control/Concurrent/CHP/Channels/Base.hs b/Control/Concurrent/CHP/Channels/Base.hs
--- a/Control/Concurrent/CHP/Channels/Base.hs
+++ b/Control/Concurrent/CHP/Channels/Base.hs
@@ -31,7 +31,6 @@
 
 import Control.Concurrent.STM
 import Control.Monad
-import Control.Monad.Trans
 import Data.Unique (Unique)
 
 import Control.Concurrent.CHP.Base
@@ -68,48 +67,17 @@
   writer :: w a}
 
 
-class ChaninC c a where
-  -- Start gets the event and the transaction that will wait for data.  You
-  -- sync on the event (possible extended write occurs) then wait for data
-  startReadChannelC :: c a -> (Event, STM (WithPoison a))
-  -- (extended read action goes here)
-  -- Read releases the writer
-  endReadChannelC :: c a -> STM (WithPoison ())
-
-  -- First action is to be done as part of the completion:
-  readChannelC :: c a -> (Event, STM (), STM (WithPoison a))
-
-  poisonReadC :: c a -> IO ()
-  checkPoisonReadC :: c a -> IO (WithPoison ())
-
-class ChanoutC c a where
-  -- Start checks for poison and gets the event:
-  startWriteChannelC :: c a -> (Event, STM (WithPoison ()))
-  -- (extended write action goes here)
-  -- Send actually transmits the value:
-  sendWriteChannelC :: c a -> a -> STM (WithPoison ())
-  -- (extended read action goes here)
-  -- End waits for the reader to tell us we're done, must be done in a different
-  -- transaction to the send
-  endWriteChannelC :: c a -> STM (WithPoison ())
-
-  -- First action is to be done as part of the completion:
-  writeChannelC :: c a -> a -> (Event, STM (), STM (WithPoison ()))
-  
-  poisonWriteC :: c a -> IO ()
-  checkPoisonWriteC :: c a -> IO (WithPoison ())
-
 instance Poisonable (Chanin a) where
-  poison (Chanin c) = liftIO $ poisonReadC c
-  checkForPoison (Chanin c) = liftCHP $ liftIO (checkPoisonReadC c) >>= checkPoison
+  poison (Chanin c) = liftCHP . liftIO_CHP $ poisonReadC c
+  checkForPoison (Chanin c) = liftCHP $ liftIO_CHP (checkPoisonReadC c) >>= checkPoison
 
 instance Poisonable (Chanout a) where
-  poison (Chanout c) = liftIO $ poisonWriteC c
-  checkForPoison (Chanout c) = liftCHP $ liftIO (checkPoisonWriteC c) >>= checkPoison
+  poison (Chanout c) = liftCHP . liftIO_CHP $ poisonWriteC c
+  checkForPoison (Chanout c) = liftCHP $ liftIO_CHP (checkPoisonWriteC c) >>= checkPoison
 
 
-stmChannel :: MonadIO m => Int -> (a -> String) -> m (Unique, STMChannel a)
-stmChannel pri sh = liftIO $
+stmChannel :: Int -> (a -> String) -> IO (Unique, STMChannel a)
+stmChannel pri sh =
   do c <- atomically $ newTVar $ NoPoison (Nothing, Nothing)
      e <- newEventPri (liftM (ChannelComm . maybe "" sh . getVal) $ readTVar c) 2 pri
      return (getEventUnique e, STMChan (e,c))
@@ -128,11 +96,18 @@
                       NoPoison (Just x, a) -> do writeTVar tv $ NoPoison (Nothing, a)
                                                  return $ NoPoison x
 
+sharedError :: String -> String
+sharedError s
+  = unlines ["CHP: Assumption violated; found " ++ s ++ " when placing " ++ s ++ "."
+            ,"This is typically because you have multiple writers or multiple readers accessing a unshared (one-to-one) channel."
+            ,"If you want to have many writers or many readers, use an appropriate (any-to-one, one-to-any or any-to-any) shared channel, using the claim function."
+            ]
+
 sendData :: TVar (WithPoison (Maybe a, Maybe ())) -> a -> STM (WithPoison ())
 sendData tv x  = do y <- readTVar tv
                     case y of
                       PoisonItem -> return PoisonItem
-                      NoPoison (Just _, _) -> error "CHP: Found data while sending data"
+                      NoPoison (Just _, _) -> error $ sharedError "data"
                       NoPoison (Nothing, a) -> do writeTVar tv $ NoPoison (Just x, a)
                                                   return $ NoPoison ()
 
@@ -148,35 +123,62 @@
 sendAck tv =    do d <- readTVar tv
                    case d of
                       PoisonItem -> return PoisonItem
-                      NoPoison (_, Just _) -> error "CHP: Found ack while placing ack!"
+                      NoPoison (_, Just _) -> error $ sharedError "ack"
                       NoPoison (x, Nothing) -> do writeTVar tv $ NoPoison (x, Just ())
                                                   return $ NoPoison ()
 
-instance ChaninC STMChannel a where
-  startReadChannelC (STMChan (e,tv)) = (e, consumeData tv)
-  endReadChannelC (STMChan (_,tv)) = sendAck tv
-  readChannelC (STMChan (e, tv))
-    = (e, sendAck tv >> return (), consumeData tv)
+-- Start gets the event and the transaction that will wait for data.  You
+-- sync on the event (possible extended write occurs) then wait for data
+startReadChannelC :: STMChannel a -> (Event, STM (WithPoison a))
+startReadChannelC (STMChan (e,tv)) = (e, consumeData tv)
 
-  poisonReadC (STMChan (e,tv))
-    = liftSTM $ do poisonEvent e
-                   writeTVar tv PoisonItem
-  checkPoisonReadC (STMChan (e,_)) = liftSTM $ checkEventForPoison e
+-- (extended read action goes here)
+-- Read releases the writer
+endReadChannelC :: STMChannel a -> STM (WithPoison ())
+endReadChannelC (STMChan (_,tv)) = sendAck tv
 
-instance ChanoutC STMChannel a where
-  startWriteChannelC (STMChan (e,tv))
+-- First action is to be done as part of the completion:
+readChannelC :: STMChannel a -> (Event, STM (), STM (WithPoison a))
+readChannelC (STMChan (e, tv))
+  = (e, sendAck tv >> return (), consumeData tv)
+
+poisonReadC :: STMChannel a -> IO ()
+poisonReadC (STMChan (e,tv))
+    = atomically $ do poisonEvent e
+                      writeTVar tv PoisonItem
+
+checkPoisonReadC :: STMChannel a -> IO (WithPoison ())
+checkPoisonReadC (STMChan (e,_)) = atomically $ checkEventForPoison e
+
+-- Start checks for poison and gets the event:
+startWriteChannelC :: STMChannel a -> (Event, STM (WithPoison ()))
+startWriteChannelC (STMChan (e,tv))
     = (e, do x <- readTVar tv
              case x of
                PoisonItem -> return PoisonItem
                NoPoison _ -> return $ NoPoison ())
-  sendWriteChannelC (STMChan (_, tv)) = sendData tv
-  endWriteChannelC (STMChan (_, tv))
+
+-- (extended write action goes here)
+-- Send actually transmits the value:
+sendWriteChannelC :: STMChannel a -> a -> STM (WithPoison ())
+sendWriteChannelC (STMChan (_, tv)) = sendData tv
+
+-- (extended read action goes here)
+-- End waits for the reader to tell us we're done, must be done in a different
+-- transaction to the send
+endWriteChannelC :: STMChannel a -> STM (WithPoison ())
+endWriteChannelC (STMChan (_, tv))
     = consumeAck tv
 
-  writeChannelC (STMChan (e, tv)) val
+-- First action is to be done as part of the completion:
+writeChannelC :: STMChannel a -> a -> (Event, STM (), STM (WithPoison ()))
+writeChannelC (STMChan (e, tv)) val
     = (e, sendData tv val >> return (), consumeAck tv)
 
-  poisonWriteC (STMChan (e,tv))
-    = liftSTM $ do poisonEvent e
-                   writeTVar tv PoisonItem
-  checkPoisonWriteC (STMChan (e,_)) = liftSTM $ checkEventForPoison e
+poisonWriteC :: STMChannel a -> IO ()
+poisonWriteC (STMChan (e,tv))
+  = atomically $ do poisonEvent e
+                    writeTVar tv PoisonItem
+
+checkPoisonWriteC :: STMChannel a -> IO (WithPoison ())
+checkPoisonWriteC (STMChan (e,_)) = atomically $ checkEventForPoison e
diff --git a/Control/Concurrent/CHP/Channels/BroadcastReduce.hs b/Control/Concurrent/CHP/Channels/BroadcastReduce.hs
--- a/Control/Concurrent/CHP/Channels/BroadcastReduce.hs
+++ b/Control/Concurrent/CHP/Channels/BroadcastReduce.hs
@@ -74,7 +74,6 @@
 import Control.Arrow
 import Control.Concurrent.STM
 import Control.Monad
-import Control.Monad.Trans
 import Data.Monoid
 
 import Control.Concurrent.CHP.Barriers
@@ -117,18 +116,18 @@
            (resetManyToOneTVar tvAck . pred) $ Enrolled b
            -- subtract one for writer
          (x, r) <- m
-         liftIO . atomically $ writeTVar tvSend $ Just x
+         liftSTM $ writeTVar tvSend $ Just x
          -- Must be two separate transactions:
-         _ <- liftIO . atomically $ readManyToOneTVar tvAck
+         _ <- liftSTM $ readManyToOneTVar tvAck
          return r
 
 instance ReadableChannel (Enrolled BroadcastChanin) where
   extReadChannel (Enrolled (BI (BC (b, tvSend, tvAck)))) f
     = do syncBarrierWith (indivRecJust ChannelRead)
            (resetManyToOneTVar tvAck . pred) $ Enrolled b
-         x <- liftIO $ atomically $ readTVar tvSend >>= maybe retry return
+         x <- liftSTM $ readTVar tvSend >>= maybe retry return
          y <- f x
-         _ <- liftIO $ atomically $ writeManyToOneTVar pred tvAck
+         _ <- liftSTM $ writeManyToOneTVar pred tvAck
          return y
 
 instance Poisonable (BroadcastChanout a) where
@@ -143,9 +142,9 @@
 newBroadcastChannel
   = do b@(Barrier (e, _, _)) <- newBarrier
        -- Writer is always enrolled:
-       _ <- liftIO $ atomically $ enrollEvent e
-       tvSend <- liftIO $ atomically $ newTVar Nothing
-       tvAck <- liftIO $ atomically $ newManyToOneTVar (== 0) (return 0) 0
+       _ <- liftSTM $ enrollEvent e
+       tvSend <- liftSTM $ newTVar Nothing
+       tvAck <- liftSTM $ newManyToOneTVar (== 0) (return 0) 0
        return $ BC (b, tvSend, tvAck)
 
 instance Channel BroadcastChanin BroadcastChanout where
@@ -156,7 +155,7 @@
 
 instance Channel BroadcastChanin (Shared BroadcastChanout) where
   newChannel' _sh = liftCHP $ do
-    m <- newMutex
+    m <- liftIO_CHP newMutex
     c <- newChannel
     return $ Chan (getChannelIdentifier c) (reader c) (Shared (m, writer c))
   sameChannel (BI x) (Shared (_, BO y)) = x == y
@@ -215,12 +214,12 @@
            (\n -> resetManyToOneTVar tv (pred n, Nothing)) $ Enrolled b
            -- Subtract one for reader
          (x, r) <- m
-         (_, Just (_, rtvb)) <- liftIO . atomically $ do
+         (_, Just (_, rtvb)) <- liftSTM $ do
            tvb <- newTVar False
            let upd (n, mx) = (pred n, Just $ maybe (x, tvb) (first $ f x) mx)
            writeManyToOneTVar upd tv
          -- Has to be two separate transactions
-         liftIO $ atomically $ readTVar rtvb >>= flip unless retry
+         liftSTM $ readTVar rtvb >>= flip unless retry
          return r
 
 instance ReadableChannel ReduceChanin where
@@ -228,10 +227,10 @@
     = do syncBarrierWith (indivRecJust ChannelRead)
            (\n -> resetManyToOneTVar tv (pred n, Nothing)) $ Enrolled b
            -- Subtract one for reader
-         (_, val) <- liftIO $ atomically $ readManyToOneTVar tv
+         (_, val) <- liftSTM $ readManyToOneTVar tv
          case val of
            Just (x, tvb) -> do y <- f x
-                               liftIO $ atomically $ writeTVar tvb True
+                               liftSTM $ writeTVar tvb True
                                return y
            Nothing -> f empty
 
@@ -247,8 +246,8 @@
 newReduceChannel
   = do b@(Barrier (e, _, _)) <- newBarrier
        -- Writer is always enrolled:
-       _ <- liftIO $ atomically $ enrollEvent e
-       mtv <- liftIO $ atomically $ newManyToOneTVar ((== 0) . fst) (return (0, Nothing)) (0, Nothing)
+       _ <- liftSTM $ enrollEvent e
+       mtv <- liftSTM $ newManyToOneTVar ((== 0) . fst) (return (0, Nothing)) (0, Nothing)
        return $ GC (b, mtv, (mappend, mempty))
 
 -- | The reduce channel version of sameChannel.
@@ -268,7 +267,7 @@
 
 manyToAnyChannel :: (Monoid a, MonadCHP m) => m (ManyToAnyChannel a)
 manyToAnyChannel = do
-    m <- newMutex
+    m <- liftCHP $ liftIO_CHP newMutex
     c <- manyToOneChannel
     return $ Chan (getChannelIdentifier c) (Shared (m, reader c)) (writer c)
 
diff --git a/Control/Concurrent/CHP/Channels/Communication.hs b/Control/Concurrent/CHP/Channels/Communication.hs
--- a/Control/Concurrent/CHP/Channels/Communication.hs
+++ b/Control/Concurrent/CHP/Channels/Communication.hs
@@ -56,7 +56,7 @@
   ReadableChannel(..), WriteableChannel(..), writeValue, writeChannelStrict
   ) where
 
-
+import Control.Concurrent.STM (atomically)
 import Control.DeepSeq
 import Control.Monad
 import Data.Monoid
@@ -132,12 +132,12 @@
     = let (e, mdur, mafter) = readChannelC c in
       buildOnEventPoison (wrapIndiv $ indivRecJust ChannelRead) e
         (EventActions (const $ return ()) mdur)
-        (liftSTM mafter) >>= checkPoison
+        (atomically mafter)
 
   extReadChannel (Chanin c) body
     = let (e, m) = startReadChannelC c in
       scopeBlock
-        (buildOnEventPoison (wrapIndiv $ indivRecJust ChannelRead) e mempty (liftSTM m) >>= checkPoison)
+        (buildOnEventPoison (wrapIndiv $ indivRecJust ChannelRead) e mempty (atomically m))
         (\val -> do x <- body val
                     _ <- liftSTM $ endReadChannelC c
                     return x)
@@ -147,13 +147,12 @@
   writeChannel (Chanout c) x
     = let (e, mdur, mafter) = writeChannelC c x in
         buildOnEventPoison (wrapIndiv $ indivRecJust ChannelWrite) e
-          (EventActions (const $ return ()) mdur) (liftSTM mafter)
-        >>= checkPoison
+          (EventActions (const $ return ()) mdur) (atomically mafter)
   extWriteChannel' (Chanout c) body
     = let (e, m) = startWriteChannelC c in
       scopeBlock
         (buildOnEventPoison (wrapIndiv $ indivRecJust ChannelWrite)
-          e mempty (liftSTM m) >>= checkPoison)
+          e mempty (atomically m))
         (const $ do (x, r) <- body
                     sequence [liftSTM $ sendWriteChannelC c x
                              ,liftSTM (endWriteChannelC c)]
diff --git a/Control/Concurrent/CHP/Channels/Creation.hs b/Control/Concurrent/CHP/Channels/Creation.hs
--- a/Control/Concurrent/CHP/Channels/Creation.hs
+++ b/Control/Concurrent/CHP/Channels/Creation.hs
@@ -63,7 +63,7 @@
 -- the channels in traces).  Instead of using @oneToOneChannelWithLabel "foo"@,
 -- you should use @oneToOneChannel' $ chanLabel "foo"@.
 module Control.Concurrent.CHP.Channels.Creation (
-  Chan, Channel(..), newChannel, ChanOpts(..), defaultChanOpts, chanLabel, newChannelWR, newChannelRW, ChannelTuple(..),
+  Chan, Channel(..), newChannel, ChanOpts(..), defaultChanOpts, chanLabel, newChannelWR, newChannelRW,
   newChannelList, newChannelListWithLabels, newChannelListWithStem,
   labelChannel
   ) where
@@ -137,17 +137,6 @@
 newChannel :: (MonadCHP m, Channel r w) => m (Chan r w a)
 newChannel = newChannel' defaultChanOpts
 
--- | A helper class for easily creating several channels of the same type.
---  The same type refers not only to what type the channel carries, but
---  also to the type of channel (one-to-one no poison, one-to-any with
---  poison, etc).  You can write code like this:
---
--- > (a, b, c, d, e) <- newChannels
---
--- To create five channels of the same type.
-class ChannelTuple t where
-  newChannels :: MonadCHP m => m t
-
 -- | A helper that is like 'newChannel' but returns the reading and writing
 -- end of the channels directly.
 newChannelRW :: (Channel r w, MonadCHP m) => m (r a, w a)
@@ -178,76 +167,38 @@
 newChannelListWithLabels :: (Channel r w, MonadCHP m) => [String] -> m [Chan r w a]
 newChannelListWithLabels = mapM (newChannel' . ChanOpts 0 (const "") . Just)
 
-instance (Channel r w) => ChannelTuple (Chan r w a, Chan r w a) where
-  newChannels = do c0 <- newChannel
-                   c1 <- newChannel
-                   return (c0, c1)
-
-instance (Channel r w) => ChannelTuple (Chan r w a, Chan r w a, Chan r w a) where
-  newChannels = do c0 <- newChannel
-                   c1 <- newChannel
-                   c2 <- newChannel
-                   return (c0, c1, c2)
-
-instance (Channel r w) => ChannelTuple (Chan r w a, Chan r w a, Chan r w a,
-  Chan r w a) where
-  newChannels = do c0 <- newChannel
-                   c1 <- newChannel
-                   c2 <- newChannel
-                   c3 <- newChannel
-                   return (c0, c1, c2, c3)
-
-instance (Channel r w) => ChannelTuple (Chan r w a, Chan r w a, Chan r w a,
-  Chan r w a, Chan r w a) where
-  newChannels = do c0 <- newChannel
-                   c1 <- newChannel
-                   c2 <- newChannel
-                   c3 <- newChannel
-                   c4 <- newChannel
-                   return (c0, c1, c2, c3, c4)
-
-instance (Channel r w) => ChannelTuple (Chan r w a, Chan r w a, Chan r w a,
-  Chan r w a, Chan r w a, Chan r w a) where
-  newChannels = do c0 <- newChannel
-                   c1 <- newChannel
-                   c2 <- newChannel
-                   c3 <- newChannel
-                   c4 <- newChannel
-                   c5 <- newChannel
-                   return (c0, c1, c2, c3, c4, c5)
-
 -- | Labels a channel in the traces.  It is easiest to do this at creation.
 -- The effect of re-labelling channels after their first use is undefined.
 --
 -- Added in version 1.5.0.
 labelChannel :: MonadCHP m => Chan r w a -> String -> m ()
-labelChannel c = liftCHP . liftPoison . liftTrace . labelUnique (getChannelIdentifier c)
+labelChannel c s = liftCHP $ getTrace >>= \t -> liftIO_CHP $ labelUnique t (getChannelIdentifier c) s
 
 
 instance Channel Chanin Chanout where
-  newChannel' o = do c <- chan (stmChannel (chanOptsPriority o) (chanOptsShow o)) Chanin Chanout
+  newChannel' o = do c <- chan (liftCHP . liftIO_CHP $ stmChannel (chanOptsPriority o) (chanOptsShow o)) Chanin Chanout
                      maybe (return ()) (labelChannel c) (chanOptsLabel o)
                      return c
   sameChannel (Chanin x) (Chanout y) = x == y
 
 instance Channel (Shared Chanin) Chanout where
   newChannel' o = do
-                  m <- newMutex
+                  m <- liftCHP . liftIO_CHP $ newMutex
                   c <- newChannel' o
                   return $ Chan (getChannelIdentifier c) (Shared (m, reader c)) (writer c)
   sameChannel (Shared (_, Chanin x)) (Chanout y) = x == y
 
 instance Channel Chanin (Shared Chanout) where
   newChannel' o = do
-                  m <- newMutex
+                  m <- liftCHP . liftIO_CHP $ newMutex
                   c <- newChannel' o
                   return $ Chan (getChannelIdentifier c) (reader c) (Shared (m, writer c))
   sameChannel (Chanin x) (Shared (_, Chanout y)) = x == y
 
 instance Channel (Shared Chanin) (Shared Chanout) where
   newChannel' o = do
-                  m <- newMutex
-                  m' <- newMutex
+                  m <- liftCHP . liftIO_CHP $ newMutex
+                  m' <- liftCHP . liftIO_CHP $ newMutex
                   c <- newChannel' o
                   return $ Chan (getChannelIdentifier c) (Shared (m, reader c)) (Shared (m', writer c))
   sameChannel (Shared (_, Chanin x)) (Shared (_, Chanout y)) = x == y
diff --git a/Control/Concurrent/CHP/Channels/Ends.hs b/Control/Concurrent/CHP/Channels/Ends.hs
--- a/Control/Concurrent/CHP/Channels/Ends.hs
+++ b/Control/Concurrent/CHP/Channels/Ends.hs
@@ -38,8 +38,6 @@
   reader, writer, readers, writers,
   claim) where
 
-import Control.Monad.Trans (liftIO)
-
 import Control.Concurrent.CHP.Base
 import Control.Concurrent.CHP.CSP
 import Control.Concurrent.CHP.Channels.Base
@@ -62,8 +60,8 @@
 claim :: Shared c a -> (c a -> CHP b) -> CHP b
 claim (Shared (lock, c)) body
   = scopeBlock
-       (claimMutex lock >> return c)
+       (liftIO_CHP (claimMutex lock) >> return c)
        (\y -> do x <- body y
-                 liftIO $ releaseMutex lock
+                 liftIO_CHP $ releaseMutex lock
                  return x)
        (releaseMutex lock)
diff --git a/Control/Concurrent/CHP/Clocks.hs b/Control/Concurrent/CHP/Clocks.hs
--- a/Control/Concurrent/CHP/Clocks.hs
+++ b/Control/Concurrent/CHP/Clocks.hs
@@ -120,8 +120,6 @@
 
 import Control.Concurrent.STM
 import Control.Monad hiding (mapM, mapM_)
-import Control.Monad.Reader (ask)
-import Control.Monad.Trans
 import Data.Foldable (mapM_)
 -- Needed for testing:
 --import Data.Maybe
@@ -327,14 +325,14 @@
          liftSTM (modifyTVar tv $ enrollTimerData $ Just ev)
            >>= checkPoison
          x <- f $ Enrolled tim
-         ts <- liftPoison . liftTrace $ ask
+         ts <- getTrace
          liftSTM (modifyTVar' tv $ checkCompletion u sh ts . resignTimerData True)
            >>= checkPoison
          return x
 
   -- For temporary resignations, we don't touch the event pool
   resign (Enrolled (Clock (tv, u, sh))) m
-    = do ts <- liftPoison . liftTrace $ ask
+    = do ts <- getTrace
          liftSTM (modifyTVar' tv (checkCompletion u sh ts . resignTimerData False))
            >>= checkPoison
          x <- m
@@ -406,32 +404,34 @@
 -- to display times in traces.
 newClock :: (Ord time, Show time) => time -> CHP (Clock time)
 newClock t = do tv <- liftSTM $ newTVar $ NoPoison $ emptyTimerData t
-                u <- liftIO Event.newEventUnique
+                u <- liftIO_CHP Event.newEventUnique
                 return $ Clock (tv, u, show)
 
 -- | Creates a clock that starts at the given time, and gives it the given
 -- label in traces.  The Show instance is needed to display times in traces.
 newClockWithLabel :: (Ord time, Show time) =>
   time -> String -> CHP (Clock time)
-newClockWithLabel t l = do tv <- liftSTM $ newTVar $ NoPoison $ emptyTimerData t
-                           u <- liftIO Event.newEventUnique
-                           liftPoison $ liftTrace $ labelUnique u l
+newClockWithLabel t l = getTrace >>= \tr -> liftIO_CHP $
+                        do tv <- atomically $ newTVar $ NoPoison $ emptyTimerData t
+                           u <- Event.newEventUnique
+                           labelUnique tr u l
                            return $ Clock (tv, u, show)
 
 instance Waitable Clock where
   getCurrentTime (Enrolled (Clock (tv, _, _)))
     = liftSTM (liftM (fmap curTime) $ readTVar tv) >>= checkPoison
   wait c@(Enrolled (Clock (_, u, sh))) mt
-    = do ts <- liftPoison . liftTrace $ ask
-         pid <- liftPoison . liftTrace $ getProcessId
-         waitAct <- liftSTM $ waitClock pid ts c mt
+    = do tr <- getTrace
+         let pid = getProcessId tr
+         waitAct <- liftSTM $ waitClock pid tr c mt
          (t, s) <- liftSTM waitAct >>= checkPoison
-         liftPoison $ liftTrace $ recordEvent [ClockSyncIndiv u s $ sh t]
+         liftIO_CHP $ recordEvent [ClockSyncIndiv u s $ sh t] tr
          return t
 
 instance Ord time => Poisonable (Enrolled Clock time) where
   poison (Enrolled (Clock (tv,_,_)))
-    = liftSTM $ do x <- readTVar tv
+    = liftCHP . liftSTM $ do
+                   x <- readTVar tv
                    case x of
                      PoisonItem -> return ()
                      NoPoison td -> do poisonTimerData td
diff --git a/Control/Concurrent/CHP/Event.hs b/Control/Concurrent/CHP/Event.hs
--- a/Control/Concurrent/CHP/Event.hs
+++ b/Control/Concurrent/CHP/Event.hs
@@ -44,7 +44,6 @@
 import Control.Concurrent.STM hiding (always)
 import Control.Concurrent.CHP.EventType
 import Control.Monad
-import Control.Monad.Reader
 #ifdef CHP_TEST
 import Control.Monad.State
 #endif
@@ -92,7 +91,7 @@
 -- Nothing if resigning
 checkEvent :: CurOfferSet -> SearchState -> Event -> DiscoverM SearchState
 checkEvent cos ss e = do
-  s <- lift $ readTVar $ getEventTVar e
+  s <- liftWPMT $ readTVar $ getEventTVar e
   case s of
     PoisonItem -> WPMT $ return PoisonItem
     NoPoison (enrollCount, _, offers) ->
@@ -218,8 +217,10 @@
 instance Monad m => Functor (WithPoisonMaybeT m) where
   fmap f = WPMT . liftM (fmap (fmap f)) . runWPMT
 
-instance MonadTrans WithPoisonMaybeT where
-  lift = WPMT . liftM (NoPoison . Just)
+liftWPMT :: Monad m => m a -> WithPoisonMaybeT m a
+liftWPMT = WPMT . liftM (NoPoison . Just)
+
+
 
 instance (Monad m) => Applicative (WithPoisonMaybeT m) where
   pure = return
diff --git a/Control/Concurrent/CHP/Guard.hs b/Control/Concurrent/CHP/Guard.hs
--- a/Control/Concurrent/CHP/Guard.hs
+++ b/Control/Concurrent/CHP/Guard.hs
@@ -31,7 +31,6 @@
 
 import Control.Concurrent.STM
 import Control.Monad
-import Control.Monad.Trans
 import qualified Data.Map as Map
 import Data.Monoid
 import Data.Unique
@@ -76,7 +75,7 @@
 guardWaitFor :: Int -> Guard
 guardWaitFor n
   = TimeoutGuard $ 
-     do signalDone <- liftIO $ registerDelay n
+     do signalDone <- registerDelay n
         return $ do b <- readTVar signalDone
                     when (not b) retry
 
diff --git a/Control/Concurrent/CHP/Monad.hs b/Control/Concurrent/CHP/Monad.hs
--- a/Control/Concurrent/CHP/Monad.hs
+++ b/Control/Concurrent/CHP/Monad.hs
@@ -31,17 +31,19 @@
 module Control.Concurrent.CHP.Monad
   (
    -- * CHP Monad
-  CHP, MonadCHP(..), runCHP, runCHP_,
+  CHP, MonadCHP(..), liftIO_CHP, runCHP, runCHP_,
   embedCHP, embedCHP_, embedCHP1, embedCHP1_,
 
   onPoisonTrap, onPoisonRethrow, throwPoison, Poisonable(..), poisonAll,
 
   -- * Primitive actions
-  skip, stop, waitFor
+  skip, stop, waitFor,
+
+  -- * chp-spec items
+  foreverP, liftIO_CHP', process, subProcess
    ) where
 
-import Control.Concurrent
-import Control.Monad.Reader
+import Control.Monad (liftM, forever)
 import Data.Unique
 
 -- This module primarily re-exports the public definitions from
@@ -49,6 +51,7 @@
 
 import Control.Concurrent.CHP.Base
 import Control.Concurrent.CHP.Guard
+import Control.Concurrent.CHP.Poison
 import Control.Concurrent.CHP.Traces.TraceOff
 
 -- | Runs a CHP program.  You should use this once, at the top-level of your
@@ -62,6 +65,27 @@
 runCHP_ :: CHP a -> IO ()
 runCHP_ p = runCHP p >> return ()
 
+-- | Exactly the same as 'forever'.  Useful only because it mirrors a different definition
+-- from the chp-spec library.
+--
+-- Added in version 2.2.0.
+foreverP :: CHP a -> CHP b
+foreverP = forever
+
+-- | Acts as @const id@.  Useful only because it mirrors a different definition in the
+-- chp-spec library.
+--
+-- Added in version 2.2.0.
+process :: String -> a -> a
+process = const id
+
+-- | Acts as @const id@.  Useful only because it mirrors a different definition in the
+-- chp-spec library.
+--
+-- Added in version 2.2.0.
+subProcess :: String -> a -> a
+subProcess = const id
+
 -- | Allows embedding of the CHP monad back into the IO monad.  The argument
 -- that this function takes is a CHP action (with arbitrary behaviour).  The
 -- function is monadic, and returns something of type: IO a.  This
@@ -81,7 +105,7 @@
 
 -- | A helper like embedCHP for callbacks that take an argument
 embedCHP1 :: (a -> CHP b) -> CHP (a -> IO (Maybe b))
-embedCHP1 f = do t <- liftPoison $ liftTrace ask
+embedCHP1 f = do t <- getTrace
                  return $ runCHPProgramWith t . f
 
 -- | A convenient version of embedCHP1 that ignores the result
@@ -102,7 +126,7 @@
 -- /NOTE:/ If you wish to use this as part of a choice, you must use @-threaded@
 -- as a GHC compilation option (at least under 6.8.2).
 waitFor :: Int -> CHP ()
-waitFor n = liftPoison $ AltableT (Right [(guardWaitFor n, return ())]) (liftIO $ threadDelay n)
+waitFor n = makeAltable [(guardWaitFor n, return $ NoPoison ())]
 -- TODO maybe fix the above lack of guarantees by keeping timeout guards explicit.
 
 -- TODO add waitUntil
@@ -111,23 +135,11 @@
 --
 -- Suitable for use in an 'Control.Concurrent.CHP.Alt.alt'.
 skip :: CHP ()
-skip = liftPoison $ AltableT (Right [(skipGuard, return ())]) (return ())
+skip = makeAltable [(skipGuard, return $ NoPoison ())]
 
--- | The stop guard.  Its main use is that it is never ready in a choice, so
--- can be used to mask out guards.  If you actually execute 'stop', that process
--- will do nothing more.  Any parent process waiting for it to complete will
--- wait forever.
+-- | Acts as @const liftIO_CHP@.  Useful only because it mirrors a different definition in the
+-- chp-spec library.
 --
--- The type of this function was generalised in CHP 1.6.0.
-stop :: CHP a
-stop = liftPoison $ AltableT (Right [(stopGuard, liftIO hang)]) (liftIO hang)
-  where
-    -- Strangely, I can't work out a good way to actually implement stop.
-    -- If you wait on a variable that will never be ready, GHC will wake
-    -- you up with an exception.  If you loop doing that, you'll burn the
-    -- CPU.  Throwing an exception would be caught and terminate the
-    -- process, which is not the desired behaviour.  The only thing I can think
-    -- to do is to repeatedly wait for a very long time.
-    hang :: IO a
-    hang = forever $ threadDelay maxBound
-
+-- Added in version 2.2.0.
+liftIO_CHP' :: String -> IO a -> CHP a
+liftIO_CHP' = const liftIO_CHP
diff --git a/Control/Concurrent/CHP/Mutex.hs b/Control/Concurrent/CHP/Mutex.hs
--- a/Control/Concurrent/CHP/Mutex.hs
+++ b/Control/Concurrent/CHP/Mutex.hs
@@ -30,18 +30,17 @@
 module Control.Concurrent.CHP.Mutex where
 
 import Control.Concurrent
-import Control.Monad.Trans
 
 type Mutex = MVar ()
 
-claimMutex :: MonadIO m => Mutex -> m ()
-claimMutex = liftIO . takeMVar
+claimMutex :: Mutex -> IO ()
+claimMutex = takeMVar
 
-newMutex :: MonadIO m => m Mutex
-newMutex = liftIO $ newMVar ()
+newMutex :: IO Mutex
+newMutex = newMVar ()
 
-releaseMutex :: MonadIO m => Mutex -> m ()
-releaseMutex m = liftIO $ putMVar m ()
+releaseMutex :: Mutex -> IO ()
+releaseMutex m = putMVar m ()
 
 -- | A wrapper (usually around a channel-end) indicating that the inner item
 -- is shared.  Use the 'claim' function to use this type.
diff --git a/Control/Concurrent/CHP/Parallel.hs b/Control/Concurrent/CHP/Parallel.hs
--- a/Control/Concurrent/CHP/Parallel.hs
+++ b/Control/Concurrent/CHP/Parallel.hs
@@ -28,17 +28,18 @@
 -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 module Control.Concurrent.CHP.Parallel (runParallel, runParallel_, (<||>), (<|*|>),
-  runParMapM, runParMapM_, ForkingT, forking, fork) where
+  runParMapM, runParMapM_ , ForkingT, liftForking, forking, fork) where
 
 import Control.Concurrent
 import Control.Concurrent.STM
+import Control.Monad (liftM)
 import qualified Control.Exception.Extensible as C
-import Control.Monad.Reader
 import Data.List
 import Data.Maybe
 import Data.Ord
 
 import Control.Concurrent.CHP.Base
+import Control.Concurrent.CHP.Poison
 import Control.Concurrent.CHP.Traces.Base
 
 -- | This type-class supports parallel composition of processes.  You may use
@@ -114,35 +115,46 @@
 -- | Runs all the processes in parallel and returns their results once they
 -- have all finished.  The length and ordering of the results reflects the
 -- length and ordering of the input
-runParallelPoison :: forall a. [CHP a] -> CHP [a]
+runParallelPoison :: [CHP a] -> CHP [a]
 runParallelPoison processes
-  = do resultVar <- liftIO $ atomically $ newManyToOneTVar
+  = do resultVar <- liftIO_CHP $ atomically $ newManyToOneTVar
          ((== length processes) . length) (return []) []
-       trace <- PoisonT $ lift $ liftTrace ask
-       blanks <- liftIO $ blankTraces trace (length processes)
-       liftIO $ 
-         mapM_ forkIO [do y <- wrapProcess p $ flip runReaderT btr . pullOutStandard
+       trace <- getTrace
+       blanks <- liftIO_CHP $ blankTraces trace (length processes)
+       liftIO_CHP $ 
+         mapM_ forkIO [do y <- wrapProcess p btr pullOutStandard
                           C.block $ atomically $
                             writeManyToOneTVar
                              ((:) (case y of
                                  Nothing -> (n, Nothing)
-                                 Just (Right x) -> (n, Just x)
-                                 Just (Left _) -> (n, Nothing)
+                                 Just (NoPoison x) -> (n, Just x)
+                                 Just PoisonItem -> (n, Nothing)
                                  )) resultVar
                              >> return ()
                       | (p, btr, n) <- zip3 processes blanks [(0::Int)..]]
-       results <- liftIO $ atomically $ readManyToOneTVar resultVar
+       results <- liftIO_CHP $ atomically $ readManyToOneTVar resultVar
        let sortedResults = map snd $ sortBy (comparing fst) results
-       PoisonT $ lift $ liftTrace $ mergeSubProcessTraces blanks
+       liftIO_CHP $ mergeSubProcessTraces blanks trace
        mapM (maybe throwPoison return) sortedResults
 
 -- | A monad transformer used for introducing forking blocks.
-newtype (Monad m, MonadCHP m) => ForkingT m a = Forking (ReaderT (TVar (Bool,
-  Int)) m a)
-  deriving (Monad, MonadIO, MonadTrans, MonadCHP)
+newtype ForkingT m a = Forking {runForkingT :: TVar (Bool, Int) -> m a }
 
+instance Monad m => Monad (ForkingT m) where
+  return = liftForking . return
+  m >>= k = Forking $ \tv -> runForkingT m tv >>= (flip runForkingT tv . k)
+
+instance MonadCHP m => MonadCHP (ForkingT m) where
+  liftCHP = liftForking . liftCHP
+
 -- TODO in future, get forking working with structural traces
 
+-- | An implementation of lift for the ForkingT monad transformer.
+--
+-- Added in version 2.2.0.
+liftForking :: Monad m => m a -> ForkingT m a
+liftForking = Forking . const
+
 -- | Executes a forking block.  Processes may be forked off inside (using the
 -- 'fork' function).  When the block completes, it waits for all the forked
 -- off processes to complete before returning the output, as long as none of
@@ -150,9 +162,9 @@
 -- is propagated (rethrown).
 forking :: MonadCHP m => ForkingT m a -> m a
 -- Like with parallel, this could probably be made a little more efficient
-forking (Forking m) = do b <- liftIO $ atomically $ newTVar (False, 0)
-                         output <- runReaderT m b
-                         p <- liftIO $ atomically $ do
+forking (Forking m) = do b <- liftCHP . liftSTM $ newTVar (False, 0)
+                         output <- m b
+                         p <- liftCHP . liftSTM $ do
                            (p,n) <- readTVar b
                            if n == 0
                              then return p
@@ -167,15 +179,14 @@
 -- are waited for.  At that point, once all of the processes have finished,
 -- if any of them threw poison it is propagated.
 fork :: MonadCHP m => CHP () -> ForkingT m ()
-fork p = Forking $
-           do b <- ask
-              liftIO $ atomically $ do
+fork p = Forking $ \b ->
+           do liftCHP . liftSTM $ do
                 (pa, n) <- readTVar b
                 writeTVar b (pa, n + 1)
-              trace <- liftCHP $ PoisonT $ lift $ liftTrace ask
-              [blank] <- liftIO $ blankTraces trace 1
-              _ <- liftIO $ forkIO $ do
-                r <- wrapProcess p $ flip runReaderT blank . pullOutStandard
+              trace <- liftCHP getTrace
+              [blank] <- liftCHP . liftIO_CHP $ blankTraces trace 1
+              _ <- liftCHP . liftIO_CHP $ forkIO $ do
+                r <- wrapProcess p blank pullOutStandard
                 C.block $ atomically $ do
                   (poisonedAlready, n) <- readTVar b
                   writeTVar b (poisonedAlready || isNothing r, n - 1)
diff --git a/Control/Concurrent/CHP/Traces/Base.hs b/Control/Concurrent/CHP/Traces/Base.hs
--- a/Control/Concurrent/CHP/Traces/Base.hs
+++ b/Control/Concurrent/CHP/Traces/Base.hs
@@ -30,8 +30,7 @@
 module Control.Concurrent.CHP.Traces.Base where
 
 import Control.Concurrent.STM
-import Control.Monad.Reader
-import Control.Monad.State
+import Control.Monad (liftM)
 import Data.IORef
 import Data.List
 import qualified Data.Map as Map
@@ -102,16 +101,22 @@
 
 type RecEvents = ([RecordedEvent Unique], [RecordedIndivEvent Unique])
 
-getName :: Ord u => String -> u -> State (Map.Map u String) String
-getName prefix u
-          = do m <- get
+data LabelM u a = LabelM { runLabelM :: ChannelLabels u -> (a, ChannelLabels u) }
+
+labelWith :: LabelM u a -> ChannelLabels u -> a
+labelWith = (fst .) . runLabelM
+
+instance Monad (LabelM u) where
+  return = LabelM . (,)
+  m >>= k = LabelM $ \s -> let (a, s') = runLabelM m s in runLabelM (k a) s'
+
+getName :: Ord u => String -> u -> LabelM u String
+getName prefix u = LabelM $ \m ->
                case Map.lookup u m of
-                 Just x -> return x
-                 Nothing -> let x = prefix ++ show (Map.size m) in
-                            do put $ Map.insert u x m
-                               return x
+                 Just x -> (x, m)
+                 Nothing -> let x = prefix ++ show (Map.size m) in (x, Map.insert u x m)
 
-nameEvent :: Ord u => RecordedEvent u -> State (Map.Map u String) String
+nameEvent :: Ord u => RecordedEvent u -> LabelM u String
 nameEvent (t, c) = liftM (++ suffix) $ getName prefix c
   where
     (prefix, suffix) = case t of
@@ -119,7 +124,7 @@
       BarrierSync x -> ("_b", if null x then "" else '.' : x)
       ClockSync st -> ("_t", ':' : st)
 
-nameEvent' :: Ord u => RecordedEvent u -> State (Map.Map u String) (RecordedEvent String)
+nameEvent' :: Ord u => RecordedEvent u -> LabelM u (RecordedEvent String)
 nameEvent' (t, c) = do c' <- getName prefix c
                        return (t, c' ++ suffix)
   where
@@ -129,7 +134,7 @@
       ClockSync st -> ("_t", ':' : st)
 
 
-nameIndivEvent :: Ord u => RecordedIndivEvent u -> State (Map.Map u String) String
+nameIndivEvent :: Ord u => RecordedIndivEvent u -> LabelM u String
 nameIndivEvent (ChannelWrite c n _) = do c' <- getName "_c" c
                                          return $ c' ++ "![" ++ show n ++ "]"
 nameIndivEvent (ChannelRead c n _) = do c' <- getName "_c" c
@@ -140,7 +145,7 @@
                                            return $ c' ++ ":" ++ t
                                              ++ "[" ++ show n ++ "]"
 
-nameIndivEvent' :: Ord u => RecordedIndivEvent u -> State (Map.Map u String) (RecordedIndivEvent String)
+nameIndivEvent' :: Ord u => RecordedIndivEvent u -> LabelM u (RecordedIndivEvent String)
 nameIndivEvent' (ChannelWrite c n x) = do c' <- getName "_c" c
                                           return $ ChannelWrite c' n x
 nameIndivEvent' (ChannelRead c n x) = do c' <- getName "_c" c
@@ -151,8 +156,6 @@
                                             return $ ClockSyncIndiv c' n t
 
 
-type TraceT = ReaderT TraceStore
-
 data TraceStore =
   NoTrace ProcessId
   | Trace (ProcessId, TVar (ChannelLabels Unique), SubTraceStore)
@@ -204,15 +207,15 @@
                  -> foldl (flip Set.insert) z news' : zs
 
 -- | Records an event where you were one of the people involved
-recordEvent :: [RecordedIndivEvent Unique] -> TraceT IO ()
-recordEvent e = ask >>= lift . mapSubTrace recH
+recordEvent :: [RecordedIndivEvent Unique] -> TraceStore -> IO ()
+recordEvent e = mapSubTrace recH
   where
     recH (Hierarchy es) = modifyIORef es (addParEventsH (map StrEvent e))
     recH _ = return ()
 
-mergeSubProcessTraces :: [TraceStore] -> TraceT IO ()
+mergeSubProcessTraces :: [TraceStore] -> TraceStore -> IO ()
 mergeSubProcessTraces ts
-  = ask >>= lift . mapSubTrace merge
+  = mapSubTrace merge
   where
     ts' = mapM readIORef [t | Trace (_,_,Hierarchy t) <- ts]
     merge (Hierarchy es) = ts' >>= modifyIORef es . addParEventsH
@@ -277,18 +280,17 @@
 addRLE x nes = (1,[x]):nes
 
 
-labelEvent :: Event -> String -> TraceT IO ()
-labelEvent e = labelUnique (getEventUnique e)
+labelEvent :: TraceStore -> Event -> String -> IO ()
+labelEvent t e = labelUnique t (getEventUnique e)
 
-labelUnique :: Unique -> String -> TraceT IO ()
-labelUnique u l
-  = do t <- ask
-       case t of
-         NoTrace {} -> return ()
-         Trace (_,tvls,_) -> add tvls
+labelUnique :: TraceStore -> Unique -> String -> IO ()
+labelUnique t u l
+  = case t of
+       NoTrace {} -> return ()
+       Trace (_,tvls,_) -> add tvls
   where
-    add :: TVar (Map.Map Unique String) -> TraceT IO ()
-    add tv = liftIO $ atomically $ do
+    add :: TVar (Map.Map Unique String) -> IO ()
+    add tv = atomically $ do
       m <- readTVar tv
       writeTVar tv $ Map.insert u l m
 
diff --git a/Control/Concurrent/CHP/Traces/CSP.hs b/Control/Concurrent/CHP/Traces/CSP.hs
--- a/Control/Concurrent/CHP/Traces/CSP.hs
+++ b/Control/Concurrent/CHP/Traces/CSP.hs
@@ -32,7 +32,7 @@
 module Control.Concurrent.CHP.Traces.CSP (CSPTrace(..), getCSPPlain, runCHP_CSPTrace, runCHP_CSPTraceAndPrint) where
 
 import Control.Concurrent.STM
-import Control.Monad.State
+import Control.Monad (liftM)
 import qualified Data.Map as Map
 import Data.Unique
 import Text.PrettyPrint.HughesPJ
@@ -54,10 +54,10 @@
                         runCHPProgramWith' st (flip toPublic st) p
 
   prettyPrint (CSPTrace (labels, events))
-    = char '<' <+> sep (punctuate (char ',') $ evalState (mapM (liftM text . nameEvent) events) labels) <+> char '>'
+    = char '<' <+> sep (punctuate (char ',') $ mapM (liftM text . nameEvent) events `labelWith` labels) <+> char '>'
 
   labelAll (CSPTrace (labels, events))
-    = CSPTrace (Map.empty, evalState (mapM nameEvent' events) labels)
+    = CSPTrace (Map.empty, mapM nameEvent' events `labelWith` labels)
 
 toPublic :: ChannelLabels Unique -> SubTraceStore -> IO (CSPTrace Unique)
 toPublic l (CSPTraceRev tv)
diff --git a/Control/Concurrent/CHP/Traces/Structural.hs b/Control/Concurrent/CHP/Traces/Structural.hs
--- a/Control/Concurrent/CHP/Traces/Structural.hs
+++ b/Control/Concurrent/CHP/Traces/Structural.hs
@@ -38,7 +38,6 @@
   getAllEventsInHierarchy) where
 
 import Control.Applicative hiding (empty)
-import Control.Monad.State
 import qualified Data.Foldable as F
 import Data.IORef
 import Data.List
@@ -115,7 +114,7 @@
 
   prettyPrint (StructuralTrace (_,Nothing)) = empty
   prettyPrint (StructuralTrace (labels, Just h))
-    = pp $ evalState (T.mapM nameIndivEvent h) labels
+    = pp $ T.mapM nameIndivEvent h `labelWith` labels
     where
       pp :: EventHierarchy String -> Doc
       pp (SingleEvent x) = text x
@@ -129,7 +128,7 @@
 
   labelAll (StructuralTrace (_, Nothing)) = StructuralTrace (Map.empty, Nothing)
   labelAll (StructuralTrace (labels, Just h))
-    = StructuralTrace (Map.empty, Just $ evalState (T.mapM nameIndivEvent' h) labels)
+    = StructuralTrace (Map.empty, Just $ T.mapM nameIndivEvent' h `labelWith` labels)
 
 toPublic :: ChannelLabels Unique -> SubTraceStore -> IO (StructuralTrace Unique)
 toPublic l (Hierarchy hv)
diff --git a/Control/Concurrent/CHP/Traces/VCR.hs b/Control/Concurrent/CHP/Traces/VCR.hs
--- a/Control/Concurrent/CHP/Traces/VCR.hs
+++ b/Control/Concurrent/CHP/Traces/VCR.hs
@@ -34,7 +34,7 @@
 module Control.Concurrent.CHP.Traces.VCR (VCRTrace(..), getVCRPlain, runCHP_VCRTrace, runCHP_VCRTraceAndPrint) where
 
 import Control.Concurrent.STM
-import Control.Monad.State
+import Control.Monad (liftM)
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Data.Unique
@@ -63,13 +63,13 @@
   prettyPrint (VCRTrace (labels, eventSets))
     = char '<' <+> sep (punctuate (char ',') $ map (braces . sep . punctuate (char ',')) ropes) <+> char '>'
     where
-      es = evalState (mapM nameVCR eventSets) labels
+      es = mapM nameVCR eventSets `labelWith` labels
 
       ropes :: [[Doc]]
       ropes = map (map text . Set.toList) es
 
   labelAll (VCRTrace (labels, eventSets))
-    = VCRTrace (Map.empty, evalState (mapM nameVCR' eventSets) labels)
+    = VCRTrace (Map.empty, mapM nameVCR' eventSets `labelWith` labels)
 
 toPublic :: ChannelLabels Unique -> SubTraceStore -> IO (VCRTrace Unique)
 toPublic l (VCRTraceRev tv)
@@ -77,10 +77,10 @@
        return $ VCRTrace (l, map (Set.map snd) $ reverse setList)
 toPublic _ _ = error "Error in VCR trace -- tracing type got switched"
 
-nameVCR :: Ord u => Set.Set (RecordedEvent u) -> State (ChannelLabels u) (Set.Set String)
+nameVCR :: Ord u => Set.Set (RecordedEvent u) -> LabelM u (Set.Set String)
 nameVCR = liftM Set.fromList . mapM nameEvent . Set.toList
 
-nameVCR' :: Ord u => Set.Set (RecordedEvent u) -> State (ChannelLabels u) (Set.Set (RecordedEvent String))
+nameVCR' :: Ord u => Set.Set (RecordedEvent u) -> LabelM u (Set.Set (RecordedEvent String))
 nameVCR' = liftM Set.fromList . mapM nameEvent' . Set.toList
 
 -- | A helper function for pulling out the interesting bit from a VCR trace processed
diff --git a/chp.cabal b/chp.cabal
--- a/chp.cabal
+++ b/chp.cabal
@@ -1,5 +1,5 @@
 Name:            chp
-Version:         2.1.0.1
+Version:         2.2.0
 Synopsis:        An implementation of concurrency ideas from Communicating Sequential Processes
 License:         BSD3
 License-file:    LICENSE
@@ -23,7 +23,7 @@
 
 Cabal-Version:   >= 1.2.3
 Build-Type:      Simple
-Build-Depends:   base >= 3 && < 5, containers, deepseq >= 1.1 && < 1.2, extensible-exceptions >= 0.1.1.0, loop-while, mtl, pretty, stm
+Build-Depends:   base >= 3 && < 5, containers, deepseq >= 1.1 && < 1.2, extensible-exceptions >= 0.1.1.0, pretty, stm
 
 Exposed-modules: Control.Concurrent.CHP
                  Control.Concurrent.CHP.Alt
@@ -57,7 +57,7 @@
                  Control.Concurrent.CHP.ProcessId
                  Control.Concurrent.CHP.Traces.Base
 
-Extensions:      BangPatterns CPP FlexibleInstances GeneralizedNewtypeDeriving
-                 MultiParamTypeClasses ScopedTypeVariables 
+Extensions:      BangPatterns CPP FlexibleInstances
+                 MultiParamTypeClasses Rank2Types ScopedTypeVariables
 
 GHC-Options:     -Wall -auto-all