Optimized, simplified continuation monad that implement all the Transient effects (except logging and distributed computing), with mockup implementation of some of them (https://github.com/transient-haskell/transient)

Transient.cont.hs

{-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification, ScopedTypeVariables, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}
import Control.Applicative
import Control.Monad.IO.Class
import Control.Monad.Trans
import GHC.Conc
import System.IO.Unsafe
import Data.IORef
import Control.Concurrent.MVar
import qualified Data.Map as M 
import Data.Typeable
import qualified Data.ByteString.Char8 as BS
import Control.Monad.State 
import Data.Monoid
import Unsafe.Coerce
import System.Mem.StableName
import Control.Exception hiding (onException)

import Debug.Trace
x !> y=  trace (show y) x
infixr 0 !>


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

-- Type coercion is necessary because continuations can only be modeled fully within Indexed monads. 
-- See paper P. Wadler "Monads and composable continuations" 
-- The symtom of that problem in the typical continaution monad is an extra parameter r that complicates reasoning
-- This monad eliminates the extra parameter by coercing types since, by construction, the contination parameter is of the
--  type of the result of the first term of the bind.
ety :: a -> b 
ety=   dontWorryEverithingisOk
tdyn :: a -> Dyn
tdyn=  dontWorryEverithingisOk
fdyn :: Dyn -> a
fdyn = dontWorryEverithingisOk

dontWorryEverithingisOk= unsafeCoerce

type Dyn= ()

data Transient m a = Transient { runTransT :: (Dyn -> m   a) -> m   a }


type StateIO = StateT EventF IO

type TransIO  = Transient  StateIO 

instance   Monad TransIO  where
    return  = pure
    m >>= k  = Transient $ \c -> ety $ runTransT m (\x -> ety $ runTransT ( k $ fdyn x) c)


instance MonadState  EventF TransIO where
    get= lift get
    put= lift . put

instance MonadTrans (Transient ) where
    lift m = Transient ((unsafeCoerce m) >>=)

instance MonadIO TransIO  where
    liftIO = lift . liftIO

callCC :: ((a -> Transient  m b) -> Transient  m a) -> Transient  m a
callCC f = Transient $ \ c -> runTransT (f (\ x -> Transient $ \ _ ->  ety $ c $ tdyn x)) c

instance Functor (Transient  m) where
    fmap f m = Transient $ \c -> ety $ runTransT m $ \ x->   ety c $ f $ fdyn x
                 
instance Monoid a => Monoid (TransIO a) where
    mappend x y = mappend <$> x <*> y
    mempty      = return mempty

instance Applicative TransIO  where
    pure a  = Transient ($  tdyn a)
    --f <*> v = ety $ Transient $ \ k -> ety $ runTransT f $ \ g -> ety $ runTransT v $ \t -> k $ (ety g) t
    f <*> v =   do
          r1 <- liftIO $ newIORef Nothing
          r2 <- liftIO $ newIORef Nothing
          (fparallel r1 r2)  <|> (vparallel  r1 r2)
      where

      fparallel :: IORef (Maybe(a -> b)) -> IORef (Maybe a) -> TransIO b 
      fparallel r1 r2= ety $ Transient $ \k  -> 
          runTransT f $ \g -> do
                (liftIO $ writeIORef r1  $ Just (fdyn  g)) !> "f write r1"
                mt <- liftIO $ readIORef r2  !> "f read r2"
                case mt of 
                  Just t -> k $ (fdyn g) t
                  Nothing -> get >>= liftIO . throw . Empty 
                  
      vparallel :: IORef (Maybe(a -> b)) -> IORef (Maybe a) -> TransIO b
      vparallel  r1 r2=  ety $ Transient $ \k  ->  
          runTransT v $ \t ->  do
                 (liftIO $ writeIORef r2 $ Just (fdyn t)) !> "v write r2"
                 mg <- liftIO $ readIORef r1 !> "v read r1"
                 case mg of 
                   Nothing -> get >>= liftIO . throw . Empty  
                   Just g ->  k $ (ety g) t 

-- sempty c= do
--     gs <- gets alternative
--     modify $ \s -> s{alternative= tail $ alternative s}
--     let (g,_)= head gs
--     runTransT (ety g)  c 

newtype Empty= Empty EventF deriving Typeable
instance Show Empty where show _= "Empty"
instance Exception Empty

instance  Alternative TransIO where
    -- empty=  do
    --     gs <- gets alternative
    --     modify $ \s -> s{alternative= tail $ alternative s}
    --     let (g,c) = head gs
    --     ety $ g >>=c

          -- get >>= liftIO . throw . Empty  --Transient ( $  throw Empty)
    -- f <|> g = ety $ do
    --     callCC $ \cont -> do
    --         modify $ \s ->  s{alternative= (ety g,cont):alternative s} 
    --         ety $ f <** (modify $ \s -> s{alternative= tail $ alternative s})

    empty= get >>= liftIO . throw . Empty 
    f <|>  g= callCC $ \k -> do
         st <- get
         (x,st'') <-  liftIO $ io st f k  `catch` (\(Empty st') -> io st' g k)
         put st''
         return x
      where
      io st f cont=   runTransState st (f >>= cont ) 
              
      
      
      -- 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 ( 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 ( a, EventF)
runTransState st t= runStateT  (runTrans t) st 
  where
  runTrans :: TransIO a -> StateIO  a
  runTrans t=   runTransT  t  (return . ety id )
  
inputLoop= getLine >>= \l -> atomically (writeTVar mvline l)  >> inputLoop

no = unsafePerformIO newEmptyMVar

mvline= unsafePerformIO $  newTVarIO ""

option :: String -> TransIO  String
--option :: [Char] -> Transient r (StateT t IO) [Char]
option s = waitEvents . atomically $ do
              x <- readTVar mvline
              if  x== s then  writeTVar mvline "" >> return s else GHC.Conc.retry               

-- callCC :: ((a -> Transient r StateIO b) -> Transient r m a) -> Transient r m a

async :: IO a -> TransIO a 
async io= callCC $ \ret -> do
            st <-  get
            liftIO $ forkIO $ runTransState st ( liftIO io >>= ret ) >> return () 
            empty 

waitEvents :: IO a -> TransIO a
--waitEvents :: IO a -> Transient a (StateIO) a
waitEvents io= callCC $ \ret -> do
    st <- get 
    loop ret st 
    where
    loop ret st=  do
            liftIO $ forkIO $ do 
                      runTransState st  (liftIO io >>=  ret  >> loop ret st)
                      return () 
            empty



mainReact = do
  -- forkIO inputLoop
   forkIO reactLoop
   runTransient $ do
        r <-  (reactOption "hello")  <>  (reactOption "world")
        liftIO $ print r 
        
        empty
   takeMVar no


   
   
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
  -- every time that an event happens in @m a@
  (<***) :: m a -> m b -> m a

  atEnd  :: m a -> m b -> m a
  atEnd  = (<***)

instance AdditionalOperators (Transient StateIO)  where

  -- (**>) :: TransIO a -> TransIO b -> TransIO b
  (**>) f g =  Transient $ \c -> ety $ runTransT f (\x -> ety $ runTransT  g c)
      

  -- (<***) :: TransIO a -> TransIO b -> TransIO a
  (<***) f g = 
      ety $ Transient $ \k -> ety $ runTransT f $ \x ->  ety $ runTransT g  (\_ -> k x)   
      where 
      f' = callCC $ \c -> g >> c ()

  -- (<**) :: TransIO a -> TransIO b -> TransIO a
  (<**) f g = ety $ Transient $ \k -> ety $ runTransT f $ \x ->  ety $ runTransT g  (\_ -> k x)  
--f >>= g   = Transient $ \k ->  runTransT f $ \x -> ety $ runTransT ( g $ unsafeCoerce x) k
  

infixr 1 <***, <**, **>   


react 
  :: ((eventdata ->  IO response) -> IO ())
  -> IO  response
  -> TransIO eventdata
react setHandler iob= callCC $ \ret -> do
            st <- get
            liftIO $ setHandler $  \x ->  (runTransState st $ ret x) >> iob
            empty

reactOption :: String -> TransIO String
reactOption s = do 
         x <- react setCallback (return ())
         if  x /= s then empty else do 
            --   liftIO $ atomically $ writeTVar mvline ""
               return s
  

reactLoop =  do
          x   <- getLine -- atomically $ readTVar mvline
          mbs <- readIORef rcb
          mapM (\cb -> cb x)  mbs
          reactLoop

rcb= unsafePerformIO $ newIORef [] 

setCallback :: (String ->  IO ()) -> IO ()
setCallback cb= atomicModifyIORef rcb $ \cbs ->  (reverse $ cb : cbs,())


----------------------------------backtracking ------------------------


data Backtrack b= forall a r c. Backtrack{backtracking :: Maybe b
                                     ,backStack :: [(b ->TransIO  c,c -> TransIO  a)] }
                                     deriving Typeable



-- | Delete all the undo actions registered till now for the given track id.
-- backCut :: (Typeable b, Show b) => b -> TransIO ()
backCut reason=
     delData $ Backtrack (Just reason)  [] 

-- | 'backCut' for the default track; equivalent to @backCut ()@.
undoCut ::  TransIO ()
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) => TransIO a -> ( b -> TransIO a) -> TransIO 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 -> TransIO a) -> b
   typeof = undefined

-- | 'onBack' for the default track; equivalent to @onBack ()@.
onUndo ::  TransIO a -> TransIO a -> TransIO 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 -> TransIO a) -> a -> TransIO 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 -> TransIO a) -> b
   typeof = undefined
   mwit= Nothing `asTypeOf` (Just $ typeof back)
   addr x = liftIO $ return . hashStableName =<< (makeStableName $! x)


