module Control.Monad.Supervisor.Transactions (
) where
import Control.Monad.State
import Control.Monad.Supervisor hiding (breturn)
import qualified Control.Monad.Supervisor as Sup(breturn)
import Data.Monoid
import Control.Monad.Trans
import Control.Monad.Supervisor.Session hiding (runs)
import Data.Typeable
breturn x= setSessionData (BackTracking False) >> Sup.breturn x
instance MonadState SessionData m => Supervise SessionData m where
supBack s= setSessionData (BackTracking True) !> "supBack"
class Monad m => BackTrackingStatus m where
isGoingBack :: m Bool
class Monoid t => HasInverse t where
cancel :: t -> t
newtype BackTracking= BackTracking Bool deriving Typeable
processReversibleEvent :: (Supervise SessionData m, HasInverse a)=> a -> a -> (a -> Sup SessionData m()) -> Sup SessionData m ()
processReversibleEvent resource event update = do
now <- isGoingBack
if now !> ("back="++ show now) then update (resource <> cancel event) >> fail ""
else update (resource <> event) >> breturn ()
instance Monoid Int where mempty=0; mappend =(+)
newtype Potatoes= Potatoes Int deriving (Num, Monoid, Typeable)
instance HasInverse Potatoes where cancel = negate
instance Supervise SessionData m => BackTrackingStatus m where
isGoingBack= do
BackTracking b <- getSessionData `onNothing` (return (BackTracking False) !> "backtracking not set" ) !> "isgoingback"
return b
runs= flip evalStateT
main= do
print "hi"
runs emptySessionData $ runSup $ do
setSessionData (BackTracking True)
getSessionData `onNothing` error "not set" >>= \(BackTracking b) -> liftIO (print b)
Potatoes potatoes <- getSessionData `onNothing` return (Potatoes 0)
liftIO . print $ " Now you have"++ show potatoes ++ " in your shopping cart"
liftIO . print $ "press enter for more potatoes"
liftIO $ getLine
liftIO . print $ " you want to add potatoes to the shopping cart"
processReversibleEvent (Potatoes potatoes) (Potatoes 5) setSessionData
liftIO . print $ "but wait!. you do not need potatoes, you need oranges!. "
liftIO . print $ "No problem. press enter to drop the potatoes from the cart"
liftIO $ getLine
fail ""