用于模仿 OO 风格代码的 haskell monad

Question

具体示例位于http://www.haskell.org/haskellwiki/State_Monad对于理解如何使用 monad 编写实际代码非常有帮助(另请参阅 stackoverflow/9014218)。但我们大多数新生都有面向对象背景，因此将面向对象程序映射到 haskell 将有助于演示如何编写等效的 haskell 代码。 (是的，这两种范式完全不同，将 OO 风格的代码直接翻译为 Haskell 并不明智，但这一次作为教程。)

这是一段OO风格的代码，它创建了一个对象的2个实例，然后调用成员函数来修改它们各自的成员变量，最后打印它们。我们如何使用 haskell 状态 monad 来编写这个？

class A:
    int p;
    bool q;
    A() { p=0; q=False;}    // constructor
    int y() {   // member function
        if(q) p++; else p--;
        return p;
    }
    bool z() {  // member function
        q = not q;
        return q;
    }
main:
    // main body - creates instances and calls member funcs
    a1 = A; a2 = A; // 2 separate instances of A
    int m = a1.y();
    m = m + a1.y();
    bool n = a2.z();
    print m, n, a1.p, a1.q, a2.p, a2.q;

Answer 1

直接翻译如下:

module Example where

import Control.Monad.State

data A = A { p :: Int, q :: Bool }

-- constructor
newA :: A
newA = A 0 False

-- member function
y :: State A Int
y = do
  b <- getQ
  modifyP $ if b then (+1) else (subtract 1)
  getP

-- member function
z :: State A Bool
z = do
  b <- gets q
  modifyQ not
  getQ

main :: IO ()
main = do
  let (m,a1) = flip runState newA $ do
      m <- y
      m <- (m +) `fmap` y
      return m
  let (n,a2) = flip runState newA $ do
      n <- z
      return n
  print (m, n, p a1, q a1, p a2, q a2)

-- general purpose getters and setters
getP :: State A Int
getP = gets p

getQ :: State A Bool
getQ = gets q

putP :: Int -> State A ()
putP = modifyP . const

putQ :: Bool -> State A ()
putQ = modifyQ . const

modifyP :: (Int -> Int) -> State A ()
modifyP f = modify $ \a -> a { p = f (p a) }

modifyQ :: (Bool -> Bool) -> State A ()
modifyQ f = modify $ \a -> a { q = f (q a) }

我可能不会费心手动 getter/setter，而只使用 lenses .

{-# LANGUAGE TemplateHaskell, FlexibleContexts #-}
module Main where

import Control.Applicative
import Control.Monad.State
import Data.Lenses
import Data.Lenses.Template

data A = A { p_ :: Int, q_ :: Bool } deriving Show
$( deriveLenses ''A )

-- constructor
newA :: A
newA = A 0 False

-- member function
y :: MonadState A m => m Int
y = do
  b <- q get
  if b then p $ modify (+1) else p $ modify (subtract 1) 
  p get

-- member function
z :: MonadState A m => m Bool
z = do
  q $ modify not
  q get


data Main = Main { a1_ :: A, a2_ :: A, m_ :: Int, n_ :: Bool } deriving Show
$( deriveLenses ''Main )

main :: IO ()
main = do
  -- main body - creates instances and calls member funcs
  print $ flip execState (Main undefined undefined undefined undefined) $ do
    a1 $ put newA ; a2 $ put newA -- 2 separate instances of A
    m . put =<< a1 y
    m . put =<< (+) <$> m get <*> a1 y
    n . put =<< a2 z

但这并不是我真正想写的，因为我正在将 Haskell 向后弯曲以尝试模仿 OO 风格。所以看起来很尴尬。

对我来说，面向对象代码的真正目的是针对接口(interface)进行编程。当我使用这些类型的对象时，我可以依靠它们来支持这些类型的方法。因此，在 haskell 中，我会使用类型类来做到这一点:

{-# LANGUAGE TemplateHaskell, FlexibleContexts #-}
module Main where

import Prelude hiding (lookup)
import Control.Applicative
import Control.Monad.State
import Data.Lenses
import Data.Lenses.Template
import Data.Map

class Show a => Example a where
  -- constructor
  new :: a
  -- member function
  y :: MonadState a m => m Int
  -- member function
  z :: MonadState a m => m Bool

data A = A { p_ :: Int, q_ :: Bool } deriving Show
$( deriveLenses ''A )

instance Example A where
  new = A 0 False
  y = do
    b <- q get
    if b then p $ modify (+1) else p $ modify (subtract 1) 
    p get
  z = do
    q $ modify not
    q get

data B = B { v_ :: Int, step :: Map Int Int } deriving Show
$( deriveLenses ''B )

instance Example B where
  new = B 10 . fromList $ zip [10,9..1] [9,8..0]
  y = v get
  z = do
    i <- v get
    mi <- lookup i `liftM` gets step 
    case mi of
      Nothing -> return False
      Just i' -> do
        v $ put i'
        return True

data Main a = Main { a1_ :: a, a2_ :: a, m_ :: Int, n_ :: Bool } deriving Show
start :: Example a => Main a
start = Main undefined undefined undefined undefined
$( deriveLenses ''Main )

run :: Example a => State (Main a) ()
run = do
  -- main body - creates instances and calls member funcs
  a1 $ put new ; a2 $ put new -- 2 separate instances of a
  m . put =<< a1 y
  m . put =<< (+) <$> m get <*> a1 y
  n . put =<< a2 z

main :: IO ()
main = do
  print $ flip execState (start :: Main A) run
  print $ flip execState (start :: Main B) run

现在我可以为不同类型的 A 和 B 重用相同的 run。