gistfile1.hs

{-# LANGUAGE FlexibleInstances #-}
module MMorphTest where

import Control.Monad
import Control.Monad.Morph
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.Trans.Maybe
import Data.Monoid
import Data.Functor.Identity

-- base monad from Id to Maybe

push :: a -> State [a] ()
push v = modify (v:)

pop :: State [a] a
pop = state (\(x:xs) -> (x,xs))

safePush :: a -> StateT [a] Maybe ()
safePush = hoist generalize . push

safePop :: StateT [a] Maybe a
safePop = do
    gets null >>= guard
    hoist generalize pop

-- mt stack from StateT, ReaderT, Id
-- to: StateT, WriterT, ReaderT, Id

type M1 a = StateT Int (Reader Int) a
type M1' a = StateT Int (WriterT (Sum Int) (Reader Int)) a

bump :: M1 Int
bump = do
    incr <- lift ask
    state (\v -> let v' = v+incr in (v',v') )

bumpCounted :: M1' Int
bumpCounted = do
    lift $ tell (Sum 1)
    hoist lift bump

-- allowing extra actions after the first layer

assumeEven :: MaybeT (State Int) ()
assumeEven = lift get >>= guard . even

assumeBigEven :: MaybeT (State Int) ()
assumeBigEven = embed (\s -> do
                           result <- lift s
                           v <- lift get
                           guard (v >= 100)
                           pure result)
                      assumeEven

{-
*MMorphTest> runIdentity $ evalStateT (runMaybeT assumeEven) (1 :: Int)
Nothing
*MMorphTest> runIdentity $ evalStateT (runMaybeT assumeEven) (2 :: Int)
Just ()
*MMorphTest> runIdentity $ evalStateT (runMaybeT assumeBigEven) (2 :: Int)
Nothing
*MMorphTest> runIdentity $ evalStateT (runMaybeT assumeBigEven) (200 :: Int)
Just ()
-}