What is the idiomatic way to call pure functions within a MaybeT ( StateT ) monadT stack such that error propagates?

Question

Concretely, let's say I have this monadT stack:

type MHeap e ret = MaybeT ( StateT [e] Identity ) ret

and a runMheap function for convience:

runMheap :: MHeap e ret -> [e] -> ( Maybe ret, [e] )
runMheap m es = runIdentity $ runStateT ( runMaybeT m ) es

I want to create an MHeap that finds the ith element of a list ( note we could have an out of bound error here ), and then append it to the end of the list if the element exist, else leave the list as is. In code:

mheapOp' :: Int -> MHeap Int ( Maybe Int )
mheapOp' i = do 
    xs <- lift $ get
    -- I would like to use the pure function ( !! ) here
    let ma = fndAtIdx i xs 
    -- I would also like to get rid these case statements
    -- Also how do you describe 'no action' on the list?
    case ma of 
        Nothing -> lift $ modify ( ++ [] )
        Just a  -> lift $ modify ( ++ [a] )
    return ma


-- Since I dont know how to use the pure function above, I'm using this hack below
fndAtIdx i xs = if length xs > i then Just $ xs !! i else Nothing

Please note I put my questions in comments above.

This code runs as follows:

case 1: runMheap(mheapOp' 1 ) [1..3]   // (Just (Just 2),[1,2,3,2])
case 2: runMheap(mheapOp' 10 ) [1..3]  // (Just Nothing,[1,2,3])

You see, unsurprisingly the first element of the tuple is double wrapped, but I have no idea how to get rid of it without calling join on the result. In other words, this would be nice:

( Just 2, [1,2,3,2] ) and ( Nothing, [1,2,3] )

So to recap, what is the idiomatic way to call pure functions within a monadT stack and ensure that the error propagates without explicitly writing case statements?

Answer 1

I recommend that you stick with findAtIdx, which returns a Nothing, rather than use a partial function like (!!) that uses error. What you actually need is a function of the following type:

hoistMaybe :: (Monad m) => Maybe a -> MaybeT m a

This function would let you embed your findAtIdx command correctly within the surrounding MaybeT monad like so:

mheapOp' :: Int -> MHeap Int Int
mheapOp' i = do 
    xs <- lift get
    -- if 'findAtIdx' is 'Nothing', it will stop here and not call 'modify'
    a <- hoistMaybe (findAtIdx i xs)
    lift $ modify (++ [a])
    return a

We can write this function ourselves:

hoistMaybe ma = MaybeT (return ma)

Or you can import it from the errors library (Full disclosure: I wrote it). Note that this library also re-exports the atMay function from the safe library for you, which is just like your findAtIdx function.

But how do we know that this function does the right thing? Well, usually when we get a function "right" it happens to obey some sort of category theory laws, and this function is no exception. In this particular case, hoistMaybe is a "monad morphism", which means that it should satisfy the following laws:

-- It preserves empty actions, meaning it doesn't have any accidental complexity
hoistMaybe (return x) = return x

-- It distributes over 'do' blocks
hoistMaybe $ do x <- m  =  do x <- hoistMaybe m
                f x           hoistMaybe (f x)

It's easy to prove the first law:

hoistMaybe (return x)

-- Definition of 'return' in the 'Maybe' monad:
= hoistMaybe (Just x)

-- Definition of 'hoistMaybe'
= MaybeT (return (Just x))

-- Definition of 'return' in the 'MaybeT' monad
= return x

We can also prove the second law, too:

hoistMaybe $ do x <- m
                f x

-- Definition of (>>=) in the 'Maybe' monad:
= hoistMaybe $ case m of
    Nothing -> Nothing
    Just a  -> f a

-- Definition of 'hoistMaybe'
= MaybeT $ return $ case m of
    Nothing -> Nothing
    Just a  -> f a

-- Distribute the 'return' over both case branches
= MaybeT $ case m of
    Nothing -> return Nothing
    Just a  -> return (f a)

-- Apply first monad law in reverse
= MaybeT $ do
    x <- return m
    case x of
        Nothing -> return Nothing
        Just a  -> return (f a)

-- runMaybeT (MaybeT x) = x
= MaybeT $ do
    x <- runMaybeT (MaybeT (return m))
    case x of
        Nothing -> return Nothing
        Just a  -> runMaybeT (MaybeT (return (f a)))

-- Definition of (>>=) for 'MaybeT m' monad in reverse
= do x <- MaybeT (return m)
     MaybeT (return (f x))

-- Definition of 'hoistMaybe' in reverse
= do x <- hoistMaybe m
     hoistMaybe (f x)

So that's how we can convince ourselves that we lifted the 'Maybe' to the 'MaybeT' correctly.

Edit: In response to your deleted request, this is how mheapOp inlines:

import Control.Monad
import Control.Error
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.State
import Data.Functor.Identity

-- (State s) is the exact same thing as (StateT s Identity):
-- type State s = StateT s Identity
type MHeap e r = MaybeT (State [e]) r

mheapOp :: Int -> MHeap Int Int
{-
mheapOp i = do 
    xs <- lift get
    a <- hoistMaybe (atMay xs i)
    lift $ modify (++ [a])
    return a

-- Inline 'return' and 'lift' for 'MaybeT', and also inline 'hoistMaybe'
mheapOp i = do 
    xs <- MaybeT $ liftM Just get
    a <- MaybeT $ return $ atMay xs i
    MaybeT $ liftM Just $ modify (++ [a])
    MaybeT $ return $ Just a

-- Desugar 'do' notation
mheapOp i =
    (MaybeT $ liftM Just get)               >>= \xs ->
     (MaybeT $ return $ atMay xs i)          >>= \a ->
      (MaybeT $ liftM Just $ modify (++ [a])) >>= \_ ->
       (MaybeT $ return $ Just a)

-- Inline first '(>>=)' (which uses 'MaybeT' monad)
mheapOp i =
    MaybeT $ do
        mxs <- runMaybeT (MaybeT $ liftM Just get)
        case mxs of
            Nothing -> return Nothing
            Just xs -> runMaybeT $
                (MaybeT $ return $ atMay xs i)          >>= \a ->
                 (MaybeT $ liftM Just $ modify (++ [a])) >>= \_ ->
                  (MaybeT $ return $ Just a)

-- runMaybeT (MaybeT x) = x
mheapOp i =
    MaybeT $ do
        mxs <- liftM Just get
        case mxs of
            Nothing -> return Nothing
            Just xs -> runMaybeT $
                (MaybeT $ return $ atMay xs i)          >>= \a ->
                 (MaybeT $ liftM Just $ modify (++ [a])) >>= \_ ->
                  (MaybeT $ return $ Just a)

-- Inline definition of 'liftM'
mheapOp i =
    MaybeT $ do
        mxs <- do xs' <- get
                return (Just xs')
        case mxs of
            Nothing -> return Nothing
            Just xs -> runMaybeT $
                (MaybeT $ return $ atMay xs i)          >>= \a ->
                 (MaybeT $ liftM Just $ modify (++ [a])) >>= \_ ->
                  (MaybeT $ return $ Just a)

{- Use third monad law (a.k.a. the "associativity law") to inline the inner do
   block -}
mheapOp i =
    MaybeT $ do
        xs  <- get
        mxs <- return (Just xs)
        case mxs of
            Nothing -> return Nothing
            Just xs -> runMaybeT $
                (MaybeT $ return $ atMay xs i)          >>= \a ->
                 (MaybeT $ liftM Just $ modify (++ [a])) >>= \_ ->
                  (MaybeT $ return $ Just a)

{- Use first monad law (a.k.a. the "left identity law"), which says that:

   x <- return y

   ... is the same thing as:

   let x = y
-}
mheapOp i =
    MaybeT $ do
        xs' <- get
        let mxs = Just xs'
        case mxs of
            Nothing -> return Nothing
            Just xs -> runMaybeT $
                (MaybeT $ return $ atMay xs i)          >>= \a ->
                 (MaybeT $ liftM Just $ modify (++ [a])) >>= \_ ->
                  (MaybeT $ return $ Just a)

-- Inline definition of 'mxs'
mheapOp i =
    MaybeT $ do
        xs' <- get
        case (Just xs') of
            Nothing -> return Nothing
            Just xs -> runMaybeT $
                (MaybeT $ return $ atMay xs i)          >>= \a ->
                 (MaybeT $ liftM Just $ modify (++ [a])) >>= \_ ->
                  (MaybeT $ return $ Just a)

{- The 'case' statement takes the second branch, binding xs' to xs.

   However, I choose to rename xs' to xs for convenience, rather than rename xs
   to xs'. -}
mheapOp i =
    MaybeT $ do
        xs <- get
        runMaybeT $ (MaybeT $ return $ atMay xs i)          >>= \a ->
                     (MaybeT $ liftM Just $ modify (++ [a])) >>= \_ ->
                      (MaybeT $ return $ Just a)

-- Inline the next '(>>=)'
mheapOp i =
    MaybeT $ do
        xs <- get
        runMaybeT $ MaybeT $ do
            ma <- runMaybeT $ MaybeT $ return $ atMay xs i
            case ma of
                Nothing -> return Nothing
                Just a -> runMaybeT $
                    (MaybeT $ liftM Just $ modify (++ [a])) >>= \_ ->
                     (MaybeT $ return $ Just a)

-- runMaybeT (MaybeT x) = x
mheapOp i =
    MaybeT $ do
        xs <- get
        do ma <- return $ atMay xs i
           case ma of
               Nothing -> return Nothing
               Just a -> runMaybeT $
                   (MaybeT $ liftM Just $ modify (++ [a])) >>= \_ ->
                    (MaybeT $ return $ Just a)

-- You can inline the inner 'do' block because it desugars to the same thing
mheapOp i =
    MaybeT $ do
        xs <- get
        ma <- return $ atMay xs i
        case ma of
            Nothing -> return Nothing
            Just a -> runMaybeT $
                (MaybeT $ liftM Just $ modify (++ [a])) >>= \_ ->
                 (MaybeT $ return $ Just a)

-- Use first monad law
mheapOp i =
    MaybeT $ do
        xs <- get
        let ma = atMay xs i
        case ma of
            Nothing -> return Nothing
            Just a -> runMaybeT $
                (MaybeT $ liftM Just $ modify (++ [a])) >>= \_ ->
                 (MaybeT $ return $ Just a)

-- Inline definition of 'ma'
mheapOp i =
    MaybeT $ do
        xs <- get
        case (atMay xs i) of
            Nothing -> return Nothing
            Just a -> runMaybeT $
                (MaybeT $ liftM Just $ modify (++ [a])) >>= \_ ->
                 (MaybeT $ return $ Just a)

-- Inline the next '(>>=)'
mheapOp i =
    MaybeT $ do
        xs <- get
        case (atMay xs i) of
            Nothing -> return Nothing
            Just a -> runMaybeT $ MaybeT $ do
                mv <- runMaybeT $ MaybeT $ liftM Just $ modify (++ [a])
                case mv of
                    Nothing -> return Nothing
                    Just _  -> runMaybeT $ MaybeT $ return $ Just a

-- runMaybeT (MaybeT x) = x
mheapOp i =
    MaybeT $ do
        xs <- get
        case (atMay xs i) of
            Nothing -> return Nothing
            Just a -> do
                mv <- liftM Just $ modify (++ [a])
                case mv of
                    Nothing -> return Nothing
                    Just _  -> return (Just a)

-- Inline definition of 'liftM'
mheapOp i =
    MaybeT $ do
        xs <- get
        case (atMay xs i) of
            Nothing -> return Nothing
            Just a -> do
                mv <- do x <- modify (++ [a])
                         return (Just x)
                case mv of
                    Nothing -> return Nothing
                    Just _  -> return (Just a)

-- Inline inner 'do' block using third monad law
mheapOp i =
    MaybeT $ do
        xs <- get
        case (atMay xs i) of
            Nothing -> return Nothing
            Just a -> do
                x  <- modify (++ [a])
                mv <- return (Just x)
                case mv of
                    Nothing -> return Nothing
                    Just _  -> return (Just a)

-- Use first monad law to turn 'return' into 'let'
mheapOp i =
    MaybeT $ do
        xs <- get
        case (atMay xs i) of
            Nothing -> return Nothing
            Just a -> do
                x  <- modify (++ [a])
                let mv = Just x
                case mv of
                    Nothing -> return Nothing
                    Just _  -> return (Just a)

-- Inline definition of 'mv'
mheapOp i =
    MaybeT $ do
        xs <- get
        case (atMay xs i) of
            Nothing -> return Nothing
            Just a -> do
                x  <- modify (++ [a])
                case (Just x) of
                    Nothing -> return Nothing
                    Just _  -> return (Just a)

-- case takes the 'Just' branch, binding 'x' to '_', which goes unused
mheapOp i =
    MaybeT $ do
        xs <- get
        case (atMay xs i) of
            Nothing -> return Nothing
            Just a -> do
                modify (++ [a])
                return (Just a)

{- At this point we've completely inlined the outer 'MaybeT' monad, converting
   it to a 'StateT' monad internally.  Before I inline the 'StateT' monad, I
   want to point out that if 'atMay' returns 'Nothing', the computation short
   circuits and doesn't call 'modify'.

   The next step is to inline the definitions of 'return, 'get', and 'modify':
-}
mheapOp i =
    MaybeT $ do
        xs <- StateT (\as -> return (as, as))
        case (atMay xs i) of
            Nothing -> StateT (\as -> return (Nothing, as))
            Just a -> do
                StateT (\as -> return ((), as ++ [a]))
                StateT (\as -> return (Just a , as))

-- Now desugar both 'do' blocks:
mheapOp i =
    MaybeT $
        StateT (\as -> return (as, as)) >>= \xs ->
         case (atMay xs i) of
             Nothing -> StateT (\as -> return (Nothing, as))
             Just a ->
                 StateT (\as -> return ((), as ++ [a])) >>= \_ ->
                  StateT (\as -> return (Just a , as))

-- Inline first '(>>=)', which uses 'StateT' monad instance
mheapOp i =
    MaybeT $ StateT $ \as0 -> do
        (xs, as1) <- runStateT (StateT (\as -> return (as, as))) as0
        runStateT (case (atMay xs i) of
            Nothing -> StateT (\as -> return (Nothing, as))
            Just a ->
                StateT (\as -> return ((), as ++ [a])) >>= \_ ->
                 StateT (\as -> return (Just a , as)) ) as1
                     --                                 ^
                     -- Play close attention to this s1 |

-- runStateT (StateT x) = x
mheapOp i =
    MaybeT $ StateT $ \as0 -> do
        (xs, as1) <- (\as -> return (as, as)) as0
        runStateT (case (atMay xs i) of
            Nothing -> StateT (\as -> return (Nothing, as))
            Just a ->
                StateT (\as -> return ((), as ++ [a])) >>= \_ ->
                 StateT (\as -> return (Just a , as)) ) as1

-- Apply (\as -> ...) to as0, binding 'as0' to 'as'
mheapOp i =
    MaybeT $ StateT $ \as0 -> do
        (xs, as1) <- return (as0, as0)
        runStateT (case (atMay xs i) of
            Nothing -> StateT (\as -> return (Nothing, as))
            Just a ->
                StateT (\as -> return ((), as ++ [a])) >>= \_ ->
                 StateT (\as -> return (Just a , as)) ) as1

-- Use first monad law to convert 'return' to 'let'
mheapOp i =
    MaybeT $ StateT $ \as0 -> do
        let (xs, as1) = (as0, as0)
        runStateT (case (atMay xs i) of
            Nothing -> StateT (\as -> return (Nothing, as))
            Just a ->
                StateT (\as -> return ((), as ++ [a])) >>= \_ ->
                 StateT (\as -> return (Just a , as)) ) as1

{- The let binding says that xs = as0 and as1 = as0, so I will rename all of
   them to 'xs' since they are all equal -}
mheapOp i =
    MaybeT $ StateT $ \xs -> do
        runStateT (case (atMay xs i) of
            Nothing -> StateT (\as -> return (Nothing, as))
            Just a ->
                StateT (\as -> return ((), as ++ [a])) >>= \_ ->
                 StateT (\as -> return (Just a , as)) ) xs

-- do m = m, so we can just get rid of the 'do'
mheapOp i =
    MaybeT $ StateT $ \xs ->
        runStateT (case (atMay xs i) of
            Nothing -> StateT (\as -> return (Nothing, as))
            Just a ->
                StateT (\as -> return ((), as ++ [a])) >>= \_ ->
                 StateT (\as -> return (Just a , as)) ) xs

-- Distribute the 'runStateT ... xs' over both 'case' branches
mheapOp i =
    MaybeT $ StateT $ \xs ->
        case (atMay xs i) of
            Nothing -> runStateT (StateT (\as -> return (Nothing, as))) xs
            Just a -> runStateT (
                StateT (\as -> return ((), as ++ [a])) >>= \_ ->
                 StateT (\as -> return (Just a , as)) ) xs

-- runStateT (StateT x) = x
mheapOp i =
    MaybeT $ StateT $ \xs ->
        case (atMay xs i) of
            Nothing -> (\as -> return (Nothing, as)) xs
            Just a -> runStateT (
                StateT (\as -> return ((), as ++ [a])) >>= \_ ->
                 StateT (\as -> return (Just a , as)) ) xs

-- Apply (\as -> ...) to 'xs', binding 'xs' to 'as'
mheapOp i =
    MaybeT $ StateT $ \xs ->
        case (atMay xs i) of
            Nothing -> return (Nothing, xs)
            Just a -> runStateT (
                StateT (\as -> return ((), as ++ [a])) >>= \_ ->
                 StateT (\as -> return (Just a , as)) ) xs

-- Inline the '(>>=)'
mheapOp i =
    MaybeT $ StateT $ \xs ->
        case (atMay xs i) of
            Nothing -> return (Nothing, xs)
            Just a -> runStateT (StateT $ \as0 -> do
                (_, as1) <- runStateT (StateT (\as -> return ((), as ++ [a]))) as0
                runStateT (StateT (\as -> return (Just a , as))) as1 ) xs

-- runStateT (StateT x) = x
mheapOp i =
    MaybeT $ StateT $ \xs ->
        case (atMay xs i) of
            Nothing -> return (Nothing, xs)
            Just a -> (\as0 -> do
                (_, as1) <- (\as -> return ((), as ++ [a])) as0
                (\as -> return (Just a , as)) as1 ) xs

-- Apply all the functions to their arguments
mheapOp i =
    MaybeT $ StateT $ \xs ->
        case (atMay xs i) of
            Nothing -> return (Nothing, xs)
            Just a -> (\as0 -> do
                (_, as1) <- return ((), as0 ++ [a])
                return (Just a , as1) ) xs

-- Use first monad law to convert 'return' to 'let'
mheapOp i =
    MaybeT $ StateT $ \xs ->
        case (atMay xs i) of
            Nothing -> return (Nothing, xs)
            Just a -> (\as0 -> do
                let (_, as1) = ((), as0 ++ [a])
                return (Just a , as1) ) xs

-- Let binding says that as1 = as0 ++ [a], so we can inline its definition
mheapOp i =
    MaybeT $ StateT $ \xs ->
        case (atMay xs i) of
            Nothing -> return (Nothing, xs)
            Just a  -> (\as0 -> do
                return (Just a , as0 ++ [a]) ) xs

-- do m = m
mheapOp i =
    MaybeT $ StateT $ \xs ->
        case (atMay xs i) of
            Nothing -> return (Nothing, xs)
            Just a  -> (\as0 -> return (Just a , as0 ++ [a])) xs

-- Apply (\as0 -> ...) to 'xs', binding 'xs' to 'as0'
mheapOp i =
    MaybeT $ StateT $ \xs ->
        case (atMay xs i) of
            Nothing -> return (Nothing, xs)
            Just a  -> return (Just a , xs ++ [a])

-- Factor out the 'return' from the 'case' branches, and tidy up the code
mheapOp i =
    MaybeT $ StateT $ \xs ->
        return $ case (atMay xs i) of
            Nothing -> (Nothing, xs)
            Just a  -> (Just a , xs ++ [a])
-}

-- One last step: that last 'return' is for the 'Identity' monad, defined as:
mheapOp i =
    MaybeT $ StateT $ \xs ->
        Identity $ case (atMay xs i) of
            Nothing -> (Nothing, xs)
            Just a  -> (Just a , xs ++ [a])

{- So now we can clearly say what the function does:

   * It takes an initial state named 'xs'

   * It calls 'atMay xs i' to try to find the 'i'th value of 'xs'

   * If 'atMay' returns 'Nothing, then our stateful function returns 'Nothing'
     and our original state, 'xs'

   * If 'atMay' return 'Just a', then our stateful function returns 'Just a'
     and a new state whose value is 'xs ++ [a]'

   Let's also walk through the types of each layer:

   layer1 :: [a] -> Identity (Maybe a, [a])
   layer1 = \xs ->
       Identity $ case (atMay xs i) of
           Nothing -> (Nothing, xs)
           Just a  -> (Just a, xs ++ [a])

   layer2 :: StateT [a] Identity (Maybe a)
   --   i.e. State  [a] (Maybe a)
   layer2 = StateT layer1

   layer3 :: MaybeT (State [a]) a
   layer3 = MaybeT layer2
-}