如何定義狀態monad？

Question

我想定義一個狀態monad來管理錯誤（從某種意義上來說可能是這樣）：如果在「do」計算過程中出現錯誤/問題，它將由>>=引導並傳播。 該錯誤還應包含描述它的字符串。 之後，我想將這個monad應用到mapTreeM，使用map來表示一個函數，該函數假設狀態爲數字和包含數字的樹，並且在每個訪問步驟中通過將當前葉的值添加到當前狀態來更新當前狀態;生成的樹必須包含一個具有舊葉值和訪問時刻狀態的對。如果在計算過程中狀態變爲負值，那麼這種訪問就會失敗，如果變爲正值，就會成功。

例如鑑於此樹：Branch (Branch (Leaf 7) (Branch (Leaf (-1)) (Leaf 3))) (Branch (Leaf (-2)) (Leaf 9))

我們得到一棵樹（考慮初始狀態0）：Branch (Branch (Leaf (7,7)) (Branch (Leaf (-1,6)) (Leaf (3,9)))) (Branch (Leaf (-2,7)) (Leaf (9,16)))

如果我們在第二葉放-18，我們應該得到我們達到了一個負面狀態(-11)錯誤值的信號。

我做了這樣的事情來打印樹沒有管理錯誤...我還沒有明白如何去做。 以下是我的代碼：

module Main where 

-- State monad 
newtype State st a = State (st -> (st, a)) 

instance Monad (State state) where 

return x = State(\s -> (s,x)) 

State f >>= g = State(\oldstate -> 
        let (newstate, val) = f oldstate 
         State newf  = g val 
        in newf newstate) 




-- Recursive data structure for representing trees 
data Tree a = Leaf a | Branch (Tree a) (Tree a) 
      deriving (Show,Eq) 


-- Utility methods  
getState :: State state state 
getState = State(\state -> (state,state)) 

putState :: state -> State state() 
putState new = State(\_ -> (new,())) 


mapTreeM :: (Num a) => (a -> State state b) -> Tree a -> State state (Tree b) 
mapTreeM f (Leaf a) = 
f a >>= (\b -> return (Leaf b)) 
mapTreeM f (Branch lhs rhs) = do 
lhs' <- mapTreeM f lhs 
rhs' <- mapTreeM f rhs 
return (Branch lhs' rhs') 


numberTree :: (Num a) => Tree a -> State a (Tree (a,a)) 
numberTree tree = mapTreeM number tree 
    where number v = do 
     cur <- getState 
     putState(cur+v) 
     return (v,cur+v) 

-- An instance of a tree       
testTree = (Branch 
       (Branch 
       (Leaf 7) (Branch (Leaf (-1)) (Leaf 3))) 
      (Branch 
       (Leaf (-2)) (Leaf (-20)))) 


runStateM :: State state a -> state -> a 
runStateM (State f) st = snd (f st) 


main :: IO()    
main = print $ runStateM (numberTree testTree) 0 

Answer 1

我可以提出替代解決問題了嗎？雖然Monads適用於很多事情，但您想要做的事情可以通過一個簡單的功能完成，該功能可以跟蹤錯誤。 下面是我的功能transferVal是這樣的功能的一個例子。 函數transferVal從左向右遍歷 Tree，同時保持找到最後一個值。如果發生錯誤，該函數將返回錯誤並停止遍歷Tree。 而不是使用Maybe，如果出現問題，通常最好使用Either <error_type> <result_type>以獲得更清晰的錯誤。在我的示例中，我使用([ChildDir],a)，其中[ChildDir]包含 指示節點的「方向」，而a是觸發該錯誤的錯誤值。功能printErrorsOrTree是一個示例，說明如何使用transferVal和main的輸出包含4個示例，其中前三個正確，最後一個觸發您期望的錯誤。

module Main where 

import Data.List  (intercalate) 
import Control.Monad (mapM_) 

data Tree a = Leaf a | Branch (Tree a) (Tree a) 
    deriving (Show,Eq) 

-- given a Branch, in which child the error is? 
data ChildDir = LeftChild | RightChild 
    deriving Show 

