組成繼續和狀態monad變換器的正確方法

Question

我有用哈斯克爾編寫的原始解釋器。 該解釋器可以正確處理return語句（see my previous question）。

現在我想添加全局狀態到我的解釋器。 該狀態可以從全局代碼或功能代碼 （功能代碼使用runCont運行以提供return邏輯）運行。

的代碼是這裏介紹：

import Control.Monad.Cont 
import Control.Monad.State 

type MyState = String 
data Statement = Return Int | GetState | SetState MyState | FuncCall [Statement] deriving (Show) 
data Value = Undefined | Value Int | StateValue MyState deriving (Show) 

type Eval a = StateT MyState (Cont (Value, MyState)) a 

runEval ::(Eval Value) -> MyState -> (Value, MyState) 
runEval eval state = runCont (runStateT eval state) id 

evalProg :: [Statement] -> Value 
evalProg stmts = fst $ runEval (evalBlock stmts) $ "" 

evalBlock :: [Statement] -> Eval Value 
evalBlock [] = return Undefined 
evalBlock [stmt] = evalStatment stmt 
evalBlock (st:stmts) = evalStatment st >> evalBlock stmts 

evalStatment :: Statement -> Eval Value 
evalStatment (Return val) = do 
    state <- get 
    lift $ cont $ \_ -> (Value val, state) 
evalStatment (SetState state) = put state >> return Undefined 
evalStatment (FuncCall stmts) = do 
    -- I don't like this peace of code 
    state <- get 
    (value, newState) <- return $ runEval (evalBlock stmts) $ state 
    put newState 
    return value 
evalStatment GetState = get >>= return . StateValue 

test2 = evalProg [SetState "Hello", FuncCall [SetState "Galaxy", Return 3], GetState] -- result is StateValue "Galaxy" 

此代碼工作正常，但我不喜歡這個代碼evalStatment (FuncCall stmts)一部分。 我將解釋器的當前狀態傳遞給runEval函數，然後返回修改狀態並將其設置爲新解釋器的狀態。

是否有可能改進此代碼？我能以某種方式讓函數的代碼（FuncCall） 在翻譯的狀態隱含（沒有得到當前的狀態和運行功能的 代碼，並明確制定解釋的新的國家）操作？

Answer 1

我建議你改變自己的基本單子到

type Eval a = ContT Value (State MyState) a 

這樣一來，State MyState部分是在「單子轉換棧」的底部，你將只能夠更容易地拉斷上繼續部分而不影響狀態。然後FuncCall的情況下，可以簡單地

evalStatment (FuncCall stmts) = lift $ runContT (evalBlock stmts) return 

當然，這將需要重寫一些其他部分以及。但並不多，而且大部分都變得更簡單了！以下是我需要更改的所有部分：

type Eval a = ContT Value (State MyState) a 

runEval eval state = runState (runContT eval return) state 

evalStatment (Return val) = ContT $ \_ -> return (Value val) 

evalStatment (FuncCall stmts) = lift $ runContT (evalBlock stmts) return