我建议您坚持使用findAtIdx
返回 a 的Nothing
,而不是使用类似使用的部分(!!)
函数error
。您实际需要的是以下类型的函数:
hoistMaybe :: (Monad m) => Maybe a -> MaybeT m a
这个函数可以让你将你的findAtIdx
命令正确地嵌入到周围的MaybeT
monad 中,如下所示:
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
-}