content: -----------------------------------------------------------------------------
  --
  -- Module      :  Base
  -- Copyright   :
  -- License     :  MIT
  --
  -- Maintainer  :  agocorona@gmail.com
  -- Stability   :
  -- Portability :
  --
  -- | See http://github.com/agocorona/transient
  -- Everything in this module is exported in order to allow extensibility.
  -----------------------------------------------------------------------------
  {-# LANGUAGE ScopedTypeVariables       #-}
  {-# LANGUAGE ExistentialQuantification #-}
  {-# LANGUAGE FlexibleContexts          #-}
  {-# LANGUAGE FlexibleInstances         #-}
  {-# LANGUAGE MultiParamTypeClasses     #-}
  {-# LANGUAGE DeriveDataTypeable        #-}
  {-# LANGUAGE UndecidableInstances      #-}
  {-# LANGUAGE Rank2Types                #-}
  {-# LANGUAGE RecordWildCards           #-}
  {-# LANGUAGE CPP                       #-}
  {-# LANGUAGE InstanceSigs              #-}
  {-# LANGUAGE ConstraintKinds           #-}
  
  module Transient.Internals where
  
  import           Control.Applicative
  import           Control.Monad.State
  import           Data.Dynamic
  import qualified Data.Map               as M
  import           System.IO.Unsafe
  import           Unsafe.Coerce
  import           Control.Exception hiding (try,onException)
  import qualified Control.Exception  (try)
  import           Control.Concurrent
  import           GHC.Conc(unsafeIOToSTM)
  import           Control.Concurrent.STM hiding (retry)
  import qualified Control.Concurrent.STM  as STM (retry)
  import           System.Mem.StableName
  import           Data.Maybe
  
  import           Data.List
  import           Data.IORef
  import           System.Environment
  import           System.IO
  
  import qualified Data.ByteString.Char8 as BS
  import           Data.Atomics
  
  #ifdef DEBUG
  
  import           Data.Monoid
  import           Debug.Trace
  import           System.Exit
  
  {-# INLINE (!>) #-}
  (!>) :: Show a => b -> a -> b
  (!>) x y =  trace (show y)  x 
  infixr 0 !>
  
  #else
  
  {-# INLINE (!>) #-}
  (!>) :: a -> b -> a
  (!>) = const
  
  
  #endif
  
  type SData= ()
  
  data LifeCycle = Alive | Parent | Listener | Dead
    deriving (Eq, Show)
  
  -- | EventF describes the context of a TransientIO computation:
  data EventF = EventF
    { mfData      :: M.Map TypeRep SData
      -- ^ State data accessed with get or put operations
  
    , mfSequence  :: Int
    , threadId    :: ThreadId
    , freeTh      :: Bool
      -- ^ When 'True', threads are not killed using kill primitives
  
    , parent      :: Maybe EventF
      -- ^ The parent of this thread
  
    , children    :: MVar [EventF]
      -- ^ Forked child threads, used only when 'freeTh' is 'False'
  
    , maxThread   :: Maybe (IORef Int)
      -- ^ Maximum number of threads that are allowed to be created
  
    , labelth     :: IORef (LifeCycle, BS.ByteString)
      -- ^ Label the thread with its lifecycle state and a label string
    } deriving Typeable
  
  newtype Transient r  a = Transient { runTransT :: (Maybe a -> StateIO  (Maybe r)) -> StateIO (Maybe r) }
  
  type StateIO = StateT EventF IO
  
  type TransIO   a= Transient a  a
  
  type TransientIO a= TransIO a
  
  --type Transient r  a= Transient r  a
  
  
  instance   Monad (Transient r) where
      return  = pure
      m >>= k  = Transient $ \c -> runTransT m (\a -> runTransT (mayb k a) c)
       where
       mayb k (Just x)= k x
       mayb _ Nothing =  empty
  
  instance MonadState  EventF (Transient r ) where
      get= liftt get -- where  lift m = Transient ((Just <$> m) >>=)
      put= liftt . put -- where  lift m = Transient ((Just <$> m) >>=)
  
  -- instance MonadTrans (Transient r) where
  liftt m = Transient ((Just <$> m) >>=)
  
  instance MonadIO (Transient r ) where
      liftIO = liftt . liftIO
  
  callCC :: ((a -> Transient r  b) -> Transient r  a) -> Transient r  a
  callCC f = Transient $ \ c -> runTransT (f (\ x -> Transient $ \ _ ->  c $ Just x)) c
  
  instance Functor (Transient r ) where
      fmap f m = Transient $ \c -> runTransT m $ \ mx->
               case mx of
                   Just x ->  c $ Just $ f x
                   Nothing ->  return Nothing
                   
  instance  Monoid a => Monoid (Transient r  a) where
      mappend x y = mappend <$> x <*> y
      mempty      = return mempty
  
  instance Applicative (Transient r ) where
      pure a  = Transient ($ Just a)
      -- f <*> v = Transient $ \ k -> runTransT f $ \ g -> runTransT v (k . g)
      f <*> v =   do
            r1 <- liftIO $ newIORef Nothing
            r2 <- liftIO $ newIORef Nothing
            fparallel r1 r2 <|> vparallel r1 r2
        where
  
        fparallel r1 r2= Transient $ \k  -> do
            runTransT f $ \mg -> do
                  liftIO $ writeIORef r1 mg !> "f write r1"
                  case mg of
                      Nothing -> return Nothing 
                      Just g   -> do 
                            mt <- liftIO $ readIORef r2  !> "f read r2"
                            case mt of
                              Nothing -> return Nothing 
                              Just t -> k . Just $ g t
  
        vparallel  r1 r2=  Transient $ \k  ->  do 
              runTransT v $ \mt ->  do
                   liftIO $ writeIORef r2 mt !> "v write r2"
                   mg <- liftIO $ readIORef r1 !> "v read r2"
                   case mg of 
                      Nothing -> return Nothing
                      Just g -> do
                                     case mt of
                                        Nothing -> return Nothing
                                        Just t -> k . Just $ g t 
  
  
  instance  Alternative (Transient r ) where
      empty=  Transient ( $  Nothing)
      f <|> g= Transient $ \ k ->do
                mr <- runTransT f k 
                case mr of 
                    Nothing  -> runTransT g k
                    justr -> return justr
  
  
  
  
  emptyEventF :: ThreadId -> IORef (LifeCycle, BS.ByteString) -> MVar [EventF] -> EventF
  emptyEventF th label childs =
    EventF { mfData     = mempty
           , mfSequence = 0
           , threadId   = th
           , freeTh     = False
           , parent     = Nothing
           , children   = childs
           , maxThread  = Nothing
           , labelth    = label }
  
  -- | Run a transient computation with a default initial state
  runTransient :: TransIO a -> IO (Maybe a, EventF)
  -- runTransient :: Transient r (StateT EventF IO) r -> IO (Maybe r, EventF)
  runTransient t = do
      th     <- myThreadId
      label  <- newIORef $ (Alive, BS.pack "top")
      childs <- newMVar []
      runTransState (emptyEventF th label childs) t
  
  runTransState :: EventF -> TransIO a ->  IO (Maybe a, EventF)
  runTransState st t= runStateT  (runTrans t) st
  
  runTrans :: TransIO  a -> StateIO (Maybe a)
  runTrans t= ((flip runTransT) (return . id)) t
  
  noTrans :: StateIO  a -> TransIO a
  noTrans x= Transient $ const $ x >>= return . Just
  
  readWithErr :: (Typeable a, Read a) => String -> IO [(a, String)]
  readWithErr line =
    (v `seq` return [(v, left)])
       `catch` (\(e :: SomeException) ->
                  error $ "read error trying to read type: \"" ++ show (typeOf v)
                       ++ "\" in:  " ++ " <" ++ show line ++ "> ")
    where [(v, left)] = readsPrec 0 line
  
  readsPrec' _ = unsafePerformIO . readWithErr
  
  -- | Constraint type synonym for a value that can be logged.
  type Loggable a = (Show a, Read a, Typeable a)
  
  -- | Dynamic serializable data for logging.
  data IDynamic =
      IDyns String
    | forall a. Loggable a => IDynamic a
  
  instance Show IDynamic where
    show (IDynamic x) = show (show x)
    show (IDyns    s) = show s
  
  instance Read IDynamic where
    readsPrec n str = map (\(x,s) -> (IDyns x,s)) $ readsPrec' n str
  
  type Recover        = Bool
  type CurrentPointer = [LogElem]
  type LogEntries     = [LogElem]
  
  data LogElem        =  Wait | Exec | Var IDynamic
    deriving (Read, Show)
  
  data Log            = Log Recover CurrentPointer LogEntries
    deriving (Typeable, Show)
  
  data RemoteStatus   = WasRemote | WasParallel | NoRemote
    deriving (Typeable, Eq, Show)
  
  -- | A synonym of 'empty' that can be used in a monadic expression. It stops
  -- the computation, which allows the next computation in an 'Alternative'
  -- ('<|>') composition to run.
  stop :: Alternative m => m stopped
  stop = empty
  
  --instance (Num a,Eq a,Fractional a) =>Fractional (Transient r a)where
  --     mf / mg = (/) <$> mf <*> mg
  --     fromRational (x:%y) =  fromInteger x % fromInteger y
  
  
  instance (Num a, Eq a) => Num (Transient r a) where
    fromInteger = return . fromInteger
    mf + mg     = (+) <$> mf <*> mg
    mf * mg     = (*) <$> mf <*> mg
    negate f    = f >>= return . negate
    abs f       = f >>= return . abs
    signum f    = f >>= return . signum
  
  class AdditionalOperators m where
  
    -- | Run @m a@ discarding its result before running @m b@.
    (**>)  :: m a -> m b -> m b
  
    -- | Run @m b@ discarding its result, after the whole task set @m a@ is
    -- done.
    (<**)  :: m a -> m b -> m a
  
    atEnd' :: m a -> m b -> m a
    atEnd' = (<**)
  
    -- | Run @m b@ discarding its result, once after each task in @m a@, and
    -- once again after the whole task set is done.
    (<***) :: m a -> m b -> m a
  
    atEnd  :: m a -> m b -> m a
    atEnd  = (<***)
  
  instance AdditionalOperators (Transient r )  where
  
    -- (**>) :: Transient r a -> Transient r b -> Transient r b
    (**>) f g =
        Transient $ \k ->  runTransT f $ \x -> runTransT g  k 
  
    -- (<***) :: Transient r a -> Transient r b -> Transient r a
    (<***) f g =
        Transient $ \k -> runTransT f $ \mx -> do
               case mx of
                   Nothing -> return Nothing
                   _ -> runTransT g (const $ return Nothing) >>  k mx
  
    -- (<**) :: Transient r a -> Transient r b -> Transient r a
    (<**) f g =
        Transient $ \k ->  runTransT f $ \mx -> do
               case mx of
                   Nothing -> return Nothing
                   _ -> runTransT g (const $ return Nothing) >>  k mx
  
  infixr 1 <***, <**, **>  
  
  
  
  
  -- * Threads
  
  waitQSemB   sem = atomicModifyIORefCAS sem $ \n ->
                      if n > 0 then(n - 1, True) else (n, False)
  signalQSemB sem = atomicModifyIORefCAS sem $ \n -> (n + 1, ())
  
  -- | Sets the maximum number of threads that can be created for the given task
  -- set.  When set to 0, new tasks start synchronously in the current thread.
  -- New threads are created by 'parallel', and APIs that use parallel.
  threads :: Int -> Transient r a -> Transient r a
  threads n process = do
     msem <- gets maxThread
     sem <- liftIO $ newIORef n
     modify $ \s -> s { maxThread = Just sem }
     r <- process <** (modify $ \s -> s { maxThread = msem }) -- restore it
     return r
  
  -- | Terminate all the child threads in the given task set and continue
  -- execution in the current thread. Useful to reap the children when a task is
  -- done.
  --
  oneThread :: Transient r a -> Transient r a
  oneThread comp = do
    st    <-  get
    chs   <- liftIO $ newMVar []
    label <- liftIO $ newIORef (Alive, BS.pack "oneThread")
    let st' = st { parent   = Just st
                , children = chs
                , labelth  = label }
    liftIO $ hangThread st st'
    put st'
    x   <- comp
    th  <- liftIO myThreadId
            -- !> ("FATHER:", threadId st)
    chs <- liftIO $ readMVar chs -- children st'
    liftIO $ mapM_ (killChildren1 th) chs
    return x
    where killChildren1 :: ThreadId  ->  EventF -> IO ()
          killChildren1 th state = do
            ths' <- modifyMVar (children state) $ \ths -> do
                      let (inn, ths')=  partition (\st -> threadId st == th) ths
                      return (inn, ths')
            mapM_ (killChildren1  th) ths'
            mapM_ (killThread . threadId) ths'
              -- !> ("KILLEVENT1 ", map threadId ths' )
  
  -- | Add a label to the current passing threads so it can be printed by debugging calls like `showThreads`
  labelState :: (MonadIO m,MonadState EventF m) => String -> m ()
  labelState l =  do
    st <- get
    liftIO $ atomicModifyIORefCAS (labelth st) $ \(status,_) -> ((status, BS.pack l), ())
  
  printBlock :: MVar ()
  printBlock = unsafePerformIO $ newMVar ()
  
  -- | Show the tree of threads hanging from the state.
  showThreads :: MonadIO m => EventF -> m ()
  showThreads st = liftIO $ withMVar printBlock $ const $ do
    mythread <- myThreadId
  
    putStrLn "---------Threads-----------"
    let showTree n ch = do
          liftIO $ do
            putStr $ take n $ repeat ' '
            (state, label) <- readIORef $ labelth ch
            if BS.null label
              then putStr . show $ threadId ch
              else do BS.putStr label; putStr . drop 8 . show $ threadId ch
                      when (state == Dead) $ putStr " dead"
            putStrLn $ if mythread == threadId ch then " <--" else ""
          chs <- readMVar $ children ch
          mapM_ (showTree $ n + 2) $ reverse chs
    showTree 0 st
  
  -- | Return the state of the thread that initiated the transient computation
  topState :: Transient r EventF
  topState = do
    st <- get
    return $ toplevel st
    where toplevel st = case parent st of
                          Nothing -> st
                          Just p  -> toplevel p
  
  -- | Return the state variable of the type desired with which a thread, identified by his number in the treee was initiated
  showState :: (Typeable a, MonadIO m, Alternative m) => String -> EventF -> m  (Maybe a)
  showState th top = resp
    where resp = do
            let thstring = drop 9 . show $ threadId top
            if thstring == th
            then getstate top
            else do
              sts <- liftIO $ readMVar $ children top
              foldl (<|>) empty $ map (showState th) sts
          getstate st =
              case M.lookup (typeOf $ typeResp resp) $ mfData st of
                Just x  -> return . Just $ unsafeCoerce x
                Nothing -> return Nothing
          typeResp :: m (Maybe x) -> x
          typeResp = undefined
  
  -- | Add n threads to the limit of threads. If there is no limit, the limit is set.
  addThreads' :: Int -> TransIO ()
  addThreads' n= noTrans $ do
    msem <- gets maxThread
    case msem of
      Just sem -> liftIO $ modifyIORef sem $ \n' -> n + n'
      Nothing  -> do
        sem <- liftIO (newIORef n)
        modify $ \ s -> s { maxThread = Just sem }
  
  -- | Ensure that at least n threads are available for the current task set.
  addThreads :: Int -> TransIO ()
  addThreads n = noTrans $ do
    msem <- gets maxThread
    case msem of
      Nothing  -> return ()
      Just sem -> liftIO $ modifyIORef sem $ \n' -> if n' > n then n' else  n
  
  --getNonUsedThreads :: Transient r (Maybe Int)
  --getNonUsedThreads= Transient $ do
  --   msem <- gets maxThread
  --   case msem of
  --    Just sem -> liftIO $ Just <$> readIORef sem
  --    Nothing -> return Nothing
  
  -- | Disable tracking and therefore the ability to terminate the child threads.
  -- By default, child threads are terminated automatically when the parent
  -- thread dies, or they can be terminated using the kill primitives. Disabling
  -- it may improve performance a bit, however, all threads must be well-behaved
  -- to exit on their own to avoid a leak.
  freeThreads :: Transient r a -> Transient r a
  freeThreads process =  do
    st <- get
    put st { freeTh = True }
    r  <-  process
    modify $ \s -> s { freeTh = freeTh st }
    return r
  
  -- | Enable tracking and therefore the ability to terminate the child threads.
  -- This is the default but can be used to re-enable tracking if it was
  -- previously disabled with 'freeThreads'.
  hookedThreads :: Transient r a -> Transient r a
  hookedThreads process =  do
    st <- get
    put st {freeTh = False}
    r  <-  process
    modify $ \st -> st { freeTh = freeTh st }
    return r
  
  -- | Kill all the child threads of the current thread.
  -- killChilds :: Transient r ()
  killChilds :: TransIO ()
  killChilds = noTrans $ do
    cont <- get
    liftIO $ do
      killChildren $ children cont
      writeIORef (labelth cont) (Alive, mempty)
         -- !> (threadId cont,"relabeled")
    return ()
  
  -- | Kill the current thread and the childs.
  killBranch :: TransIO ()
  killBranch = noTrans $ do
    st <- get
    liftIO $ killBranch' st
  
  -- | Kill the childs and the thread of an state
  killBranch' :: EventF -> IO ()
  killBranch' cont = do
    killChildren $ children cont
    let thisth  = threadId  cont
        mparent = parent    cont
    when (isJust mparent) $
      modifyMVar_ (children $ fromJust mparent) $ \sts ->
        return $ filter (\st -> threadId st /= thisth) sts
    killThread $ thisth
  
  -- * Extensible State: Session Data Management
  
  -- | Same as 'getSData' but with a more general type. If the data is found, a
  -- 'Just' value is returned. Otherwise, a 'Nothing' value is returned.
  getData :: (MonadState EventF m, Typeable a) => m (Maybe a)
  getData = resp
    where resp = do
            list <- gets mfData
            case M.lookup (typeOf $ typeResp resp) list of
              Just x  -> return . Just $ unsafeCoerce x
              Nothing -> return Nothing
          typeResp :: m (Maybe x) -> x
          typeResp = undefined
  
  -- | Retrieve a previously stored data item of the given data type from the
  -- monad state. The data type to retrieve is implicitly determined from the
  -- requested type context.
  -- If the data item is not found, an 'empty' value (a void event) is returned.
  -- Remember that an empty value stops the monad computation. If you want to
  -- print an error message or a default value in that case, you can use an
  -- 'Alternative' composition. For example:
  --
  -- > getSData <|> error "no data"
  -- > getInt = getSData <|> return (0 :: Int)
  getSData :: (Typeable r, Typeable a) => Transient r a
  getSData = Transient $ const getData 
  
  
  -- | Same as `getSData`
  getState :: Typeable a => TransIO a
  getState = getSData
  
  -- | 'setData' stores a data item in the monad state which can be retrieved
  -- later using 'getData' or 'getSData'. Stored data items are keyed by their
  -- data type, and therefore only one item of a given type can be stored. A
  -- newtype wrapper can be used to distinguish two data items of the same type.
  --
  -- @
  -- import Control.Monad.IO.Class (liftIO)
  -- import Transient.Base
  -- import Data.Typeable
  --
  -- data Person = Person
  --    { name :: String
  --    , age :: Int
  --    } deriving Typeable
  --
  -- main = keep $ do
  --      setData $ Person "Alberto"  55
  --      Person name age <- getSData
  --      liftIO $ print (name, age)
  -- @
  setData :: (MonadState EventF m, Typeable a) => a -> m ()
  setData x = modify $ \st -> st { mfData = M.insert t (unsafeCoerce x) (mfData st) }
    where t = typeOf x
  
  -- | Accepts a function that takes the current value of the stored data type
  -- and returns the modified value. If the function returns 'Nothing' the value
  -- is deleted otherwise updated.
  modifyData :: (MonadState EventF m, Typeable a) => (Maybe a -> Maybe a) -> m ()
  modifyData f = modify $ \st -> st { mfData = M.alter alterf t (mfData st) }
    where typeResp :: (Maybe a -> b) -> a
          typeResp   = undefined
          t          = typeOf (typeResp f)
          alterf mx  = unsafeCoerce $ f x'
            where x' = case mx of
                         Just x  -> Just $ unsafeCoerce x
                         Nothing -> Nothing
  
  -- | Same as modifyData
  modifyState :: (MonadState EventF m, Typeable a) => (Maybe a -> Maybe a) -> m ()
  modifyState = modifyData
  
  -- | Same as 'setData'
  setState :: (MonadState EventF m, Typeable a) => a -> m ()
  setState = setData
  
  -- | Delete the data item of the given type from the monad state.
  delData :: (MonadState EventF m, Typeable a) => a -> m ()
  delData x = modify $ \st -> st { mfData = M.delete (typeOf x) (mfData st) }
  
  -- | Same as 'delData'
  delState :: (MonadState EventF m, Typeable a) => a -> m ()
  delState = delData
  
  
  -- STRefs for the Transient monad
  
  newtype Ref a = Ref (IORef a)
  
  -- | mutable state reference that can be updated (similar to STRef in the state monad)
  --
  -- Initialized the first time it is set.
  setRState:: Typeable a => a -> Transient (Ref a)  ()
  setRState x= do
          Ref ref <- getSData
          liftIO $ atomicModifyIORefCAS ref $ const (x,())
     <|> do
          ref <- liftIO (newIORef x)
          setData $ Ref ref
    
  
  getRState :: Typeable a => Transient (Ref a)  a
  getRState= do
      Ref ref <- getSData
      liftIO $ readIORef ref
  
  delRState x= delState (undefined `asTypeOf` ref x)
    where ref :: a -> IORef a 
          ref= undefined
  
  -- | Run an action, if it does not succeed, undo any state changes
  -- that it might have caused and allow aternative actions to run with the original state
  try :: Transient r a -> Transient r a
  try mx = do
    sd <- gets mfData
    mx <|> (modify (\s -> s { mfData = sd }) >> empty)
  
  -- | Executes the computation and reset the state either if it fails or not. 
  sandbox :: Transient r a -> Transient r a
  sandbox mx = do
    sd <- gets mfData
    mx <*** modify (\s ->s { mfData = sd})
  
  -- | Generator of identifiers that are unique within the current monadic
  -- sequence They are not unique in the whole program.
  genId :: MonadState EventF m => m Int
  genId = do
    st <- get
    let n = mfSequence st
    put st { mfSequence = n + 1 }
    return n
  
  getPrevId :: MonadState EventF m => m Int
  getPrevId = gets mfSequence
  
  instance Read SomeException where
    readsPrec n str = [(SomeException $ ErrorCall s, r)]
      where [(s , r)] = read str
  
  -- | 'StreamData' represents a task in a task stream being generated.
  data StreamData a =
        SMore a               -- ^ More tasks to come
      | SLast a               -- ^ This is the last task
      | SDone                 -- ^ No more tasks, we are done
      | SError SomeException  -- ^ An error occurred
      deriving (Typeable, Show,Read)
  
  -- | An task stream generator that produces an infinite stream of tasks by
  -- running an IO computation in a loop. A task is triggered carrying the output
  -- of the computation. See 'parallel' for notes on the return value.
  -- waitEvents :: IO a -> Transient r a
  waitEvents io = do
    mr <- parallel (SMore <$> io)
    case mr of
      SMore  x -> return x
      SError e -> back   e
  
  -- | Run an IO computation asynchronously and generate a single task carrying
  -- the result of the computation when it completes. See 'parallel' for notes on
  -- the return value.
  -- async :: IO a -> Transient r a
  async io = do
    mr <- parallel (SLast <$> io)
    case mr of
      SLast  x -> return x
      SError e -> back   e
  
  -- | Force an async computation to run synchronously. It can be useful in an
  -- 'Alternative' composition to run the alternative only after finishing a
  -- computation.  Note that in Applicatives it might result in an undesired
  -- serialization.
  sync :: Transient r a -> Transient r a
  sync x = do
    setData WasRemote
    r <- x
    delData WasRemote
    return r
  
  -- | @spawn = freeThreads . waitEvents@
  spawn :: IO a -> Transient r a
  spawn = freeThreads . waitEvents
  
  -- | An task stream generator that produces an infinite stream of tasks by
  -- running an IO computation periodically at the specified time interval. The
  -- task carries the result of the computation.  A new task is generated only if
  -- the output of the computation is different from the previous one.  See
  -- 'parallel' for notes on the return value.
  -- sample :: Eq a => IO a -> Int -> Transient r a
  sample action interval = do
    v    <- liftIO action
    prev <- liftIO $ newIORef v
    waitEvents (loop action prev) <|> async (return v)
    where loop action prev = loop'
            where loop' = do
                    threadDelay interval
                    v  <- action
                    v' <- readIORef prev
                    if v /= v' then writeIORef prev v >> return v else loop'
  
  
  
  -- | Run an IO action one or more times to generate a stream of tasks. The IO
  -- action returns a 'StreamData'. When it returns an 'SMore' or 'SLast' a new
  -- task is triggered with the result value. If the return value is 'SMore', the
  -- action is run again to generate the next task, otherwise task creation
  -- stops.
  --
  -- Unless the maximum number of threads (set with 'threads') has been reached,
  -- the task is generated in a new thread and the current thread returns a void
  -- task.
  --parallel :: IO (StreamData b) -> Transient r StateIO (StreamData b)
  parallel ioaction = callCC $ \ret ->  do
        cont <- get
            --  !> "PARALLEL"
    
        liftIO $ atomicModifyIORefCAS (labelth cont) $ \(_, lab) -> ((Parent, lab), ())
        liftIO $ loop cont  ret ioaction
        was <- getData `onNothing` return NoRemote
        when (was /= WasRemote) $ setData WasParallel
  --            th <- liftIO myThreadId
  --            return () !> ("finish",th)
        empty
  
  -- | Execute the IO action and the continuation
  -- loop ::  EventF ->(StreamData a -> Transient r (StreamData a)) -> IO (StreamData t) -> IO ()
  loop parentc ret rec = forkMaybe parentc $ \cont -> do
    -- Execute the IO computation and then the closure-continuation
    liftIO $ atomicModifyIORefCAS (labelth cont) $ const ((Listener,BS.pack "wait"),())
    let loop'=   do
           mdat <- rec `catch` \(e :: SomeException) -> return $ SError e
           case mdat of
               se@(SError _)  -> setworker cont >> iocont  se    cont
               SDone          -> setworker cont >> iocont  SDone cont
               last@(SLast _) -> setworker cont >> iocont  last  cont
  
               more@(SMore _) -> do
                    forkMaybe cont $ iocont  more
                    loop'
  
           where
           setworker cont= liftIO $ atomicModifyIORefCAS (labelth cont) $ const ((Alive,BS.pack "work"),())
  
           iocont  dat cont = do
               runTransState cont  (ret dat )
               return ()
  
  
  
    loop'
    return ()
    where
    {-# INLINABLE forkMaybe #-}
    forkMaybe parent  proc = do
       case maxThread parent  of
         Nothing -> forkIt parent  proc
         Just sem  -> do
               dofork <- waitQSemB sem
               if dofork then  forkIt parent proc else proc parent
  
  
    forkIt parent  proc= do
       chs <- liftIO $ newMVar []
  
       label <- newIORef (Alive, BS.pack "work")
       let cont = parent{parent=Just parent,children=   chs, labelth= label}
  
       forkFinally1  (do
           th <- myThreadId
           let cont'= cont{threadId=th}
           when(not $ freeTh parent )$ hangThread parent   cont'
                                      -- !>  ("thread created: ",th,"in",threadId parent )
  
           proc cont')
           $ \me -> do
  
             case  me of
              Left e -> exceptBack cont e >> return ()
  
  
  
              _ -> do
               case maxThread cont of
                 Just sem -> signalQSemB sem      -- !> "freed thread"
                 Nothing -> return ()
               when(not $ freeTh parent  )  $ do -- if was not a free thread
  
                   th <- myThreadId
                   (can,label) <- atomicModifyIORefCAS (labelth cont) $ \(l@(status,label)) ->
                      ((if status== Alive then Dead else status, label),l)
  
  
                   when (can/= Parent ) $ free th parent
       return ()
  
  
    forkFinally1 :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
    forkFinally1 action and_then =
         mask $ \restore ->  forkIO $ Control.Exception.try (restore action) >>= and_then
         
  free th env= do
     --    return ()                                       !> ("freeing",th,"in",threadId env)
         let sibling=  children env
  
         (sbs',found) <- modifyMVar sibling $ \sbs -> do
                     let (sbs', found) = drop [] th  sbs
                     return (sbs',(sbs',found))
  
  
  
         if found
           then do
  
  --                                             !> ("new list for",threadId env,map threadId sbs')
             (typ,_) <- readIORef $ labelth env
             if (null sbs' && typ /= Listener && isJust (parent env))
              -- free the parent
              then free (threadId env) ( fromJust $ parent env)
              else return ()
  
  --               return env
           else return () -- putMVar sibling sbs
                                                       -- !>  (th,"orphan")
  
         where
         drop processed th []= (processed,False)
         drop processed th (ev:evts)| th ==  threadId ev= (processed ++ evts, True)
                                    | otherwise= drop (ev:processed) th evts
  
  
  
  hangThread parentProc child =  do
  
         let headpths= children parentProc
  
         modifyMVar_ headpths $ \ths -> return (child:ths)
  --       ths <- takeMVar headpths
  --       putMVar headpths (child:ths)
  
  
             --  !> ("hang", threadId child, threadId parentProc,map threadId ths,unsafePerformIO $ readIORef $ labelth parentProc)
  
  -- | kill  all the child threads associated with the continuation context
  killChildren childs  = do
  
  
             ths <- modifyMVar childs $ \ths -> return ([],ths)
  --           ths <- takeMVar childs
  --           putMVar childs []
  
             mapM_ (killChildren . children) ths
  
  
             mapM_ (killThread . threadId) ths  -- !> ("KILL", map threadId ths )
  
  
  
  
  
  -- | Make a transient task generator from an asynchronous callback handler.
  --
  -- The first parameter is a callback. The second parameter is a value to be
  -- returned to the callback; if the callback expects no return value it
  -- can just be a @return ()@. The callback expects a setter function taking the
  -- @eventdata@ as an argument and returning a value to the callback; this
  -- function is supplied by 'react'.
  --
  -- Callbacks from foreign code can be wrapped into such a handler and hooked
  -- into the transient monad using 'react'. Every time the callback is called it
  -- generates a new task for the transient monad.
  --
  
  react 
    :: ((eventdata ->  IO response) -> IO ())
    -> IO  response
    -> Transient r eventdata
  react setHandler iob= callCC $ \ret -> do
              st <- get
              liftIO $ setHandler $  \x ->  (runTransState st $ ret x) >> iob
              empty
  
  -- | Runs a computation asynchronously without generating any events. Returns
  -- 'empty' in an 'Alternative' composition.
  
  abduce = async $ return ()
  
  
  
  -- * non-blocking keyboard input
  
  getLineRef= unsafePerformIO $ newTVarIO Nothing
  
  
  roption= unsafePerformIO $ newMVar []
  
  -- | Waits on stdin in a loop and triggers a new task every time the input data
  -- matches the first parameter.  The value contained by the task is the matched
  -- value i.e. the first argument  itself. The second parameter is a label for
  -- the option. The label is displayed on the console when the option is
  -- activated.
  --
  -- Note that if two independent invocations of 'option' are expecting the same
  -- input, only one of them gets it and triggers a task. It cannot be
  -- predicted which one gets it.
  --
  option :: (Typeable b, Show b, Read b, Eq b) =>
        b -> String -> Transient r  b
  option ret message= do
      let sret= show ret
      liftIO $ putStrLn $ "Enter  " ++ sret ++ "\tto: " ++ message
      liftIO $ modifyMVar_ roption $ \msgs-> return $ sret:msgs
      unsafeCoerce $ waitEvents $ getLine' (==ret)
      liftIO $ putStr "\noption: " >> putStrLn (show ret)
      return ret
  
  
  -- | Waits on stdin and triggers a task when a console input matches the
  -- predicate specified in the first argument.  The second parameter is a string
  -- to be displayed on the console before waiting.
  --
  --input ::  (Typeable a, Read a,Show a) => (a -> Bool) -> String -> Transient r StateIO a
  input cond prompt= input' Nothing cond prompt
  
  --input' :: (Typeable a, Read a,Show a) => Maybe a -> (a -> Bool)
  --       -> String -> Transient r StateIO a
  input' mv cond prompt= Transient . const $ liftIO $do
     putStr prompt >> hFlush stdout
     atomically $ do
         mr <- readTVar getLineRef
         case mr of
           Nothing -> STM.retry
           Just r ->
              case reads2 r  of
              (s,_):_ -> if cond s    !> show (cond s)
                       then do
                         unsafeIOToSTM $ print s
                         writeTVar  getLineRef Nothing  !>"match"
                         return $ Just s
  
                       else return mv
              _ -> return mv !> "return "
  
     where
     reads2 s= x where
        x= if typeOf(typeOfr x) == typeOf "" 
             then unsafeCoerce[(s,"")] 
             else unsafePerformIO $ return (reads s) `catch` \(e :: SomeException) -> (return [])
  
     typeOfr :: [(a,String)] ->  a
     typeOfr  = undefined
  
  -- | Non blocking `getLine` with a validator
  getLine' :: (Typeable a,Read a) => (a -> Bool) -> IO a
  getLine' cond=    do
       atomically $ do
         mr <- readTVar getLineRef
         case mr of
           Nothing -> STM.retry
           Just r ->
              case reads1 r of --  !> ("received " ++  show r ++ show (unsafePerformIO myThreadId)) of
              (s,_):_ -> if cond s -- !> show (cond s)
                       then do
                         writeTVar  getLineRef Nothing -- !>"match"
                         return s
  
                       else STM.retry
              _ -> STM.retry
  
  reads1 s=x where
        x= if typeOf(typeOfr x) == typeOf "" then unsafeCoerce[(s,"")] else readsPrec' 0 s
        typeOfr :: [(a,String)] ->  a
        typeOfr  = undefined
  
  
  inputLoop :: IO ()
  inputLoop= do
             r <- getLine
             -- XXX hoping that the previous value has been consumed by now.
             -- otherwise its just lost by overwriting.
             atomically $ writeTVar getLineRef Nothing
             processLine r
             inputLoop
  
  processLine r= do
  
     let rs = breakSlash [] r
  
     -- XXX this blocks forever if an input is not consumed by any consumer.
     -- e.g. try this "xxx/xxx" on the stdin
     liftIO $ mapM_ (\ r ->
                   atomically $ do
  --                    threadDelay 1000000
                      t <- readTVar getLineRef
                      when (isJust  t) STM.retry
                      writeTVar  getLineRef $ Just r ) rs
  
  
      where
      breakSlash :: [String] -> String -> [String]
      breakSlash [] ""= [""]
      breakSlash s ""= s
      breakSlash res ('\"':s)=
        let (r,rest) = span(/= '\"') s
        in breakSlash (res++[r]) $ tail1 rest
  
      breakSlash res s=
        let (r,rest) = span(\x -> x /= '/' && x /= ' ') s
        in breakSlash (res++[r]) $ tail1 rest
  
      tail1 []=[]
      tail1 x= tail x
  
  
  
  
  -- | Wait for the execution of `exit` and return the result or the exhaustion of thread activity
  
  stay rexit=  takeMVar rexit
   `catch` \(e :: BlockedIndefinitelyOnMVar) -> return Nothing
  
  newtype Exit a= Exit a deriving Typeable
  
  -- | Runs the transient computation in a child thread and keeps the main thread
  -- running until all the user threads exit or some thread invokes 'exit'.
  --
  -- The main thread provides facilities to accept keyboard input in a
  -- non-blocking but line-oriented manner. The program reads the standard input
  -- and feeds it to all the async input consumers (e.g. 'option' and 'input').
  -- All async input consumers contend for each line entered on the standard
  -- input and try to read it atomically. When a consumer consumes the input
  -- others do not get to see it, otherwise it is left in the buffer for others
  -- to consume. If nobody consumes the input, it is discarded.
  --
  -- A @/@ in the input line is treated as a newline.
  --
  -- When using asynchronous input, regular synchronous IO APIs like getLine
  -- cannot be used as they will contend for the standard input along with the
  -- asynchronous input thread. Instead you can use the asynchronous input APIs
  -- provided by transient.
  --
  -- A built-in interactive command handler also reads the stdin asynchronously.
  -- All available commands handled by the command handler are displayed when the
  -- program is run.  The following commands are available:
  --
  -- 1. @ps@: show threads
  -- 2. @log@: inspect the log of a thread
  -- 3. @end@, @exit@: terminate the program
  --
  -- An input not handled by the command handler can be handled by the program.
  --
  -- The program's command line is scanned for @-p@ or @--path@ command line
  -- options.  The arguments to these options are injected into the async input
  -- channel as keyboard input to the program. Each line of input is separated by
  -- a @/@. For example:
  --
  -- >  foo  -p  ps/end
  --
  keep :: Typeable a => Transient r a -> IO (Maybe a)
  keep mx = do
  
     liftIO $ hSetBuffering stdout LineBuffering
     rexit <- newEmptyMVar
     forkIO $ do
  --       liftIO $ putMVar rexit  $ Right Nothing
         runTransient $ do
             st <- get
             setData $ Exit rexit
             do abduce
                labelState "input"
                liftIO inputLoop
                
             
             
  
              <|> do
                     option "ps" "show threads"
                     liftIO $ showThreads st
                     
              <|> do
                     option "log" "inspect the log of a thread"
                     th <- input (const True)  "thread number>"
                     ml <- liftIO $ showState th st
                     liftIO $ print $ fmap (\(Log _ _ log) -> reverse log) ml
                     
              <|> do
                     option "end" "exit"
                     killChilds
                     liftIO $ putMVar rexit Nothing
                     
              <|> unsafeCoerce mx
         return ()
     threadDelay 10000
     execCommandLine
     stay rexit
  
     where
     type1 :: Transient r a -> Either String (Maybe a)
     type1= undefined
  
  -- | Same as `keep` but does not read from the standard input, and therefore
  -- the async input APIs ('option' and 'input') cannot be used in the monad.
  -- However, keyboard input can still be passed via command line arguments as
  -- described in 'keep'.  Useful for debugging or for creating background tasks,
  -- as well as to embed the Transient monad inside another computation. It
  -- returns either the value returned by `exit`.  or Nothing, when there are no
  -- more threads running
  --
  keep' :: Typeable a => TransIO a -> IO  (Maybe a)
  keep' mx  = do
     liftIO $ hSetBuffering stdout LineBuffering
     rexit <- newEmptyMVar
     forkIO $ do
             runTransient $ do
                setData $ Exit rexit
                mx
  
             return ()
     threadDelay 10000
     forkIO $ execCommandLine
     stay rexit
  
  
  execCommandLine= do
     args <- getArgs
     let mindex =  findIndex (\o ->  o == "-p" || o == "--path" ) args
     when (isJust mindex) $ do
          let i= fromJust mindex +1
          when (length  args >= i) $ do
            let path= args !! i
            putStr "Executing: " >> print  path
            processLine  path
  
  -- | Exit the main thread, and thus all the Transient threads (and the
  -- application if there is no more code)
  -- exit :: Typeable a => a -> Transient r a
  exit x= do
    Exit rexit <- getSData <|> error "exit: not the type expected"  `asTypeOf` type1 x
    liftIO $  putMVar  rexit  $ Just x
    stop
    where
    type1 :: a -> Transient r (Exit (MVar (Maybe a)))
    type1= undefined
  
  
  
  -- | If the first parameter is 'Nothing' return the second parameter otherwise
  -- return the first parameter..
  onNothing :: Monad m => m (Maybe b) -> m b -> m b
  onNothing iox iox'= do
         mx <- iox
         case mx of
             Just x -> return x
             Nothing -> iox'
  
  
  
  
  
  ----------------------------------backtracking ------------------------
  
  
  data Backtrack b= forall a r c. Backtrack{backtracking :: Maybe b
                                       ,backStack :: [(b ->Transient r c,c -> Transient r a)] }
                                       deriving Typeable
  
  
  
  -- | Delete all the undo actions registered till now for the given track id.
  -- backCut :: (Typeable b, Show b) => b -> Transient r ()
  backCut reason=
       delData $ Backtrack (Just reason)  [] 
  
  -- | 'backCut' for the default track; equivalent to @backCut ()@.
  undoCut ::  Transient r ()
  undoCut = backCut ()
  
  -- | Run the action in the first parameter and register the second parameter as
  -- the undo action. On undo ('back') the second parameter is called with the
  -- undo track id as argument.
  --
  {-# NOINLINE onBack #-}
  onBack :: (Typeable b, Show b) => Transient r a -> ( b -> Transient r a) -> Transient r a
  onBack ac back =  do
       -- Backtrack mreason _  <- getData `onNothing` backStateOf (typeof bac) !> "HANDLER1"
      -- r <-ac
      --  case mreason  !> ("mreason",mreason) of
      --               Nothing     -> ac
      --               Just reason -> bac reason
       registerBack  ac back
    
     where
           
     typeof :: (b -> Transient r a) -> b
     typeof = undefined
  
  -- | 'onBack' for the default track; equivalent to @onBack ()@.
  onUndo ::  Transient r a -> Transient r a -> Transient r a
  onUndo x y= onBack x (\() -> y)
  
  
  
  -- | Register an undo action to be executed when backtracking. The first
  -- parameter is a "witness" whose data type is used to uniquely identify this
  -- backtracking action. The value of the witness parameter is not used.
  --
  --{-# NOINLINE registerUndo #-}
  -- registerBack :: (Typeable a, Show a) => (a -> Transient r a) -> a -> Transient r a
  registerBack  ac back = callCC $ \k -> do
     md <- getData `asTypeOf` (Just <$> (backStateOf $ typeof back))  !> "HANDLER"
     case md of
          Just (bss@(Backtrack b (bs@((back',_):_)))) ->
            --  when (isNothing b) $ do
            --      addrx  <- addr back'
            --      addrx' <- addr back        -- to avoid duplicate backtracking points
            --      when (addrx /= addrx') $ do return () !> "ADD"; setData $ Backtrack mwit  ( (back,  k):   unsafeCoerce bs)
             setData $  Backtrack b  ( (back,  k):   unsafeCoerce bs)
          Just (Backtrack b []) -> setData $ Backtrack b  [(back , k)]
          Nothing ->  do
             setData $ Backtrack mwit  [  (back , k)]    -- !> "NOTHING"
     ac
    
     where
  
  
     typeof :: (b -> Transient r a) -> b
     typeof = undefined
     mwit= Nothing `asTypeOf` (Just $ typeof back)
     addr x = liftIO $ return . hashStableName =<< (makeStableName $! x)
  
  
  -- registerUndo :: Transient r a -> Transient r a
  -- registerUndo f= registerBack ()  f
  
  -- XXX Should we enforce retry of the same track which is being undone? If the
  -- user specifies a different track would it make sense?
  --
  -- | For a given undo track id, stop executing more backtracking actions and
  -- resume normal execution in the forward direction. Used inside an undo
  -- action.
  --
  forward :: (Typeable b, Show b) => b -> Transient r ()
  forward reason=  do
      Backtrack _ stack <- getData `onNothing`  (backStateOf reason)
      setData $ Backtrack(Nothing `asTypeOf` Just reason)  stack
  
  
  -- |  To be used with `undo´
  retry= forward ()
  
  
  -- | Start the undo process for the given undo track id. Performs all the undo
  -- actions registered till now in reverse order. An undo action can use
  -- 'forward' to stop the undo process and resume forward execution. If there
  -- are no more undo actions registered execution stops and a 'stop' action is
  -- returned.
  --
  back :: (Typeable b, Show b) => b -> Transient r a
  back reason = do
    Backtrack _ cs <- getData  `onNothing`  backStateOf  reason
    let  bs= Backtrack (Just reason) cs
    setData bs
    goBackt bs           
                                                      !>"GOBACK"
  
    where
  
    goBackt (Backtrack _ [] )= empty                       !> "END"
    goBackt (Backtrack Nothing _ )= error "goback: no reason"
  
    goBackt (Backtrack (Just reason) ((handler,cont) : bs))= do
          
          -- setData $ Backtrack (Just reason) $ tail stack
          -- unsafeCoerce $ first reason !>  "GOBACK2"
          x <- unsafeCoerce handler reason                                        -- !> ("RUNCLOSURE",length stack)
  
          Backtrack mreason _ <- getData `onNothing`  backStateOf  reason
          -- setData $ Backtrack mreason bs
          --                                                          -- !> "END RUNCLOSURE"
  
          -- case mr of
          --    Nothing -> return empty                                     --  !> "END EXECUTION"
          case mreason of
                    Nothing    -> do 
                           --setData $ Backtrack Nothing bs
                           unsafeCoerce $ cont x                          !> "FORWARD EXEC"
                    justreason -> do
                          setData $ Backtrack justreason bs
                          goBackt $ Backtrack justreason bs              !> ("BACK AGAIN")
                          empty
  
  backStateOf :: (Monad m, Show a, Typeable a) => a -> m (Backtrack a)
  backStateOf reason= return $ Backtrack (Nothing `asTypeOf` (Just reason)) []
  
  
  -- | 'back' for the default undo track; equivalent to @back ()@.
  --
  undo ::  Transient r a
  undo= back ()
  
  
  ------ finalization
  
  newtype Finish= Finish String deriving Show
  
  instance Exception Finish 
  
  -- newtype FinishReason= FinishReason (Maybe SomeException) deriving (Typeable, Show)
  
  -- | Clear all finish actions registered till now.
  -- initFinish= backCut (FinishReason Nothing)
  
  -- | Register an action that to be run when 'finish' is called. 'onFinish' can
  -- be used multiple times to register multiple actions. Actions are run in
  -- reverse order. Used in infix style.
  --
  onFinish :: (Finish ->TransIO ()) -> TransIO ()
  onFinish f= onException' (return ()) f
  
  
  -- | Run the action specified in the first parameter and register the second
  -- parameter as a finish action to be run when 'finish' is called. Used in
  -- infix style.
  --
  onFinish' ::TransIO a ->(Finish ->TransIO a) -> TransIO a
  onFinish' proc f= proc `onException'` f
  
  
  -- | Execute all the finalization actions registered up to the last
  -- 'initFinish', in reverse order and continue the execution.  Either an exception or 'Nothing' can be
  initFinish = cutExceptions
  -- passed to 'finish'.  The argument passed is made available in the 'onFinish'
  -- actions invoked. 
  --
  finish :: String -> Transient r ()
  finish reason= (throwt $ Finish reason) <|> return()
  
  
  noFinish= forward $ Finish ""
  
  -- | trigger finish when the stream of data ends
  checkFinalize v=
     case v of
        SDone ->  stop
        SLast x ->  return x
        SError e -> throwt  e
        SMore x -> return x
  
  ------ exceptions ---
  --
  -- | Install an exception handler. Handlers are executed in reverse (i.e. last in, first out) order when such exception happens in the
  -- continuation. Note that multiple handlers can be installed for the same exception type.
  --
  -- The semantic is thus very different than the one of `Control.Exception.Base.onException`
  onException :: Exception e => (e -> TransIO ()) -> TransIO ()
  onException exc= return () `onException'` exc
  
  
  onException' :: Exception e => TransIO a -> (e -> TransIO a) -> TransIO a
  onException' mx f= onAnyException mx $ \e ->
      case fromException e of
         Nothing -> return $ error "do nothing,this should not be evaluated"
         Just e'  -> f e'
    where
    --onAnyException :: Transient r a -> (SomeException ->Transient r a) -> Transient r a
    onAnyException mx f= ioexp `onBack` f
      where 
      ioexp = callCC $ \cont -> do
         st <- get
         ioexp' $ runTransState st (mx >>=cont ) `catch` exceptBack st
      
      ioexp' mx= do
        (mx,st') <- liftIO  mx
        put st'
        case mx of
          Nothing -> empty 
          Just x  -> return x
    
  exceptBack st = \(e ::SomeException) -> do  -- recursive catch itself
                        return () !> "CATCHHHHHHHHHHHHH" 
                        runTransState st  (back e ) 
                  `catch` exceptBack st
  
  
    
  
  -- | Delete all the exception handlers registered till now.
  cutExceptions :: Transient r ()
  cutExceptions= backCut  (undefined :: SomeException)
  
  -- | Use it inside an exception handler. it stop executing any further exception
  -- handlers and resume normal execution from this point on.
  continue :: Transient r ()
  continue = forward (undefined :: SomeException) !> "CONTINUE"
  
  -- | catch an exception in a Transient block
  --
  -- The semantic is the same than `catch` but the computation and the exception handler can be multirhreaded
  -- catcht1 mx exc= mx' `onBack` exc
  --  where
  --  mx'= Transient $ const $do
  --   st <- get
  --   (mx, st) <- liftIO $ runTransState st mx `catch` exceptBack st
  --   put st 
  --   return mx
  
  
  catcht :: Exception e => TransIO a -> (e -> TransIO a) -> TransIO a
  catcht mx exc= do
        rpassed <- liftIO $ newIORef False
        sandbox  $ do
           delData $ Backtrack (Just (undefined :: SomeException))  [] 
  
           r <- onException'  mx $ \e -> do
                    passed <- liftIO $ readIORef rpassed
                    if not passed then unsafeCoerce continue >> exc e  else empty
           liftIO $ writeIORef rpassed True
           return r
           
     where
     sandbox :: Transient r a -> Transient r a
     sandbox  mx= do
       exState <- getData `onNothing` backStateOf (undefined :: SomeException)
       mx   <*** setState exState 
  
  -- | throw an exception in the Transient monad
  throwt :: Exception e => e -> Transient r a
  throwt= back . toException
  
  
  