The hardworking programmer II: practical backtracking to undo actions

As of March 2020, School of Haskell has been switched to read-only mode.


Compensations are a general mechanism for restoring state that permits to undo even IO actions. I present two primitives for transient: onUndo that "annotates" undo actions attached to the monadic statements in a monadic sequence. These statements are executed in reverse order when undo is called. It is a kind of backtracking.

onUndostatements can be used to restore state variables, close streams, restore database registers, respond to the back button in a web navigation or whatever. undo can be invoked as part of the execution flow or to express some exceptional condition.

Additionally, with undoCut the onUndo statements can fix some problem and resume the execution forward from this point instead of undoing further actions.

A word on continuations

In Haskell, the continuation is the second parameter in the bind operation. Other languages use imperative and eager execution, so they have to resort to continuations to implement special kinds of flows so a kind of special mechanism is necessary in these languages for capturing continuations. Haskell does not have such problem: It uses continuations natively. The monad instance defines what each kind of computation has to do with these continuations.

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

So at every moment you know what is in the continuation, in any monad. You don't need any special Cont structure for this. It is in the monad instance: it is the second parameter in the bind operation:

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

In this expression:

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

When executing the second >>= in this expression, the closure is the result of the execution of x>>=f1 The continuation is f2>>=f3. so that at every point of the execution, the expression is identical to his closure composed with his continuation:

exp= closure >>= continuation

while the computation executes, the closure and the continuation changes, but the equality holds. It is like if the monadic tree were expressed in terms of a zipper.

What the transient Monad does is to store the closure and the continuation of each bind operation in the state of a state monad. Then each statement, for example f1, can access to both of them to create new effectful primitives. a such statement can modify the execution flow so that it is possible to create new effects without modifying the monad instance neither stacking monad transformers.

Suppose that in f1 depend on two events from a GUI, or, for example, the finalization of two blocking IO operations.

exp= x >>= ((op1 <|> op2) >>= f2) >>=f3

then op1 and op2 share the same closure and the same continuation. since both block, I can set up the watching of both events, stop execution of the current thread and wait. when any of the two events fire, I can store the event value in a buffer, execute the closure with each of the two buffer result and then execute the continuation. That is how events and non blocking IO can make use of the closure and the continuation. See the first article of this serie for more details.

The Transient state contains both of them.

data EventF  = forall a b . EventF{xcomp :: (TransientIO a)
                                  ,fcomp :: [a -> TransientIO b]
                                  mfData :: M.Map TypeRep SData

It also contains a Data.Map of Dynamic values, to store arbitrary data, that can be stored and retrieved by his type. This map can store any programmer-defined data. it also can store continuations of previous statements, this permits to modify the execution of the monadic expression in very sophisticated ways.

By editing the monadic statements as if they were arrows in a graph, you can construct new effects. That is what my Transient monad does. In the previous article it has been used to implement asynchronous event handling, parallelism and thread control. Now I will use it for another exotic effect, that may be very useful.


The Transient monad of the previous article has user state management, 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 a Web navigation. As I demonstrated here with the MFlow package. 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 monad for the implementation of this effect.

In the previous article I presented the Transient monad, that stores a closure and a continuation in a state monad. 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 gave up for whatever reason. The semantics of these two primitives can be understood by looking at this example:

transaction=   do
       option "back" "backtracking test" 

       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"

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

To implement these primitives I will define a registration method registerUndo that registers 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 backtracking points.

The call registerUndo (below) gets 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 bs ->  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

  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 backtracking stack, which contains closures and continuations of different backtracking points. Then it sets the backtracking flag and executes the first closure (that is the last statement registered). If the closure changed the backtracking flag, (False) then the continuation of that closure is executed, so the flow continues forward from that statement on. If the closure returns Nothing (early termination) then undo and stop.

If the closure doesn't change the backtracking flag, the next backtracking point in the stack is executed in the same way until there is no more backtracking points.

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


transaction=   do
       option "back" "backtracking test"
transaction2= do
       option "back2" "backtracking test 2"

       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"

reserveAndSendMsg= do
            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
       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
       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 "")
                     <*> async  (worker "")

       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)
                  [ ""
                  , ""]

       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 second 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 action 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 executes the registered actions in reverse order.
-- If the backtracking flag is changed, the flow proceeds 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

  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  :
-- 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 ()
   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 synonym of empty that can be used in a monadic expression. It stops 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

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

        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
  :: 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
            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)
     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
     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'= do
           r<- getLine                      !> "started inputLoop"
           if r=="end" then putMVar rexit () else do
              atomically . writeTVar  getLineRef $ Just r

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 portrayed here 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 backtracking point, but suppose that the reserve call updates 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:

Conclusions and future work

With the use of session state and backtracking it is possible to do complex navigations when exploring tree structures and 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. Check them out!

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 to come!

Thanks to: Aistis Raulinaitis