-- registerUndo :: TransIO a -> TransIO 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 -> TransIO ()
forward reason=  do
    Backtrack _ stack <- getData `onNothing`  (backStateOf reason)
    setData $ Backtrack(Nothing `asTypeOf` Just reason)  stack






-- | 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 -> TransIO 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)) []



------ 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 :: TransIO a -> (SomeException ->TransIO a) -> TransIO 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 :: TransIO ()
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 :: TransIO ()
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 :: TransIO a -> TransIO a
   sandbox  mx= do
     exState <- getData `onNothing` backStateOf (undefined :: SomeException)
     mx   <*** setState exState 

-- | throw an exception in the Transient monad
throwt :: Exception e => e -> TransIO a
throwt= back . toException


-- * 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 a => TransIO a
getSData =   Transient $ const  $ do
        mx <- getData
        case mx of
          Nothing -> empty
          Just x  -> return x

-- | 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


-- | 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'


mainBack = do

   runTransient $ do
        return () !> "before"
        r <-  async (print "hello")  `onBack` \s ->  liftIO $ print $ "received: 111"++ s 
        r <-  async (print "world")  `onBack` \s ->  liftIO $ print $ "received: 222"++ s 

        back "exception"
        empty
   takeMVar no


main1= do
   runTransient $ do
        return () !> "before"
        onException $ \(s :: SomeException) -> liftIO $  print $ "received: 111"++ show s 
        async $ print "$$$$$$$$$$$$"
        -- r <-  async (print "hello")  `onException'` \(s :: SomeException) -> liftIO $  print $ "received: 111"++ show s 
        -- r <-  async (print "world")  `onException'` \(s :: SomeException) -> liftIO $  print $ "received: 222"++ show s 
        liftIO $ print "AFTER"
        liftIO $ myThreadId >>= print

        error "exception"
   takeMVar no

mainCatch= do
   runTransient $ do
        async $ print "hello"
        error "error" 
        return ()
      `catcht` (\(e :: SomeException) -> liftIO $ print $ "RECEIVED " ++ show e)
      
   takeMVar no


   

main2= runTransient $ do
  r  <- return 2
  r' <- liftIO $ return $ r +5
  r2 <- callCC $ \ret -> do 
     ret  100
     liftIO  $ print "HELLO"
     return 1
  liftIO $ print $ r2
  liftIO $ print $ "world3"


main= keep $ do
    -- r<- async ( return "hello") <***  liftIO (print "world")
    r <-  ( async (threadDelay 10000 >> return "hello ")  <>  return "world"     )  <|> return "world2"
    -- r <- Transient $ \c -> runTransT  (return "hello") c
    liftIO $ putStrLn  r

mexit= unsafePerformIO $ newEmptyMVar  
keep mx= do
   forkIO $( runTransient mx  >> return ()) `catch` \(Empty _) -> return ()
   takeMVar mexit