gistfile1.md

In haskell, continuations have been right in front of your eyes all the time, Use then to undo actions by means of the backtracking effect added to the the hardworking programmer EDSL.

#A word on continuations# In Haskell, the continuation is the second parameter in the bind operation. While most languages that use imperative and eager execution have to resort to continuations to implement special kinds of flows -so the continuation play a central role in them- haskell has not such problem: It uses continuations natively; The monad instance define what each kind of computation has to do with these continuations.

a bind has two parameters: a closure and a continuation.

 x >>=(f1>>=(f2 >>=f3))

So at every moment you know what is the continuation. In any monad. You don't need any special Cont structure for this!!!. It is right there, in the monad instance:

 instance Monad ...
    x >>= f = ....
    ...

For example when executing the second >>= this bind operation has the closure as first parameter. It is the result of x>>=f1, already executed. In the second parameter, the continuation is f2>>=f3.

If you are tired of the usual and boring monadic effects and you are tired also of managing event handlers and threads by hand, just store your continuations in a state monad and make use of them wherever you need it. That is what my Transient monad does. In the previous article It has been used to implement asyncronous event handling, parallelism and thread control. Now I will use for another exotic effect, that may be very useful:

#Backtracking#

The Transient monad of the previous article, has user state managemet, event/signal handling, thread control, parallelism and early termination effects. But another important effect that I wish to make available for the hard working programmer is backtracking. with this additional effect I can undo transactions and I can express Web navigations. As I demonstrated here with MFlow. The backtracking in MFlow is done using a different mechanism, explained in this article in The monad reader. This time I will use the Transient continuations.

I previous articles I presented the Transient monad, that stores the closure and the continuation in a state monad. it also facilities for user-definable session state management. Can we implement backtracking without touching the Base package where the Transient monad is defined?. Yes, we can.

Instead of using intimidating words like "backtracking" as a concept, let´s start with an application of it. let´s code some primitives like undo and onUndo so that we can, for example, undo the reservation of some product when the payment process fails because the user give up for whatever reason. The semantics of these two primitives can be understood by looking at this example:

transaction=   do
       option "back" "backtracking test"  
       productNavigation    
       reserve    
       payment

       liftIO $ print "done!"

       where

       productNavigation = liftIO $ putStrLn "product navigation"

       reserve= liftIO (putStrLn "product reserved,added to cart")
                 `onUndo` liftIO (putStrLn "product un-reserved")

       payment = do
           liftIO $ putStrLn "Payment failed"
           undo

Instead of undoing the reservation manually when the fail is verified, I call undo and let each action undo himself, so I can give the responsibility to the actions themselves. The advantage is that the programmer of the flow don't care about such low level things.

To implement these primitives I will define a registration method registerUndo that register a statement to be re-executed when backtracking.

I need a definition of the backtrack stack, which will contain a flag that indicates if backtracking is being executed and also will contain all the continuations of the back points.

The call registerUndo (below) get the continuation and stores it in the Backtrack structure. This Backtrack data will be stored in the session state using getSessionData and setSessionData

data Backtrack= forall a b.Backtrack{backtracking :: Bool
                                    ,backStack :: [EventF]}


registerUndo :: TransientIO a -> TransientIO a
registerUndo f  = Transient $ do
      cont  <- getCont  
      md  <- getSessionData
      setSessionData $   case md of
         Just   Backtrack b $ cont:bs
         Nothing ->  Backtrack False [cont]
      runTrans f

getCont is the Transient primitive that gives the computation state at that point, including the closure and the continuation.

Then, we define the onUndo primitive, that has two actions as parameters:

    onUndo :: TransientIO a -> TransientIO a -> TransientIO a
    onUndo ac bac= registerUndo $ do
       Backtrack back _ <- getSData <|> return (Backtrack False [])
       if back then bac else ac

When going forward the first action is executed, but when the flag signals that onUndo is being executed under backtracking, the second action is executed.

And now the primitive that executes the backtracking:

undo :: TransientIO a
undo= Transient $ do
  bs <- getSessionData  `onNothing` return nullBack              
  goBackt  bs

  where
  nullBack= Backtrack False []
  goBackt (Backtrack _ [])= return Nothing                      
  goBackt (Backtrack b (stack@(first: bs)))= do
        put first
        setSData $ Backtrack True stack
        mr <-  runClosure first
        Backtrack back _ <- getSessionData `onNothing` return nullBack
        case back of
           True ->  goBackt $ Backtrack True bs                 
           False -> case mr of
                   Nothing -> return Nothing                    
                   Just x -> runContinuation first x             

First It get the back stack, which contains closures and continuations of different back points. then it set the backtracking flag and execute the first closure (that is the last statement registered). If the closure changed the back flag, (False) then the continuation of that closure is executed, so the flow continue forward from that statement on. If the closure return Nothing (early termination) then undo stop.

If the closure don't change the back flag, the next back point in the stack is executed in the same way until there is no more backpoints.

This code below contains all the programs of the Hard working programmer 1 plus the backtracking example(s).

{-# START_FILE main.hs #-}

{-# LANGUAGE ScopedTypeVariables #-}

module Main where 

import           Base
import           Backtrack
import           Control.Applicative
import           Control.Concurrent
import           Control.Exception
import           Control.Monad.State
import           Data.Monoid
import           System.IO.Unsafe

import           Network.HTTP

import           Network
import           System.IO

-- show

main=  do
    runTransient $ do   
      async inputLoop  <|> return ()
      
      option "main" "to return to the main menu"  <|> return ""
      liftIO $ putStrLn "MAIN MENU"

      transaction <|> transaction2 <|> colors <|> 
        app  <|> sum1 <|> sum2 <|> server <|> menu

    stay

transaction=   do
       option "back" "backtracking test"
       productNavigation
       reserve
       payment
       
transaction2= do
       option "back2" "backtracking test 2"
       productNavigation
       reserveAndSendMsg
       payment


       liftIO $ print "done!"

       
productNavigation = liftIO $ putStrLn "product navigation" 

reserve= liftIO (putStrLn "product reserved,added to cart") 
                 `onUndo` liftIO (putStrLn "product un-reserved") 

payment = do
           liftIO $ putStrLn "Payment failed"
           undo

reserveAndSendMsg= do
            reserve
            liftIO $ print "MIDDLE"
            liftIO  (putStrLn "update other database necesary for the reservation")
                 `onUndo` liftIO (putStrLn "database update undone")

colors :: TransientIO ()
colors= do
       option "colors" "choose between three colors"
       r <-  color 1  "red"  <|> color 2 "green" <|> color 3 "blue"
       liftIO $ print r
       where
       color :: Int -> String -> TransientIO String
       color n str= option (show n) str >> return  str

app :: TransientIO ()
app= do
       option "app" "applicative expression that return a counter in 2-tuples every second"
       r <-  (,) <$>  number  <*> number
       liftIO $ putStrLn $ "result=" ++ show r
       where
       number= waitEvents $ do
          threadDelay 1000000
          n <- takeMVar counter
          putMVar counter (n+1)
          return  n

       counter=unsafePerformIO $ newMVar (0 :: Int)

sum1 :: TransientIO ()
sum1= do
       option "sum1" "access to two web pages concurrently and sum the number of words using Applicative"
       (r,r') <- (,) <$> async  (worker "http://www.haskell.org/")
                     <*> async  (worker "http://www.google.com/")

       liftIO $ putStrLn $ "result="  ++ show (r + r')

getURL= simpleHTTP . getRequest

worker :: String -> IO Int
worker url=do
      r <- getURL url
      body <- getResponseBody r
      putStrLn $ "number of words in " ++ url ++" is: " ++ show(length (words body))
      return . length . words $ body

sum2 :: TransientIO ()
sum2= do
       option "sum2" "access to N web pages concurrenty and sum the number of words using map-fold"
       rs <- foldl (<>) (return 0) $ map (async . worker)
                  [ "http://www.haskell.org/"
                  , "http://www.google.com/"]

       liftIO $ putStrLn $ "result="  ++ show rs

instance Monoid Int where
      mappend= (+)
      mempty= 0

server :: TransientIO ()
server=  do
       option "server" "A web server in the port 8080"
       liftIO $ print "Server Stated"
       sock <-  liftIO $  listenOn $ PortNumber 8080
       (h,_,_) <- spawn $ accept sock
       liftIO $ do
           hPutStr h msg
           putStrLn "new request"
           hFlush h
           hClose h
         `catch` (\(e::SomeException) -> sClose sock)

msg = "HTTP/1.0 200 OK\r\nContent-Length: 5\r\n\r\nPong!\r\n"


menu :: TransientIO ()
menu=  do
     option "menu"  "a submenu with two options"
     colors  <|> sum2 

-- / show






{-# START_FILE Backtrack.hs #-}

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}

-- show
module Backtrack (registerUndo, onUndo, undo, retry, undoCut) where
-- /show

import Base
import Data.Typeable
import Control.Applicative
import Control.Monad.State
import Unsafe.Coerce

data Backtrack= forall a b.Backtrack{backtracking :: Bool
                                    ,backStack :: [EventF]}
                                    deriving Typeable

-- | assures that backtracking will not go further
undoCut :: TransientIO ()
undoCut= Transient $ do
     delSessionData $ Backtrack False []
     return $ Just ()

-- | the secod parameter will be executed when backtracking 
{-# NOINLINE onUndo #-}
onUndo :: TransientIO a -> TransientIO a -> TransientIO a
onUndo ac bac= do
   r<-registerUndo $ Transient $ do 
     Backtrack back _ <- getSessionData `onNothing` return (Backtrack False [])
     runTrans $ if back then bac  else ac 
   return r
   
-- | register an actions that will be executed when backtracking
{-# NOINLINE registerUndo #-}
registerUndo :: TransientIO a -> TransientIO a
registerUndo f  = Transient $ do
   cont@(EventF _ _ _ i _ _ )  <- get   !> "backregister"
   md  <- getSessionData
   setSessionData $   case md of
        Just (bss@(Backtrack b (bs@((EventF _ _ _ i' _ _ ):_)))) -> if False then bss else  Backtrack b $ cont:bs
        Nothing ->  Backtrack False [cont]
   runTrans f

-- | restart the flow forward from this point on
retry :: TransientIO ()
retry= do
    Backtrack _ stack <- getSessionData `onNothing` return (Backtrack False [])
    setSData $ Backtrack False stack

-- | execute backtracking. It execute the registered actions in reverse order. 
--
-- If the backtracking flag is changed the flow proceed  forward from that point on. 
--
--If the backtrack stack is finished or undoCut executed, `undo` will stop.
undo :: TransientIO a
undo= Transient $ do
  bs <- getSessionData  `onNothing` return nullBack            !>"GOBACK"
  goBackt  bs

  where
  nullBack= Backtrack False []
  goBackt (Backtrack _ [])= return Nothing                     !> "END"
  goBackt (Backtrack b (stack@(first@(EventF x fs _ _ _  _ ): bs)))= do
        put first{replay=True} 
        setSData $ Backtrack True stack
        mr <-  runClosure first                                !> "RUNCLOSURE"
        Backtrack back _ <- getSessionData `onNothing` return nullBack 
                                                               !>"END RUNCLOSURE"
        case back of
           True ->  goBackt $ Backtrack True bs                !> "BACK AGAIN"
           False -> case mr of
                   Nothing -> return empty                     !> "FORWARD END"
                   Just x ->  runContinuation first x          !> "FORWARD EXEC"


{-# START_FILE Base.hs #-}

-----------------------------------------------------------------------------
--
-- Module      :  Base
-- Copyright   :
-- License     :  GPL (Just (Version {versionBranch = [3], versionTags = []}))
--
-- Maintainer  :  [email protected]
-- Stability   :
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------
{-# LANGUAGE ExistentialQuantification,FlexibleContexts,
             FlexibleInstances, MultiParamTypeClasses #-}

-- show
module Base  where 
-- /show

import Control.Monad.State
import Unsafe.Coerce
import System.IO.Unsafe
import Control.Applicative
import qualified Data.Map as M
import Data.Dynamic
import Debug.Trace
import Data.Monoid

--import Data.IORef
import Control.Concurrent
import Control.Concurrent.STM
import GHC.Conc
import Data.Maybe
import System.Mem.StableName
import Data.List

(!>) =  const . id -- flip trace
infixr 0 !>

data Transient m x= Transient  {runTrans :: m (Maybe x)}
type SData= ()

type EventId= Int



data EventF  = forall a b . EventF{xcomp :: TransientIO a
                                  ,fcomp :: a -> TransientIO b
                                  ,mfData :: M.Map TypeRep SData
                                  ,mfSequence :: Int
                                  ,row :: P RowElem
                                  ,replay :: Bool
                                  }

type P= MVar

type Buffer= Maybe ()
type NodeTuple= (EventId, ThreadId, Buffer)

type Children=  Maybe (P RowElem)

data RowElem=   Node NodeTuple |  RowList Row Children

instance Show RowElem where
  show (Node (e,_,_))= show e
  show (RowList r ch)= show ( reverse r)  ++ "->" ++ show ch

type Row = [P RowElem]

instance Eq NodeTuple where
     (i,_,_) ==  (i',_,_)= i == i'


instance Show x => Show (MVar x) where
  show  x = show (unsafePerformIO $ readMVar x)

eventf0= EventF  empty (const  empty) M.empty 0
          rootRef False

-- {-# NOINLINE topNode #-}
-- topNode= (-1 :: Int,unsafePerformIO $ myThreadId,False,Nothing)

{-# NOINLINE rootRef #-}
rootRef :: MVar RowElem
rootRef=  unsafePerformIO $ newMVar $ RowList []  Nothing                      

instance MonadState EventF  TransientIO where
  get=  Transient $ get >>= return . Just
  put x= Transient $ put x >> return (Just ())

type StateIO= StateT EventF  IO

type TransientIO= Transient StateIO

--runTrans ::  TransientIO x -> StateT EventF  IO (Maybe x)
--runTrans (Transient mx) = mx

runTransient :: TransientIO x -> IO (Maybe x, EventF)
runTransient t= runStateT (runTrans t) eventf0


newRow :: MonadIO m => m (P RowElem)
newRow= liftIO $ newMVar $ RowList [] Nothing

setEventCont ::   TransientIO a -> (a -> TransientIO b) -> StateIO EventF
setEventCont x f  = do
   st@(EventF   _ fs d _  ro r)  <- get
   n <- if replay st then return $ mfSequence st
     else  liftIO $ readMVar refSequence
   ro' <- newRow
   ro `eat` ro'
   put $ EventF   x ( \x -> f x >>= unsafeCoerce fs) d n  ro' r !> ("stored " ++ show n)
   return st

eat ro ro'= liftIO $
 modifyMVar_  ro $ \(RowList es t) -> return $ RowList (ro':es) t

resetEventCont (EventF x fs _ _  _ _)=do
   st@(EventF   _ _ d  n  ro r )  <- get
   put $ EventF  x fs d n  ro r


getCont ::(MonadState EventF  m) => m EventF
getCont = get

runCont :: EventF -> StateIO ()
runCont (EventF  x fs _ _  _ _)= do runIt  x (unsafeCoerce fs); return ()
   where
   runIt  x fs= runTrans $ do
         st <- get
         --put st{mfSequence=i}
         r <- x
         put st
         fs r


runClosure :: EventF -> StateIO (Maybe a)
runClosure (EventF x _ _ _ _ _) =  unsafeCoerce $ runTrans x

runContinuation ::  EventF -> a -> StateIO (Maybe b)
runContinuation (EventF _ fs _ _ _ _ ) x= runTrans $  (unsafeCoerce fs) x 

instance   Functor TransientIO where
  fmap f x=   Transient $ fmap (fmap f) $ runTrans x -- 


instance Applicative TransientIO where
  pure a  = Transient  .  return $ Just a
  Transient f <*> Transient g= Transient $ do
       k <- f
       x <- g
       return $  k <*> x

instance  Alternative TransientIO where
  empty= Transient $ return  Nothing
  Transient f <|> Transient g= Transient $ do
       k <- f
       x <- g
       return $  k <|> x


-- | a sinonym of empty that can be used in a monadic expression. it stop the
-- computation
stop :: TransientIO a
stop= Control.Applicative.empty

instance Monoid a => Monoid (TransientIO a) where
  mappend x y = mappend <$> x <*> y  
  mempty= return mempty

instance Monad TransientIO where
      return x = Transient $ return $ Just x
      x >>= f  = Transient $ do
        cont <- setEventCont x  f
        mk <- runTrans x
        resetEventCont cont
        case mk of
           Just k  -> do addDescent' !> "ADDROW" ; runTrans $ f k

           Nothing -> return Nothing

        where
        addDescent'= do
            r <- gets row
            n <- addDescent r
            modify $ \s -> s{row= n}
addDescent r=
            liftIO $ do
              n <- newMVar $ RowList [] Nothing
              modifyMVar_ r $ \(RowList ns ch) ->  return $ RowList  ns $ Just n
             --   case ch of
             --     Just x -> error $ "children not empty: "++ show x
             --     Nothing ->  return $ RowList  ns $ Just n
              return n

addChild row ref= modifyMVar_  row $ \(RowList ns t) -> return $  RowList (ref : ns) t
   
instance MonadTrans (Transient ) where
  lift mx = Transient $ mx >>= return . Just

instance MonadIO TransientIO where
  liftIO = lift . liftIO --     let x= liftIO io in x `seq` lift x



-- | Get the session data of the desired type if there is any.
getSessionData ::  (MonadState EventF m,Typeable a) =>  m (Maybe a)
getSessionData =  resp where
 resp= gets mfData >>= \list  ->
    case M.lookup ( typeOf $ typeResp resp ) list of
      Just x  -> return . Just $ unsafeCoerce x
      Nothing -> return $ Nothing
 typeResp :: m (Maybe x) -> x
 typeResp= undefined

-- | getSessionData specialized for the View monad. if Nothing, the monadic computation
-- does not continue. getSData is a widget that does not validate when there is no data
--  of that type in the session.
getSData :: MonadState EventF m => Typeable a =>Transient m  a
getSData= Transient getSessionData


-- | setSessionData ::  (StateType m ~ MFlowState, Typeable a) => a -> m ()
setSessionData  x=
  modify $ \st -> st{mfData= M.insert  (typeOf x ) (unsafeCoerce x) (mfData st)}

-- | a shorter name for setSessionData
setSData ::  ( MonadState EventF m,Typeable a) => a -> m ()
setSData= setSessionData

delSessionData x=
  modify $ \st -> st{mfData= M.delete (typeOf x ) (mfData st)}

delSData :: ( MonadState EventF m,Typeable a) => a -> m ()
delSData= delSessionData

withSData ::  ( MonadState EventF m,Typeable a) => (Maybe a -> a) -> m ()
withSData f= modify $ \st -> st{mfData=
    let dat = mfData st
        mx= M.lookup typeofx dat
        mx'= case mx of Nothing -> Nothing; Just x -> unsafeCoerce x
        fx=  f mx'
        typeofx= typeOf $ typeoff f
    in  M.insert typeofx  (unsafeCoerce fx) dat}
    where 
    typeoff :: (Maybe a -> a) -> a
    typeoff = undefined
----

genNewId :: MonadIO m => MonadState EventF m =>  m Int
genNewId=  do
      st <- get
      case replay st of
        True -> do
          let n= mfSequence st
          put $ st{mfSequence= n+1}
          return n
        False -> liftIO $
          modifyMVar refSequence $ \n -> return (n+1,n)

{-# NOINLINE refSequence #-}
refSequence :: MVar Int
refSequence= unsafePerformIO $ newMVar 0


--- IO events

--buffers :: IORef [(EventId,Dynamic)]
--buffers= unsafePerformIO $ newIORef []

data Loop= Once | Loop | Multithread deriving Eq

waitEvents ::  IO b -> TransientIO b
waitEvents= parallel Loop


async  :: IO b -> TransientIO b
async = parallel Once

spawn= parallel Multithread

parallel  ::  Loop ->  IO b -> TransientIO b
parallel hasloop receive =  Transient $ do
      cont <- getCont
      id <- genNewId
      liftIO $ forkCont id hasloop receive cont

forkCont::  EventId -> Loop -> IO a -> EventF -> IO (Maybe a)
forkCont id hasloop receive cont= do
      let currentRow= row cont
      mnode  <-   liftIO $ lookTree id currentRow !> ("idToLook="++ show id++ " in: "++ show currentRow)
      
      case mnode of
        Nothing ->do
                 return () !> "NOT FOUND"
                 forkCont' id cont hasloop receive
                 return Nothing
        
        Just (node@(id',th', mrec)) -> do
         -- modify $ \cont -> cont{nodeInfo=Nothing}
          return $ if isJust mrec then Just $ unsafeCoerce $ fromJust mrec else Nothing

        where
        forkCont' id cont hasloop receive= liftIO $ forkIO $ do
                     th <- myThreadId
                     ref <-newMVar  $  Node (id,th,Nothing)
                     addChild (row cont) ref

                     loop hasloop  receive $ \r -> do
                       modifyMVar_  ref $ \(Node(i,th,_)) -> return
                                       $ Node(i,th,Just $ unsafeCoerce r)
                       (flip runStateT) cont $ do
                           cont@(EventF  x fs _  _ _ _) <- get
                           
                           put cont{replay= True{-,-mfSequence=i,-}{-nodeInfo=Just ref-}}
                           
                           mr <- runClosure cont 
                           case mr  of
                             Nothing ->return Nothing
                             Just r ->do
                               row1 <- gets row 
                               liftIO $ delEvents  row1              !> ("delEvents: "++ show row1)
                               id <- liftIO $ readMVar refSequence
                               n <-  addDescent  row1
                               modify $ \cont -> cont{row=n,replay= False,mfSequence=id } !> ("SEQ=" ++ show(mfSequence cont))
                               runContinuation cont r
                       return ()



        loop Once rec x  = rec >>= x
        loop Loop rec f = do
            r <- rec
            f r
            loop Loop rec f

        loop Multithread rec f = do
            r <- rec
            forkIO $ f r
            loop Multithread rec f

        lookTree :: EventId -> P RowElem -> IO (Maybe NodeTuple)
        lookTree id ref=  do
            RowList ns _<- readMVar ref
            lookList id ns



        lookList id mn= case mn of
              [] -> return Nothing
              (p:nodes) -> do
                  me <- readMVar p
                  case me of
                    Node(node@((id',_,_))) ->
                      if id== id'
                         then return $ Just node
                         else lookList id nodes
                    RowList row _ -> do
                         mx <- lookList id nodes
                         case mx of
                           Nothing -> lookList id row
                           Just x -> return $ Just x
        delEvents :: P RowElem  -> IO()
        delEvents ref = do
            RowList mevs mch <- takeMVar ref
            maybeDel mch
            putMVar ref $ RowList mevs Nothing

        maybeDel mch=  case mch of
              Nothing -> return ()
              Just p -> do
                  RowList es mch' <- readMVar p
                  delList es !> ("toDelete="++ show es)
                  maybeDel mch'


        delList es=  mapM_ del es where
          del p = readMVar p >>= del'
          del' (Node(node@(_,th,_)))= killThread th !> ("DELETING " ++ show node)
          del' (RowList l mch)= delList l >> maybeDel mch


type EventSetter eventdata response= (eventdata ->  IO response) -> IO ()
type ToReturn  response=  IO response
react
  :: Typeable eventdata
  => EventSetter eventdata response
  -> ToReturn  response
  -> TransientIO eventdata

react setHandler iob= Transient $ do
        cont    <- getCont
        mEvData <- getSessionData
        case mEvData of
          Nothing -> do
            liftIO $ setHandler $ \dat ->do
--              let cont'= cont{mfData = M.insert (typeOf dat)(unsafeCoerce dat) (mfData cont)}
              runStateT (setSData dat >> runCont cont) cont
              iob
            return Nothing
          Just dat -> delSessionData dat >> return (Just  dat)


{-# NOINLINE getLineRef #-}        
getLineRef= unsafePerformIO $ newTVarIO Nothing


option1 x  message=  inputLoop `seq` (waitEvents  $ do
     liftIO $ putStrLn $ message++"("++show x++")"
     atomically $ do
       mr <- readTVar getLineRef
       th <- unsafeIOToSTM myThreadId
       case mr of
         Nothing -> retry
         Just r ->
            case reads1 r !> ("received " ++  show r ++  show th) of
            (s,_):_ -> if  s == x  !> ("waiting" ++ show x)
                     then do
                       writeTVar  getLineRef Nothing !>"match"
                       return s

                     else retry
            _ -> retry)
     where
     reads1 s=x where
      x= if typeOf(typeOfr x) == typeOf "" then unsafeCoerce[(s,"")] else readsPrec 0 s
      typeOfr :: [(a,String)] ->  a
      typeOfr  = undefined

option ret message= do
    liftIO $ putStrLn $"Enter "++show ret++"\tto: " ++ message
    waitEvents  $ getLine' (==ret)
    liftIO $do putStrLn $ show ret ++ " chosen"
    return ret
    
getLine' cond=   inputLoop `seq` do
     atomically $ do
       mr <- readTVar getLineRef
       th <- unsafeIOToSTM myThreadId
       case mr of
         Nothing -> retry
         Just r ->
            case reads1 r !> ("received " ++  show r ++ show th) of
            (s,_):_ -> if cond s  !> show (cond s)
                     then do
                       writeTVar  getLineRef Nothing !>"match"
                       return s

                     else retry
            _ -> retry
     where
     reads1 s=x where
      x= if typeOf(typeOfr x) == typeOf "" then unsafeCoerce[(s,"")] else readsPrec 0 s
      typeOfr :: [(a,String)] ->  a
      typeOfr  = undefined

inputLoop=  do
    print "Press end to exit"
    inputLoop'
    where
        inputLoop'= do 
           r<- getLine                      !> "started inputLoop"
           if r=="end" then putMVar rexit () else do
              atomically . writeTVar  getLineRef $ Just r
              inputLoop'


rexit= unsafePerformIO newEmptyMVar

stay=  takeMVar rexit

onNothing iox iox'= do
       mx <- iox
       case mx of 
           Just x -> return x
           Nothing -> iox'

           

If you press the option "back", it executes the backtracking test, corresponding to the first snippet of code in this article. The sequence executed is the one intended:

  "back" chosen
  product navigation
  product reserved,added to cart
  Payment failed
  product un-reserved

This is a simple undo with one single back point, but suppose that the reserve call update a database, but, for some reason, it is necessary in the future to update a second database, so you add to reserve this modification without changing the main flow:

reserve= do
            liftIO (putStrLn "product reserved,added to cart")
                 `onUndo` liftIO (putStrLn "product un-reserved")
                 
            liftIO  (putStrLn "update other database necessary for the reservation")
                 `onUndo` liftIO (putStrLn "database update undone")

The undo in the main flow will undo both changes.

There are two more primitives in the library

• undoCut to empty the stack, so previous back points will not be executed by the next undo
• retry changes the backtracking flag, so the flow will proceed forward from that point on

You can play with them and tell me the about the results.

The Transient repo:

    https://github.com/agocorona/transient

#Conclussions and future work# With the use of session state and backtracking it is possible to do complex navigations when exploring tree structores or even doing web navigations. I plan to adapt MFlow to this transient Monad.

Execution state persistence, like the Workflow and MFlow packages is also necessary for the hardworking programmer. This can be done by storing events and replaying them.

This is one more effect added to my hardworking programmer super-monad. It is intended to super-charge the Haskell newbie with a set of powerful but intuitive primitives ad combinators to give unprecendented expressive power without adding complexity.

More effects will come...