-- an error is the direction to get to the error from the root and the 
-- value that triggered the error 
type Error a = ([ChildDir],a) 

-- util to append a direction to an error 
appendDir :: ChildDir -> Error a -> Error a 
appendDir d (ds,x) = (d:ds,x) 

transferVal :: (Ord a,Num a) => Tree a -> Either (Error a) (Tree (a,a)) 
transferVal = fmap fst . go 0 
    where go :: (Ord a,Num a) => a -> Tree a -> Either (Error a) (Tree (a,a),a) 
     go c (Leaf x) = let newC = x + c 
         in if newC < 0 
          then Left ([],newC) 
          else Right (Leaf (x,newC),newC) 
     go c (Branch t1 t2) = case go c t1 of 
      Left e    -> Left $ appendDir LeftChild e 
      Right (newT1,newC) -> case go newC t2 of 
       Left    e -> Left $ appendDir RightChild e 
       Right (newT2,newC') -> Right (Branch newT1 newT2,newC') 

printErrorsOrTree :: (Show a,Show b) => Either (Error a) (Tree b) -> IO() 
printErrorsOrTree (Left (ds,x)) = putStrLn $ "Error in position " ++ (intercalate " -> " $ map show ds) ++ ". Error value is " ++ show x 
printErrorsOrTree (Right  t) = putStrLn $ "Result: " ++ show t 

main :: IO() 
main = mapM_ runExample 
      [(Leaf 1) 
      ,(Branch (Leaf 1) (Leaf 2)) 
      ,(Branch (Branch (Leaf 7) (Branch (Leaf (-1)) (Leaf 3))) (Branch (Leaf (-2)) (Leaf 9))) 
      ,(Branch (Branch (Leaf 7) (Branch (Leaf (-11)) (Leaf 3))) (Branch (Leaf (-2)) (Leaf 9)))] 
    where runExample orig = do 
      let res = transferVal orig 
      print orig 
      printErrorsOrTree res 

Answer 2

通過使您Tree數據類型的Traversable一個實例，你可以使用mapM（從Data.Traversable）映射在Tree動作。您還可以將StateT monad變壓器層疊到Either monad上，以提供錯誤處理。

import Control.Monad.State 
import Control.Applicative 
import Control.Monad.Error 
import Data.Monoid 
import Data.Foldable 
import Data.Traversable 
import qualified Data.Traversable as T 

-- our monad which carries state but allows for errors with string message  
type M s = StateT s (Either String) 

data Tree a = Leaf a | Branch (Tree a) (Tree a) 
      deriving (Show,Eq) 

-- Traversable requires Functor 
instance Functor Tree where 
    fmap f (Leaf a) = Leaf (f a) 
    fmap f (Branch lhs rhs) = Branch (fmap f lhs) (fmap f rhs) 

-- Traversable requires Foldable 
instance Foldable Tree where 
    foldMap f (Leaf a) = f a 
    foldMap f (Branch lhs rhs) = foldMap f lhs `mappend` foldMap f rhs 

-- Finally, we can get to Traversable 
instance Traversable Tree where 
    traverse f (Leaf a) = Leaf <$> f a 
    traverse f (Branch lhs rhs) = Branch <$> traverse f lhs <*> traverse f rhs 

testTree = (Branch 
       (Branch 
       (Leaf 7) (Branch (Leaf (-1)) (Leaf 3))) 
      (Branch 
       (Leaf (-2)) (Leaf (-20)))) 

numberTree :: (Num a, Ord a) => Tree a -> M a (Tree (a,a)) 
numberTree = T.mapM number where 
    number v = do 
     cur <- get 
     let nxt = cur+v 
     -- lift the error into the StateT layer 
     when (nxt < 0) $ throwError "state went negative" 
     put nxt 
     return (v, nxt) 

main :: IO() 
main = 
    case evalStateT (numberTree testTree) 0 of 
     Left e -> putStrLn $ "Error: " ++ e 
     Right t -> putStrLn $ "Success: " ++ show t