import Monad

{- 
   ------------------------------------------------
   Monad Transformer, Implementation on Haskell.
   The ideas was based on the Paper:

   Monad Transformers and Modular Interpreters, 
   S. Liang, P. Hudak and Mark P. Jones, Pages 6-8

   For running the example you must type run.
   ------------------------------------------------
   Written by Alejandro C. Russo 
   russo@eva.fceia.unr.edu.ar
   ------------------------------------------------
-}

{-
 Monad Transformer Class, any type constructor 
 (::*->*->*)
 that satisfy this class is considered like a 
 Monad Transformer.
-}
class (Monad m,Monad (t m)) => MonadTrans t m where
	lift :: m a -> t m a

{- 
   ----------------
   Error 
   ----------------
-}

data Error a = Raise String | Return a 
			   deriving Show

{-
 Monad Error Class, any monad that satisfy 
 this class is considered like a Error Monad 
-}
class Monad m => MonadError m where
	raise :: String -> m a

instance Monad Error => MonadError Error  where
	raise e = (Raise e) 

{- Monad Error Transformer -}
data ErrorT m a = ErrorT ( m (Error a) )
				  deriving Show 

{- We show here that ErrorT applied to a monad m 
   is a monad -}
instance Monad m => Monad (ErrorT m) where
	
	return x          = ErrorT $ return (Return x)
	(ErrorT m) >>= k  = ErrorT $ 
						  m >>= \r -> case r of 
										 (Raise e)  -> return (Raise e) 
						   				 (Return x) -> 
											let (ErrorT m') = k x 
											in m'  

{-
 Here we show that when ErrorT is applied to 
 a monad m, it generates a Error Monad. 
 We use the class MonadError 
 we previosly defined.
-}
instance Monad m => MonadError (ErrorT m) where
	raise e = ErrorT ( return (Raise e) )

{- Here we show that ErrorT is a monad transformer because
   it permits ``lift'' other monad on it -}
instance Monad m => MonadTrans ErrorT m where
	lift m = ErrorT ( m >>= \x -> return (Return x) )


{- 
   -----------
   State
   -----------
-}

{-
 MonadSt Class, any monad that satisfy 
 this class is considered like a State Monad.
 Apply must be defined outside of this class for 
 typing reasons.
-}
class (Monad m) => MonadSt s m where
	poke :: (s -> s) -> m s        

{- State Monad Transformer -}
data StateT s m a = StateT ( s -> m (s,a) )

{- We show here that StateT applied to a monad m 
   is a monad -}
instance Monad m => Monad (StateT s m) where
	return x          = StateT $ \s -> return (s,x) 
	(StateT m) >>= k  = StateT $ \s -> 
						  m s >>= \(s',a) -> let (StateT m') = k a  
											 in m' s'  

{-
 Here we show that when StateT is applied to 
 a monad m, it generates a State Monad. 
 We use the class MonadSt
-}
instance Monad m => MonadSt s (StateT s m) where
	poke f = StateT $ \s -> let s' = f s 
							in return (s',s')


{- Here we show that StateT is a monad transformer because
   it permits ``lift'' other monad on it -}
instance Monad m => MonadTrans (StateT s) m where
	lift m = StateT $ \s -> m >>= \a -> return (s,a)  



{- 
   -------------------------------------------
   Example: think in a virtual machine with 
   an int state, input/output and 
   error handling. We must put numbers to 
   the machine, which adds them and put 
   the result in its state. When 
   the state value is bigger than 100, 
   the machine produces an "overflow" error. 
   If we put 0 when we introduce numbers, 
   the machine shows its state. 
   -------------------------------------------
-}

{- Read a Number, it only involves IO monad -}
readNumber :: Read Int => IO Int 
readNumber = liftM read getLine 

vmError :: String -> ErrorT IO Int 
vmError = raise 

message :: IO ()
message = do putStr "Virtual Machine\n"
             putStr "Constructed by Monad Transformer\n"
             putStr "Maded by Alejandro C. Russo\n"
             putStr "russo@eva.fceia.unr.edu.ar\n\n"
             putStr "Input integer numbers (0 stop)\n"

vmMessage :: StateT Int (ErrorT IO) ()
vmMessage = (lift.lift) message
 
{- here we add two effect to the monadic 
   value readNumber, using lift operation.
-} 
vmInput :: StateT Int (ErrorT IO) Int 
vmInput =  (lift.lift) readNumber 

vm :: StateT Int (ErrorT IO) Int  
vm = do n <- vmInput 
        if n == 0 then poke id 
                  else do s <- poke (+n)
                          if s <= 100 then vm 
                                      else lift (raise "Overflow!") 
 
vmApply :: (Show a, Show s) => s -> StateT s m a -> m (s,a)
vmApply s (StateT m) = m s

outError (ErrorT m) = m >>= \x -> putStr (show x) 


run = outError (vmApply 0 (vmMessage >> vm))