9

具体来说，假设我有这个 monadT 堆栈：

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

和一个方便的 runMheap 函数：

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

我想创建一个MHeap查找列表的第 i 个元素（请注意，我们可能在此处出现超出范围的错误），然后如果该元素存在，则将其附加到列表的末尾，否则保持列表不变。在代码中：

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

请注意，我将我的问题放在上面的评论中。

此代码运行如下：

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])

你看，不出所料，元组的第一个元素是双重包装的，但我不知道如何在不调用结果的情况下摆脱它。换句话说，这会很好：

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

回顾一下，在 monadT 堆栈中调用纯函数并确保错误传播而不显式编写 case 语句的惯用方式是什么？

4

1 回答 1

11

我建议您坚持使用findAtIdx返回 a 的Nothing，而不是使用类似使用的部分(!!)函数error。您实际需要的是以下类型的函数：

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

这个函数可以让你将你的findAtIdx命令正确地嵌入到周围的MaybeTmonad 中，如下所示：

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

我们可以自己编写这个函数：

hoistMaybe ma = MaybeT (return ma)

或者您可以从库中导入它errors（完全披露：我写的）。请注意，此库还会为您重新导出库中的atMay函数safe，就像您的findAtIdx函数一样。

但是我们怎么知道这个函数做对了呢？好吧，通常当我们得到一个“正确”的函数时，它恰好遵循某种范畴论定律，这个函数也不例外。在这种特殊情况下，hoistMaybe是一个“单子态射”，这意味着它应该满足以下定律：

-- 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)

很容易证明第一定律：

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

我们也可以证明第二定律：

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)

所以这就是我们如何说服自己我们正确地将“Maybe”提升到“MaybeT”。

编辑：为了响应您删除的请求，这是内mheapOp联方式：

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
-}
于 2013-03-31T00:11:26.580 回答