gistfile1.txt

{-# LANGUAGE NoMonomorphismRestriction #-}
module Test where

import Control.Applicative ((<$>),(<*>))
import Control.Monad.State (get, put, lift, StateT(..))
import Control.Monad.Trans.Either (right, left, EitherT(..))

type C a = EitherT String (StateT [a] IO)

-- low level
pop :: C a a
pop = do  
  s <- get
  case s of
    (x:xs) -> put xs >> right x
    _ -> left "no item"

push :: a -> C a ()
push n = get >>= put.(n:)

-- util
run :: C s a -> IO (Either String a, [s])
run p = runStateT (runEitherT p) []

transaction :: C a b -> C a b
transaction p = do
  s <- get
  either (rollback s) right =<< lift (runEitherT p)
  where
    rollback s m = put s >> left m

op2 :: (a -> a -> a) -> C a ()
op2 f = f <$> pop <*> pop >>= push
op3 :: (a -> a -> a -> a) -> C a ()
op3 f = f <$> pop <*> pop <*> pop >>= push

-- primitive op
plus :: C Int ()
plus = op2 (+)

plus3 :: C Int ()
plus3 = op3 (\x y z -> x + y + z)

-- |
-- illegal case without transaction
-- >>> run test
-- (Right 6,[])
test :: C Int Int
test = do
  push 1
  push 2
  push 3
  (transaction plus3)
  pop

-- |
-- illegal case without transaction
-- >>> run test2
-- (Left "no item",[])
test2 :: C Int Int
test2 = do
  push 1
  push 2
  push 3
  plus3
  push 4
  plus3
  pop

-- |
-- illegal case with transaction
-- >>> run test3
-- (Left "no item",[4,6])
test3 :: C Int Int
test3 = do
  push 1
  push 2
  push 3
  (transaction plus3)
  push 4
  (transaction plus3)
  pop