如何在Haskell中执行复杂的IO处理和隐式缓存？ [英] How to do complex IO processing and implicit cache in Haskell?

问题描述

在更大的应用程序中，经常会有多层IO缓存（Hibernate L1和L2，Spring缓存等），这些通常是抽象的，因此调用者不需要意识到特定的实现是IO。有了一些警告（范围，事务），它允许组件之间的接口更简单。

例如，如果组件A需要查询数据库，则无需知道结果是否已被缓存。它可能已被B或C检索到，A对此一无所知，但它们通常会参与某些会话或事务 - 通常是隐含的。

使用AOP等技术，框架往往会使这种调用与简单的对象方法调用无法区分。

是否有可能Haskell应用程序能够像这样受益吗？客户端界面如何显示？

解决方案在Haskell中，有很多方法可以组成代表各自职责的组件进行计算。这可以通过数据类型和功能（ http ：//www.haskellforall.com/2012/05/scrap-your-type-classes.html ）或使用类型类。在Haskell中，您可以查看每个数据类型，类型，函数，签名，类等等作为接口;只要你有其他相同类型的东西，你可以用一些兼容的东西替换一个组件。

当我们想要推理Haskell中的计算时，我们经常使用抽象 Monad 。 Monad 是构造计算的接口。可以用 return 构造一个基本计算，并且这些计算可以与产生其他计算的函数一起构成，其中>> = 。当我们想要将多个责任添加到由monads表示的计算中时，我们会创建monad变换器。在下面的代码中，有四种不同的monad变换器可以捕获分层系统的不同方面：

DatabaseT s 添加一个类型为 s 的模式的数据库。它通过将数据存储在数据库中或从数据库中检索数据来处理数据操作 s。
CacheT s 截取数据操作 s用于模式 s 并从内存中检索数据（如果可用）。
OpperationLoggerT 将操作 s记录到标准输出
ResultLoggerT 将操作的结果记录到标准输出

这四个组件使用类型的类（接口）称为 MonadOperation s ，它要求实现它的组件提供了一种方法来执行执行 an Operation 并返回结果。

这个类描述了使用 MonadOperation s 系统。它要求使用接口的人提供数据库和缓存将依赖的类型类的实现。还有两个数据类型是该接口的一部分， Operation 和 CRUD 。请注意，接口不需要知道域对象或数据库模式的任何信息，也不需要知道将实现它的不同monad变换器。 monad变换器不知道任何有关模式或域对象的知识，而域对象和示例代码不知道构建系统的monad变换器。

示例代码唯一知道的是它可以访问 MonadOperation s ，因为它的类型为示例::（MonadOperation TableName m）= > m $

$ b $ main 在两个不同的上下文中运行这个例子两次。第一次，该程序与数据库进行交谈，使用它的 Operations 并将响应记录到标准输出中。

 使用空数据库运行示例程序
操作文章（创建}））
 ArticleId 0 
操作文章（阅读（ArticleId 0））
 Just（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。}）
  

第二次运行记录程序收到的响应，将操作 s，并在请求到达数据库之前记录请求。由于对程序透明的新缓存，读取文章的请求从不发生，但程序仍然收到响应：



 运行一个带空缓存和空数据库的示例程序
