Monad Transformer Example

state.hs

module Main (comp2, main) where

import Data.Maybe
import Data.List
import Data.Functor
import Control.Applicative
import Control.Monad

type Env a = [(String, a)]

data S a = S (Env Int -> (a, Env Int))
runEnv :: S a -> Env Int -> (a, Env Int)
runEnv (S s) env = s env

readEnv :: String -> S Int
readEnv var = S $ \env -> (fromMaybe 0 $ lookup var env, env)

writeEnv :: String -> Int -> S ()
writeEnv var val = S $ \env -> ((), (var, val):env)

instance Functor S where
  fmap f (S x) = S $ \env ->
     case x env of
     (x', env') -> (f x', env')

instance Applicative S where
  pure x = S (\env -> (x, env))

  (S f) <*> (S x) = S $ \env ->
     case f env of
     (f', env') ->
         case (x env') of
         (x', env'') -> (f' x', env'')

instance Monad S where
  return = pure

  (S x) >>= f = S $ \env ->
    let (x1, env1) = x env in
      runEnv (f x1) env1

empty_env = []

comp1 = do
  writeEnv "x" 1
  writeEnv "y" 2
  x <- readEnv "x"
  y <- readEnv "y"
  writeEnv "z" (x+y)

-- main :: IO ()
-- main = do
--   let (_, env) = runEnv comp empty_env
--   putStrLn $ show env

data Hard a = HardVal a | NaN deriving Show

instance Functor Hard where
  fmap _ (NaN) = NaN
  fmap f (HardVal x) = HardVal $ f x

instance Applicative Hard where
  pure = HardVal
  
  NaN <*> _ = NaN
  _ <*> NaN = NaN
  (HardVal f) <*> (HardVal x) = HardVal (f x)

instance Monad Hard where
  return = pure
  
  NaN >>= _ = NaN
  (HardVal x) >>= f = f x

razdivide :: Int -> Int -> S (Hard Int)
razdivide x 0 = S $ \e -> (NaN,e)
razdivide x y = S $ \e -> (HardVal $ x `div` y,e)

-- comp2 :: S _
comp2 = do
  writeEnv "x" 1
  writeEnv "y" 0
  x <- readEnv "x"
  y <- readEnv "y"
  razdivide x y
  --writeEnv "z" z

newtype (Monad m) => HardT m a = HardT { runHardT :: m (Hard a) }

instance Monad m => Monad (HardT m) where
  -- return :: a -> HardT m a
  return = HardT . return . HardVal

  -- (>>=) :: HardT m a -> (a -> HardT m b) -> HardT m b 
  x >>= f = HardT ((runHardT x) >>= \y -> case y of
                HardVal z -> runHardT $ f z
                NaN       -> return NaN)
            
razdivide2 :: Int -> Int -> HardT S Int
razdivide2 x 0 = HardT $ return NaN
razdivide2 x y = return (x `div` y)

lift :: Monad m => m a -> HardT m a
lift x = HardT $ (x >>= \y -> return $ HardVal y)

-- comp3 :: HardT S ()
comp3 = do
  lift $ writeEnv "x" 4
  lift $ writeEnv "y" 2
  x <- lift $ readEnv "x"
  y <- lift $ readEnv "y"
  z <- razdivide2 x y
  lift $ writeEnv "x" 5

--main :: IO ()
main = do
  let (answ, env) = x
  putStrLn $ show answ
  putStrLn $ show env
    where
        --x :: Int
        x = runEnv (runHardT comp3) empty_env