在 Haskell 中，有许多方法可以从代表各自职责的组件中组合计算。这可以在数据级别使用数据类型和函数 ( http://www.haskellforall.com/2012/05/scrap-your-type-classes.html ) 或使用类型类来完成。在 Haskell 中，您可以将每个数据类型、类型、函数、签名、类等视为一个接口；只要您有其他相同类型的东西，您就可以用兼容的东西替换组件。
当我们想推理 Haskell 中的计算时，我们经常使用 a 的抽象Monad。AMonad是用于构建计算的接口。可以使用 构建基础计算，return并且可以将这些计算与使用 产生其他计算的函数组合在一起>>=。当我们想为 monad 表示的计算添加多个职责时，我们制作了 monad 转换器。在下面的代码中，有四种不同的 monad 转换器可以捕获分层系统的不同方面：
DatabaseT s添加具有类型架构的数据库s。Operation它通过在数据库中存储数据或从数据库中检索数据来
处理数据。CacheT s拦截Operation模式的sdata 并从内存中检索数据（如果可用）。
OpperationLoggerT将Operations 记录到标准输出
将 sResultLoggerT的结果记录Operation到标准输出
这四个组件使用一个名为 的类型类（接口）进行通信MonadOperation s，这要求实现它的组件提供一种方法到performanOperation并返回其结果。
这个相同的类型类描述了使用MonadOperation s系统所需的内容。它要求使用该接口的人提供数据库和缓存所依赖的类型类的实现。此接口还有两种数据类型，Operation和CRUD. 请注意，该接口不需要知道有关域对象或数据库模式的任何信息，也不需要知道将实现它的不同 monad 转换器。monad 转换器对模式或域对象一无所知，域对象和示例代码对构建系统的 monad 转换器一无所知。
示例代码唯一知道的是，MonadOperation s由于它的 type ，它将可以访问 a example :: (MonadOperation TableName m) => m ()。
该程序main在两个不同的上下文中运行该示例两次。第一次，程序与数据库对话，其Operations和响应被记录到标准输出。
Running example program once with an empty database
Operation Articles (Create (Article {title = "My first article", author = "Cirdec", contents = "Lorem ipsum dolor sit amet."}))
ArticleId 0
Operation Articles (Read (ArticleId 0))
Just (Article {title = "My first article", author = "Cirdec", contents = "Lorem ipsum dolor sit amet."})
Operation Articles (Read (ArticleId 0))
Just (Article {title = "My first article", author = "Cirdec", contents = "Lorem ipsum dolor sit amet."})
第二次运行记录程序接收到的响应，通过Operation缓存，并在请求到达数据库之前记录它们。由于新的缓存对程序是透明的，读取文章的请求永远不会发生，但程序仍然会收到响应：
Running example program once with an empty cache and an empty database
Operation Articles (Create (Article {title = "My first article", author = "Cirdec", contents = "Lorem ipsum dolor sit amet."}))
ArticleId 0
Just (Article {title = "My first article", author = "Cirdec", contents = "Lorem ipsum dolor sit amet."})
Just (Article {title = "My first article", author = "Cirdec", contents = "Lorem ipsum dolor sit amet."})
这是整个源代码。您应该将其视为四段独立的代码： 为我们的领域编写的程序，从example. 一个应用程序，它是程序、话语域和构建它的各种工具的完整组合，从main. 接下来的两个部分，以架构结尾TableName，描述博客文章的领域；它们的唯一目的是说明其他组件如何组合在一起，而不是作为如何在 Haskell 中设计数据结构的示例。下一节描述了一个小接口，组件可以通过该接口进行数据通信；它不一定是一个好的界面。最后，源代码的其余部分实现了组合在一起形成应用程序的记录器、数据库和缓存。为了将工具和接口与域分离，这里有一些关于可类型化和动态的可怕技巧，这也不是为了演示处理转换和泛型的好方法。
{-# LANGUAGE StandaloneDeriving, GADTs, DeriveDataTypeable, FlexibleInstances, FlexibleContexts, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, KindSignatures, FunctionalDependencies, UndecidableInstances #-}
module Main (
main
) where
import Data.Typeable
import qualified Data.Map as Map
import Control.Monad.State
import Control.Monad.State.Class
import Control.Monad.Trans
import Data.Dynamic
-- Example
example :: (MonadOperation TableName m) => m ()
example =
do
id <- perform $ Operation Articles $ Create $ Article {
title = "My first article",
author = "Cirdec",
contents = "Lorem ipsum dolor sit amet."
}
perform $ Operation Articles $ Read id
perform $ Operation Articles $ Read id
cid <- perform $ Operation Comments $ Create $ Comment {
article = id,
user = "Cirdec",
comment = "Commenting on my own article!"
}
perform $ Operation Equality $ Create False
perform $ Operation Equality $ Create True
perform $ Operation Inequality $ Create True
perform $ Operation Inequality $ Create False
perform $ Operation Articles $ List
perform $ Operation Comments $ List
perform $ Operation Equality $ List
perform $ Operation Inequality $ List
return ()
-- Run the example twice, changing the cache transparently to the code
main :: IO ()
main = do
putStrLn "Running example program once with an empty database"
runDatabaseT (runOpperationLoggerT (runResultLoggerT example)) Types { types = Map.empty }
putStrLn "\nRunning example program once with an empty cache and an empty database"
runDatabaseT (runOpperationLoggerT (runCacheT (runResultLoggerT example) Types { types = Map.empty })) Types { types = Map.empty }
return ()
-- Domain objects
data Article = Article {
title :: String,
author :: String,
contents :: String
}
deriving instance Eq Article
deriving instance Ord Article
deriving instance Show Article
deriving instance Typeable Article
newtype ArticleId = ArticleId Int
deriving instance Eq ArticleId
deriving instance Ord ArticleId
deriving instance Show ArticleId
deriving instance Typeable ArticleId
deriving instance Enum ArticleId
data Comment = Comment {
article :: ArticleId,
user :: String,
comment :: String
}
deriving instance Eq Comment
deriving instance Ord Comment
deriving instance Show Comment
deriving instance Typeable Comment
newtype CommentId = CommentId Int
deriving instance Eq CommentId
deriving instance Ord CommentId
deriving instance Show CommentId
deriving instance Typeable CommentId
deriving instance Enum CommentId
-- Database Schema
data TableName k v where
Articles :: TableName ArticleId Article
Comments :: TableName CommentId Comment
Equality :: TableName Bool Bool
Inequality :: TableName Bool Bool
deriving instance Eq (TableName k v)
deriving instance Ord (TableName k v)
deriving instance Show (TableName k v)
deriving instance Typeable2 TableName
-- Data interface (Persistance library types)
data CRUD k v r where
Create :: v -> CRUD k v k
Read :: k -> CRUD k v (Maybe v)
List :: CRUD k v [(k,v)]
Update :: k -> v -> CRUD k v (Maybe ())
Delete :: k -> CRUD k v (Maybe ())
deriving instance (Eq k, Eq v) => Eq (CRUD k v r)
deriving instance (Ord k, Ord v) => Ord (CRUD k v r)
deriving instance (Show k, Show v) => Show (CRUD k v r)
data Operation s t k v r where
Operation :: t ~ s k v => t -> CRUD k v r -> Operation s t k v r
deriving instance (Eq (s k v), Eq k, Eq v) => Eq (Operation s t k v r)
deriving instance (Ord (s k v), Ord k, Ord v) => Ord (Operation s t k v r)
deriving instance (Show (s k v), Show k, Show v) => Show (Operation s t k v r)
class (Monad m) => MonadOperation s m | m -> s where
perform :: (Typeable2 s, Typeable k, Typeable v, t ~ s k v, Show t, Ord v, Ord k, Enum k, Show k, Show v, Show r) => Operation s t k v r -> m r
-- Database implementation
data Tables t k v = Tables {
tables :: Map.Map String (Map.Map k v)
}
deriving instance Typeable3 Tables
emptyTablesFor :: Operation s t k v r -> Tables t k v
emptyTablesFor _ = Tables {tables = Map.empty}
data Types = Types {
types :: Map.Map TypeRep Dynamic
}
-- Database emulator
mapOperation :: (Enum k, Ord k, MonadState (Map.Map k v) m) => (CRUD k v r) -> m r
mapOperation (Create value) = do
current <- get
let id = case Map.null current of
True -> toEnum 0
_ -> succ maxId where
(maxId, _) = Map.findMax current
put (Map.insert id value current)
return id
mapOperation (Read key) = do
current <- get
return (Map.lookup key current)
mapOperation List = do
current <- get
return (Map.toList current)
mapOperation (Update key value) = do
current <- get
case (Map.member key current) of
True -> do
put (Map.update (\_ -> Just value) key current)
return (Just ())
_ -> return Nothing
mapOperation (Delete key) = do
current <- get
case (Map.member key current) of
True -> do
put (Map.delete key current)
return (Just ())
_ -> return Nothing
tableOperation :: (Enum k, Ord k, Ord v, t ~ s k v, Show t, MonadState (Tables t k v) m) => Operation s t k v r -> m r
tableOperation (Operation tableName op) = do
current <- get
let currentTables = tables current
let tableKey = show tableName
let table = Map.findWithDefault (Map.empty) tableKey currentTables
let (result,newState) = runState (mapOperation op) table
put Tables { tables = Map.insert tableKey newState currentTables }
return result
typeOperation :: (Enum k, Ord k, Ord v, t ~ s k v, Show t, Typeable2 s, Typeable k, Typeable v, MonadState Types m) => Operation s t k v r -> m r
typeOperation op = do
current <- get
let currentTypes = types current
let empty = emptyTablesFor op
let typeKey = typeOf (empty)
let typeMap = fromDyn (Map.findWithDefault (toDyn empty) typeKey currentTypes) empty
let (result, newState) = runState (tableOperation op) typeMap
put Types { types = Map.insert typeKey (toDyn newState) currentTypes }
return result
-- Database monad transformer (clone of StateT)
newtype DatabaseT (s :: * -> * -> *) m a = DatabaseT {
databaseStateT :: StateT Types m a
}
runDatabaseT :: DatabaseT s m a -> Types -> m (a, Types)
runDatabaseT = runStateT . databaseStateT
instance (Monad m) => Monad (DatabaseT s m) where
return = DatabaseT . return
(DatabaseT m) >>= k = DatabaseT (m >>= \x -> databaseStateT (k x))
instance MonadTrans (DatabaseT s) where
lift = DatabaseT . lift
instance (MonadIO m) => MonadIO (DatabaseT s m) where
liftIO = DatabaseT . liftIO
instance (Monad m) => MonadOperation s (DatabaseT s m) where
perform = DatabaseT . typeOperation
-- State monad transformer can preserve operations
instance (MonadOperation s m) => MonadOperation s (StateT state m) where
perform = lift . perform
-- Cache implementation (very similar to emulated database)
cacheMapOperation :: (Enum k, Ord k, Ord v, t ~ s k v, Show t, Show k, Show v, Typeable2 s, Typeable k, Typeable v, MonadState (Map.Map k v) m, MonadOperation s m) => Operation s t k v r -> m r
cacheMapOperation op@(Operation _ (Create value)) = do
key <- perform op
modify (Map.insert key value)
return key
cacheMapOperation op@(Operation _ (Read key)) = do
current <- get
case (Map.lookup key current) of
Just value -> return (Just value)
_ -> do
value <- perform op
modify (Map.update (\_ -> value) key)
return value
cacheMapOperation op@(Operation _ (List)) = do
values <- perform op
modify (Map.union (Map.fromList values))
current <- get
return (Map.toList current)
cacheMapOperation op@(Operation _ (Update key value)) = do
successful <- perform op
modify (Map.update (\_ -> (successful >>= (\_ -> Just value))) key)
return successful
cacheMapOperation op@(Operation _ (Delete key)) = do
result <- perform op
modify (Map.delete key)
return result
cacheTableOperation :: (Enum k, Ord k, Ord v, t ~ s k v, Show t, Show k, Show v, Typeable2 s, Typeable k, Typeable v, MonadState (Tables t k v) m, MonadOperation s m) => Operation s t k v r -> m r
cacheTableOperation op@(Operation tableName _) = do
current <- get
let currentTables = tables current
let tableKey = show tableName
let table = Map.findWithDefault (Map.empty) tableKey currentTables
(result,newState) <- runStateT (cacheMapOperation op) table
put Tables { tables = Map.insert tableKey newState currentTables }
return result
cacheTypeOperation :: (Enum k, Ord k, Ord v, t ~ s k v, Show t, Show k, Show v, Typeable2 s, Typeable k, Typeable v, MonadState Types m, MonadOperation s m) => Operation s t k v r -> m r
cacheTypeOperation op = do
current <- get
let currentTypes = types current
let empty = emptyTablesFor op
let typeKey = typeOf (empty)
let typeMap = fromDyn (Map.findWithDefault (toDyn empty) typeKey currentTypes) empty
(result, newState) <- runStateT (cacheTableOperation op) typeMap
put Types { types = Map.insert typeKey (toDyn newState) currentTypes }
return result
-- Cache monad transformer
newtype CacheT (s :: * -> * -> *) m a = CacheT {
cacheStateT :: StateT Types m a
}
runCacheT :: CacheT s m a -> Types -> m (a, Types)
runCacheT = runStateT . cacheStateT
instance (Monad m) => Monad (CacheT s m) where
return = CacheT . return
(CacheT m) >>= k = CacheT (m >>= \x -> cacheStateT (k x))
instance MonadTrans (CacheT s) where
lift = CacheT . lift
instance (MonadIO m) => MonadIO (CacheT s m) where
liftIO = CacheT . liftIO
instance (Monad m, MonadOperation s m) => MonadOperation s (CacheT s m) where
perform = CacheT . cacheTypeOperation
-- Logger monad transform
newtype OpperationLoggerT m a = OpperationLoggerT {
runOpperationLoggerT :: m a
}
instance (Monad m) => Monad (OpperationLoggerT m) where
return = OpperationLoggerT . return
(OpperationLoggerT m) >>= k = OpperationLoggerT (m >>= \x -> runOpperationLoggerT (k x))
instance MonadTrans (OpperationLoggerT) where
lift = OpperationLoggerT
instance (MonadIO m) => MonadIO (OpperationLoggerT m) where
liftIO = OpperationLoggerT . liftIO
instance (MonadOperation s m, MonadIO m) => MonadOperation s (OpperationLoggerT m) where
perform op = do
liftIO $ putStrLn $ show op
lift (perform op)
-- Result logger
newtype ResultLoggerT m a = ResultLoggerT {
runResultLoggerT :: m a
}
instance (Monad m) => Monad (ResultLoggerT m) where
return = ResultLoggerT . return
(ResultLoggerT m) >>= k = ResultLoggerT (m >>= \x -> runResultLoggerT (k x))
instance MonadTrans (ResultLoggerT) where
lift = ResultLoggerT
instance (MonadIO m) => MonadIO (ResultLoggerT m) where
liftIO = ResultLoggerT . liftIO
instance (MonadOperation s m, MonadIO m) => MonadOperation s (ResultLoggerT m) where
perform op = do
result <- lift (perform op)
liftIO $ putStrLn $ "\t" ++ (show result)
return result
要构建此示例，您将需要mtl和containers库。
在 Haskell 中，您确实需要（并且想要！）了解任何执行 IO 的操作。
这是它的优点之一。
您可以使用MonadIO类型类编写在任何允许执行 IO 操作的 monad 中工作的函数：
myFunctionUsingIO :: (MonadIO m) => ... -> m someReturntype
myFunctionUsingIO = do
-- some code
liftIO $ ... -- some IO code
-- some other code
由于 Haskell 中的许多编程接口都是通过 monad 表达的，因此这样的函数可能在更多的上下文中工作。
您还可以使用unsafePerformIO纯代码秘密地运行 IO 操作 - 但是在几乎所有情况下都不建议这样做。纯粹可以让您立即查看是否使用了副作用。
IO 缓存是一个副作用，如果你的类型反映了这一点，你就很好了。