操作文章（创建文章{a​​rticle =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（文章{title =我的第一篇文章，作者=Cirdec，内容=Lorem ipsum dolor sit amet。））
  

这是整个源代码。您应该将它看作四个独立的代码片段：一个为我们的域编写的程序，从例如开始。从 main 开始的一个应用程序，它是程序的完整组合，话语领域以及构建它的各种工具。接下来的两节以模式 TableName 结尾，描述了博客帖子的域;他们唯一的目的是说明其他组件如何结合在一起，而不是作为如何在Haskell中设计数据结构的示例。下一部分描述了一个小组件可以通过数据进行通信的小界面;它不一定是一个好的界面。最后，源代码的其余部分实现了组成应用程序的记录器，数据库和高速缓存。为了将工具和界面从域中分离出来，在这里有一些可敲打和动态的可怕的技巧，但这并不意味着要演示处理cast和泛型的好方法。

  { - ＃LANGUAGE StandaloneDeriving，GADTs，DeriveDataTypeable，FlexibleInstances，FlexibleContexts，GeneralizedNewtypeDeriving，MultiParamTypeClasses，ScopedTypeVariables，KindSignatures，FunctionalDependencies，UndecidableInstances＃ - } 
 
模块Main（
 main 
）其中
 
导入Data.Typeable 
将限定的Data.Map导入为映射
导入Control.Monad.State 
导入Control.Monad.State.Class 
导入Control.Monad.Trans 
导入Data.Dynamic 
 
  - 示例
 
例如： ：（MonadOperation TableName m）=> m $）
 example = 
 do 
 id<  - 执行$操作文章$创建$ Article {
 title =我的第一篇文章，
 author = Cirdec，
 contents =Lorem ipsum dolor sit amet。 
} 
执行$操作文章$读取ID 
执行$操作文章$读取ID 
 cid<  - 执行$操作注释$创建$注释{
 article = id，
 user =Cirdec，
 comment =评论我自己的文章！ 
} 
 
执行$操作平等$创建假
执行$操作平等$创建真
执行$操作不等式$创建真
执行$操作不等式$ Create False 
 
执行$操作文章$ List 
执行$操作注释$ List 
执行$操作Equality $ List 
执行$操作不等式$ List 
返回（）
 
  - 运行示例两次，将缓存透明地更改为代码
 $ b $ main :: IO（）
 main = do 
 putStrLn使用空数据库运行一次示例程序
 runDatabaseT（runOpperationLoggerT（runResultLoggerT示例））类型{types = Map.empty} 
 putStrLn\\\
运行一个带有空缓存的示例程序，空数据库
 runDatabaseT（runOpperationLoggerT（runCacheT（runResultLoggerT示例）Types {types = Map.empty}））Types {types = Ma p.empty} 
 return（）
 
  - 域对象
 
 data Article = Article {
 title :: String，
 author ::字符串，
内容::字符串
 
} 
派生实例公式条目
派生实例Ord Article 
派生实例显示文章
派生实例类型化文章
 
 newtype ArticleId = ArticleId Int 
 
派生实例Eq ArticleId 
派生实例Ord ArticleId 
派生实例显示ArticleId 
派生实例Typeable ArticleId 
导出实例Enum ArticleId 
 
 data Comment =评论{
 article :: ArticleId，
 user :: String，
 comment :: String 
} 
 
派生实例Eq注释
派生实例Ord注释
派生实例显示注释
派生实例可类型注释
 
 newtype CommentId = CommentId Int 
 
导出实例Eq CommentId 
导出实例Ord CommentId 
导出立场显示CommentId 
派生实例Typeable CommentId 
派生实例Enum CommentId 
 
  - 数据库架构
 
数据TableName kv其中
文章:: TableName ArticleId Article 
 Comments :: TableName CommentId注释
 Equality :: TableName Bool Bool 
 Inequality :: TableName Bool Bool 
 
派生实例Eq（TableName kv）
派生实例Ord（TableName kv）
派生实例Show（TableName kv）
派生实例Typeable2 TableName 
 
  - 数据接口（Persistance库类型）
 
 data CRUD kvr where 
 Create :: v  - > CRUD k v k 
阅读:: 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（））
 
导出实例（Eq k，Eq v）=>等式（CRUD k v r）
导出实例（Ord k，Ord v）=> Ord（CRUD k v r）
导出实例（Show k，Show v）=>显示（CRUD k v r）
 
 data操作s t k v r其中
操作:: t〜s k v => t  - > CRUD k v r  - >操作s t k v r 
 
导出实例（Eq（s k v），Eq k，Eq v）=>等式（Ord（s k v），Ord k，Ord v）=> Ord（Operation s t k v r）
导出实例（Show（s k v），Show k，Show v）=> Show（Operation s t k v r）
 
 class（Monad m）=> MonadOperation s m | m  - > （Typeable2 s，Typeable k，Typeable v，t〜s k v，Show t，Ord v，Ord k，Enum k，Show k，Show v，Show r）=>操作s t k v r  - > mr 
 
  - 数据库实现
 
数据表tkv =表{
 tables :: Map.Map String（Map.Map kv）
} 
 
派生实例Typeable3表
 
 emptyTablesFor ::操作stkvr  - > Table tkv 
 emptyTablesFor _ = Tables {tables = Map.empty} 
 
 data Types = Types {
 types :: Map.Map TypeRep Dynamic 
} 
 
  - 数据库模拟器
 
 mapOperation ::（Enum k，Ord k，MonadState（Map.Map kv）m）=> （CRUD k v r） - > m r 
 mapOperation（创建值）= do 
 current < -  get 
 let id = case Map.null current 
 True  - > toEnum 0 
 _  - > succ maxId其中
（maxId，_）= Map.findMax当前
 put（Map.insert id value current）
返回id 
 mapOperation（读取键）= do 
当前<  - 获得
返回（Map.lookup键值当前）
 mapOperation List = do 
当前<  - 获得
返回（Map.toList当前）
 mapOperation（更新键值）= do 
 current<  - 获得
 case（Map.member key current）of 
 True  - > （Map.update（\_-> Just value）key current）
 return（Just（））
 _  - >返回Nothing 
 mapOperation（删除键）= do 
 current<  - 获得
 case（Map.member key current）of 
 True  - > 
 put（Map.delete key current）
 return（Just（））
 _  - >返回Nothing 
 
 tableOperation ::（Enum k，Ord k，Ord v，t〜s k v，Show t，MonadState（Tables t k v）m）=>操作s t k v r  - > mr 
 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} 
返回结果
 
 typeOperation ::（Enum k，Ord k，Ord v，t〜skv，Show t，Typeable2 s，Typeable k，Typeable v，MonadState Types m）=>操作s t k v r  - > mr 
 typeOperation op = do 
 current<  -  get 
 let currentTypes = types current 
 let empty = emptyTablesFor op 
 let typeKey = typeOf（empty）
让typeMap = fromDyn（Map.findWithDefault（toDyn empty）typeKey currentTypes）empty 
 let（result，newState）= runState（tableOperation op）typeMap 
 put类型{types = Map.insert typeKey（toDyn newState ）currentTypes} 
返回结果
 
  - 数据库单子变换（StateT的克隆）
 
 newtype DatabaseT（s :: *  - > *  - > * ）ma = DatabaseT {
 databaseStateT :: StateT Types ma 
} 
 
 runDatabaseT :: DatabaseT sma  - >类型 - > m（a，类型）
 runDatabaseT = runStateT。 databaseStateT 
 
 instance（Monad m）=> Monad（DatabaseT s m）其中
 return = DatabaseT。返回
（DatabaseT m）>>> = k = DatabaseT（m>> = \ x  - > databaseStateT（kx））
 
实例MonadTrans（DatabaseT s）where 
 lift = DatabaseT。提升
 
实例（MonadIO m）=> MonadIO（DatabaseT s m）其中
 liftIO = DatabaseT。 liftIO 
 
实例（Monad m）=> MonadOperation（DatabaseT s m）其中
执行= DatabaseT。 typeOperation 
 
  -  State monad变换器可以保留操作
 
 
 instance（MonadOperation s m）=> MonadOperation（StateT状态m）其中
执行=提升。执行
 
  - 缓存实现（非常类似于模拟数据库）
 
 cacheMapOperation ::（Enum k，Ord k，Ord v，t〜skv，Show t，Show k ，Show v，Typeable2 s，Typeable k，Typeable v，MonadState（Map.Map kv）m，MonadOperation sm）=>操作s t k v r  - > mr 
 cacheMapOperation op @（Operation _（Create value））= do 
 key<  - 执行op 
 modify（Map.insert键值）
返回键
 cacheMapOperation op @（Operation _（Read key））= do 
 current<  -  get 
 case（Map.lookup key current）of 
 Just value  - >返回（Just value）
 _  - > 
 value < - 执行op 
 modify（Map.update（\_-> value）key）
返回值
 cacheMapOperation op @（Operation _（List） ）= do 
值<  - 执行op 
 modify（Map.union（Map.fromList values））
 current<  -  get 
 return（Map.toList current）
 cacheMapOperation op @（Operation _（Update key value））= do 
 successful<  - 执行op 
 modify（Map.update（\_->（successful>> = （\_- && Just value）））key）
返回成功
 cacheMapOperation op @（Operation _（Delete key））= do 
 result<  - 执行op 
修改（Map.delete键）
返回结果
 
 
 cacheTableOperation ::（Enum k，Ord k，Ord v，t〜skv，Show t，Show k，Show v，Typeable2 s，Typeable k，Typeable v，MonadState（Tables tkv）m，MonadOperation sm）=>操作s t k v r  - > mr 
 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 
 $ b $ cacheTypeOperation ::（Enum k，Ord k，Ord v，t〜skv，Show t，Show k，Show v，Typeable2 s，Typeable k，Typeable v，MonadState Types m，MonadOperation sm）= >操作s t k v r  - > mr 
 cacheTypeOperation op = do 
 current<  -  get 
 let currentTypes = types current 
 let empty = emptyTablesFor op 
 let typeKey = typeOf（empty）
让typeMap = fromDyn（Map.findWithDefault（toDyn empty）typeKey currentTypes）empty 
（result，newState）<  -  runStateT（cacheTableOperation op）typeMap 
 put类型{types = Map.insert typeKey（toDyn newState）currentTypes} 
返回结果
 
  - 缓存monad变换器
 
 newtype CacheT（s :: *  - > *  - > *）ma = CacheT {
 cacheStateT :: StateT类型ma 
} 
 
 runCacheT :: CacheT sma  - >类型 - > m（a，类型）
 runCacheT = runStateT。 cacheStateT 
 
 instance（Monad m）=> Monad（CacheT s m）其中
 return = CacheT。返回
（CacheT m）>> = k = CacheT（m>> = \ x  - > cacheStateT（kx））
 
实例MonadTrans（CacheT s）where 
 lift = CacheT。提升
 
实例（MonadIO m）=> MonadIO（CacheT s m）其中
 liftIO = CacheT。 liftIO 
 
实例（Monad m，MonadOperation s m）=> MonadOperation s（CacheT s m）其中
执行= CacheT。 cacheTypeOperation 
 
  -  Logger monad transform 
 
 newtype OpperationLoggerT ma = OpperationLoggerT {
 runOpperationLoggerT :: ma 
} 
 
 instance （Monad m）=> Monad（OpperationLoggerT m）其中
 return = OpperationLoggerT。返回
（OpperationLoggerT m）>> = k = OpperationLoggerT（m>> = \ x  - > runOpperationLoggerT（kx））
 
实例MonadTrans（OpperationLoggerT） b $ b lift = OpperationLoggerT 
 
 instance（MonadIO m）=> MonadIO（OpperationLoggerT m）其中
 liftIO = OpperationLoggerT。 liftIO 
 
实例（MonadOperation s m，MonadIO m）=> MonadOperation s（OpperationLoggerT m）其中
执行op = do 
 liftIO $ putStrLn $ show op 
提升（执行op）
 
  - 结果记录器
 
 newtype ResultLoggerT ma = ResultLoggerT {
 runResultLoggerT :: ma 
} 
 
 instance（Monad m）=> Monad（ResultLoggerT m）其中
 return = ResultLoggerT。返回
（ResultLoggerT m）>>> = k = ResultLoggerT（m>> = \ x  - > runResultLoggerT（kx））
 
实例MonadTrans（ResultLoggerT） b $ b lift = ResultLoggerT 
 
 instance（MonadIO m）=> MonadIO（ResultLoggerT m）其中
 liftIO = ResultLoggerT。 liftIO 
 
实例（MonadOperation s m，MonadIO m）=> MonadOperation s（ResultLoggerT m）其中
执行op = do 
 result<  -  lift（执行op）
 liftIO $ putStrLn $\ t++（显示结果）
返回结果
  

要构建此示例，您需要 mtl 和容器库。

In bigger applications there are very often multiple layers of IO caching (Hibernate L1 and L2, Spring cache etc.) which usually are abstracted so that caller needs not to be aware that particular implementation does IO. With some caveats (scope, transactions), it allows for simpler interfaces between components.

For example, if component A needs to query database, it needs not to know whether result is already cached. It might have been retrieved by B or C which A knows nothing about, however they would usually participate in some session or transaction - often implicitly.

Frameworks tend to make this call indistinguishable from simple object method call using techniques like AOP.

Is it possible for Haskell applications to benefit like this? How would client's interface look like?

解决方案

In Haskell there are many ways to compose computations from components that represent their separate responsibilities. This can be done at the data level with data types and functions (http://www.haskellforall.com/2012/05/scrap-your-type-classes.html) or using type classes. In Haskell you can view every data type, type, function, signature, class, etc as an interface; as long as you have something else of the same type, you can replace a component with something that's compatible.

When we want to reason about computations in Haskell we frequently use the abstraction of a Monad. A Monad is an interface for constructing computations. A base computation can be constructed with return and these can be composed together with functions that produce other computations with >>=. When we want to add multiple responsibilities to computations represented by monads, we make monad transformers. In the code below, there are four different monad transformers that capture different aspects of a layered system:

DatabaseT s adds a database with a schema of type s. It handles data Operations by storing data in or retrieving it from the database. CacheT s intercepts data Operations for a schema s and retrieves data from memory, if it is available. OpperationLoggerT logs the Operations to standard output ResultLoggerT logs the results of Operations to standard output

These four components communicate together using a type class (interface) called MonadOperation s, which requires that components that implement it provide a way to perform an Operation and return its result.

This same type class described what is required to use the MonadOperation s system. It requires that someone using the interface provide implementations of type classes that the database and cache will rely on. There are also two data types that are part of this interface, Operation and CRUD. Notice that the interface doesn't need to know anything about the domain objects or database schema, nor does it need to know about the different monad transformers that will implement it. The monad transformers don't know anything about the schema or domain objects, and the domain objects and example code don't know anything about the monad transformers that build the system.

The only thing the example code knows is that it will have access to a MonadOperation s due to its type example :: (MonadOperation TableName m) => m ().

The program main runs the example twice in two different contexts. The first time, the program talks to the database, with its Operations and responses being logged to standard out.

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."})

The second run logs the responses the program receives, passes Operations through the cache, and logs the requests before they reach the database. Due to the new caching, which is transparent to the program, the requests to read the article never happen, but the program still receives a response:

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."})

Here's the entire source code. You should think of it as four independent pieces of code: A program written for our domain, starting at example. An application that is the complete assembly of the program, the domain of discourse, and the various tools that build it, starting at main. The next two sections, ending with the schema TableName, describe a domain of blog posts; their only purpose is to illustrate how the other components go together, not to serve as an example for how to design data structures in Haskell. The next section describes a small interface by which components could communicate about data; it's not necessarily a good interface. Finally, the remainder of the source code implements the loggers, database, and caches that are composed together to form the application. In order to decouple the tools and interface from the domain, there are some somewhat hideous tricks with typeable and dynamics in here, this isn't meant to demonstrate a good way to handle casting and generics either.

{-# 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

To build this example, you'll need the mtl and containers libraries.

这篇关于如何在Haskell中执行复杂的IO处理和隐式缓存？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！