Haskell 趣学指南 第二部分

Posted on:2021.08.06

TOC

Open TOC

类型

类型检查

Prelude> :t 'a'
'a' :: Char
Prelude> :t True
True :: Bool

显式类型声明

addThree :: Int -> Int -> Int -> Int
addThree x y z = x + y + z

基本类型

类型变量（参数）

泛型、多态

Prelude> :t head
head :: [a] -> a
Prelude> :t fst
fst :: (a, b) -> a

类型类

类型约束

Prelude> :t (==)
(==) :: Eq a => a -> a -> Bool

常见类型类

类型注解

::

Prelude> read "5"
*** Exception: Prelude.read: no parse
Prelude> read "5" :: Int
5

自定义类型

值构造器

data 类型名 = 值构造器

类型名和值构造器的首字母必须大写

data Bool = False | True

值构造器的本质：返回某数据类型值的函数

Prelude> data Shape = Circle Float Float Float | Rectangle Float Float Float Float
Prelude> :t Circle
Circle :: Float -> Float -> Float -> Shape

对值构造器进行模式匹配

area :: Shape -> Float
area (Circle _ _ r) = pi * r ^ 2
area (Rectangle x1 x2 y1 y2) = (abs $ x2 - x1) * (abs $ y2 - y1)

将自定义类型导出到模块中

借助 Point 数据类型优化 Shape 数据类型

将要导出的类型和函数写到一起，可以选择是否导出值构造器

Shape(..) 表示导出 Shape 的所有值构造器，等价于 Shape(Circle,Rectangle)

若只写 Shape，使用模块的用户只能使用 baseCircle 和 baseRect 来得到 Shape 了，同时也无法使用该值构造器进行模式匹配了

module Shapes
(
    Point(..),
    Shape(..),
    area,
    nudge,
    baseCircle,
    baseRect
)
where


data Point = Point Float Float deriving (Show)
data Shape = Circle Point Float | Rectangle Point Point deriving (Show)


area :: Shape -> Float
area (Circle _ r) = pi * r ^ 2
area (Rectangle (Point x1 y1) (Point x2 y2)) = (abs $ x2 - x1) * (abs $ y2 - y1)


nudge :: Shape -> Float -> Float -> Shape
nudge (Circle (Point x y) r) a b = Circle (Point (x+a) (y+b)) r
nudge (Rectangle (Point x1 y1) (Point x2 y2)) a b = Rectangle (Point (x1+a) (y1+b)) (Point (x2+a) (y2+b))


baseCircle :: Float -> Shape
baseCircle r = Circle (Point 0 0) r


baseRect :: Float -> Float -> Shape
baseRect width height = Rectangle (Point 0 0) (Point width height)

测试

*Shapes> :t Point
Point :: Float -> Float -> Point
*Shapes> nudge (baseRect 40 100) 60 23
Rectangle (Point 60.0 23.0) (Point 100.0 123.0)
*Shapes> area $ baseCircle 100
31415.928
*Shapes> baseCircle 100
Circle (Point 0.0 0.0) 100.0
*Shapes> map (Circle (Point 3 4)) [4,5,6,6]
[Circle (Point 3.0 4.0) 4.0,Circle (Point 3.0 4.0) 5.0,Circle (Point 3.0 4.0) 6.0,Circle (Point 3.0 4.0) 6.0]

记录语法

自动创建函数，允许直接按字段取值

data Car = Car {company :: String, model :: String, year :: Int} deriving (Show)

测试

*Main> :t year
year :: Car -> Int
*Main> Car {company="Ford", model="Mustang", year=1967}
Car {company = "Ford", model = "Mustang", year = 1967}
*Main> year $ Car {company="Ford", model="Mustang", year=1967}
1967

类型构造器

data 类型名 类型变量 = 值构造器

值构造器可以取几个参数，产生一个新值；类型构造器可以取类型作为参数，产生新的类型

声明中不允许添加类型约束，如 data (Num a) => Vector a = Vector a a a deriving (Show)，否则导入时会报错

Prelude> :l Main.hs
[1 of 1] Compiling Main             ( Main.hs, interpreted )


Main.hs:1:6: error:
    Illegal datatype context (use DatatypeContexts): (Num a) =>
  |
1 | data (Num a) => Vector a = Vector a a a deriving (Show)
  |      ^^^^^^^
Failed, no modules loaded.
Prelude>

实例：Maybe

正因为有了类型变量，Maybe 才成为了类型构造器

data Maybe a = Nothing | Just a

自动类型推导 & 类型注解

Prelude> Just "Haha"
Just "Haha"
Prelude> Just 84
Just 84
Prelude> :t Just "Haha"
Just "Haha" :: Maybe [Char]
Prelude> :t Just 84
Just 84 :: (Num t) => Maybe t
Prelude> :t Nothing
Nothing :: Maybe a
Prelude> Just 10 :: Maybe Double
Just 10.0

实例：Either

data Either a b = Left a | Right b deriving (Eq, Ord, Read, Show)

测试

Prelude> Right 20
Right 20
Prelude> Left "w00t"
Left "w00t"
Prelude> :t Right 'a'
Right 'a' :: Either a Char
Prelude> :t Left True
Left True :: Either Bool b

实例：向量函数

data Vector a = Vector a a a deriving (Show)


vplus :: (Num t) => Vector t -> Vector t -> Vector t
(Vector i j k) `vplus` (Vector l m n) = Vector (i+l) (j+m) (k+n)


vectMult :: (Num t) => Vector t -> t -> Vector t
(Vector i j k) `vectMult` m = Vector (i*m) (j*m) (k*m)


scalarMult :: (Num t) => Vector t -> Vector t -> t
(Vector i j k) `scalarMult` (Vector l m n) = i*l + j*m + k*n

测试

*Main> Vector 3 5 8 `vplus` Vector 9 2 8
Vector 12 7 16
*Main> Vector 3 5 8 `vplus` Vector 9 2 8 `vplus` Vector 0 2 3
Vector 12 9 19
*Main> Vector 3 9 7 `vectMult` 10
Vector 30 90 70
*Main> Vector 4 9 5 `scalarMult` Vector 9.0 2.0 4.0
74.0
*Main> Vector 2 9 3 `vectMult` (Vector 4 9 5 `scalarMult` Vector 9 2 4)
Vector 148 666 222

派生实例

关键词 deriving

注：此处类型 Day 没有类型参数，是具体的；若一个类型有类型参数，在派生后必须要有相应的类型约束，另见作为类型类实例的带参数类型

data Day = Monday | Tuesday | Wednesday | Thursday | Friday | Saturday | Sunday deriving (Eq, Ord, Show, Read, Bounded, Enum)

测试

*Main> Wednesday
Wednesday
*Main> show Wednesday
"Wednesday"
*Main> read "Saturday" :: Day
Saturday
*Main> Saturday == Sunday
False
*Main> Saturday == Saturday
True
*Main> Saturday > Friday
True
*Main> Monday `compare` Wednesday
LT
*Main> minBound :: Day
Monday
*Main> maxBound :: Day
Sunday
*Main> succ Monday
Tuesday
*Main> pred Saturday
Friday
*Main> [Thursday .. Sunday]
[Thursday,Friday,Saturday,Sunday]
*Main> [minBound .. maxBound] :: [Day]
[Monday,Tuesday,Wednesday,Thursday,Friday,Saturday,Sunday]

类型别名

type 新名 = 原名 

type String = [Char]

类型别名只可以在 Haskell 的类型部分中使用，如 data 声明和 type 声明，以及显式类型声明和类型注解中跟在 :: 后面的部分

参数化类型别名

type IntMap = Map Int

实际上是

type IntMap v = Map Int v

来看一个例子

import qualified Data.Map as Map


data LockerState = Taken | Free deriving (Show, Eq)
type Code = String
type LockerMap = Map.Map Int (LockerState, Code)


lockerLookup :: Int -> LockerMap -> Either String Code
lockerLookup lockerNumber map = case Map.lookup lockerNumber map of
    Nothing -> Left $ "Locker number " ++ show lockerNumber ++ " doesn't exist!"
    Just (state, code) ->
        if state /= Taken
        then Right code
        else Left $ "Locker " ++ show lockerNumber ++ "is already taken!"


lockers :: LockerMap
lockers = Map.fromList [
    (100,(Taken,"ZD39I")),
    (101,(Free,"JAH3I")),
    (103,(Free,"IQSA9")),
    (105,(Free,"QOTSA")),
    (109,(Taken,"893JJ")),
    (110,(Taken,"99292"))]

测试

*Main> lockerLookup 101 lockers
Right "JAH3I"
*Main> lockerLookup 100 lockers
Left "Locker 100is already taken!"
*Main> lockerLookup 102 lockers
Left "Locker number 102 doesn't exist!"
*Main> lockerLookup 110 lockers
Left "Locker 110is already taken!"
*Main> lockerLookup 105 lockers
Right "QOTSA"

递归数据结构

Fixity declaration

指定了运算符的优先级和结合性

中缀值构造器必须以冒号开头

infixr 5 :-:
data List a = Empty | a :-: (List a) deriving (Show, Read, Eq, Ord)


infixr 5 .++
(.++) :: List a -> List a -> List a
Empty .++ ys = ys
(x :-: xs) .++ ys = x :-: (xs .++ ys)

测试

*Main> 3 :-: 4 :-: 5 :-: Empty
(:-:) 3 ((:-:) 4 ((:-:) 5 Empty))
*Main> let a = 3 :-: 4 :-: 5 :-: Empty
*Main> 100 :-: a
(:-:) 100 ((:-:) 3 ((:-:) 4 ((:-:) 5 Empty)))


*Main> let a = 3 :-: 4 :-: 5 :-: Empty
*Main> let b = 6 :-: 7 :-: Empty
*Main> a .++ b
(:-:) 3 ((:-:) 4 ((:-:) 5 ((:-:) 6 ((:-:) 7 Empty))))

实例：二叉搜索树

data Tree a = EmptyTree | Node a (Tree a) (Tree a) deriving (Show, Read, Eq)


singleton :: a -> Tree a
singleton x = Node x EmptyTree EmptyTree


treeInsert :: (Ord a) => a -> Tree a -> Tree a
treeInsert x EmptyTree = singleton x
treeInsert x (Node a left right)
    | x == a = Node x left right
    | x < a = Node a (treeInsert x left) right
    | x > a = Node a left (treeInsert x right)


treeElem :: (Ord a) => a -> Tree a -> Bool
treeElem x EmptyTree = False
treeElem x (Node a left right)
    | x == a = True
    | x < a = treeElem x left
    | x > a = treeElem x right

测试

*Main> let nums = [8,6,4,1,7,3,5]
*Main> let numsTree = foldr treeInsert EmptyTree nums
*Main> numsTree
Node 5 (Node 3 (Node 1 EmptyTree EmptyTree) (Node 4 EmptyTree EmptyTree)) (Node 7 (Node 6 EmptyTree EmptyTree) (Node 8 EmptyTree EmptyTree))
*Main> 8 `treeElem` numsTree
True
*Main> 10 `treeElem` numsTree
False

自定义类型类

class

class 关键词定义新的类型类

并不一定要实现函数的本体，不过必须要写出函数的类型声明

给出的函数体是以交叉递归的形式实现的，在实例声明中只需要实现一个函数即可

class Eq a where
    (==) :: a -> a -> Bool
    (/=) :: a -> a -> Bool
    x == y = not (x /= y)
    x /= y = not (x == y)

其中 a 扮演着 Eq 实例类型的角色

instance

instance 关键词将类型转为某类型类的实例

没有直接通过 deriving 派生为某类型类的实例

data TrafficLight = Red | Yellow | Green


instance Eq TrafficLight where
    Red == Red = True
    Green == Green = True
    Yellow == Yellow = True
    _ == _ = False


instance Show TrafficLight where
    show Red = "Red light"
    show Yellow = "Yellow light"
    show Green = "Green light"

测试

*Main> Red == Red
True
*Main> Red == Yellow
False
*Main> Red `elem` [Red, Yellow, Green]
True
*Main> [Red, Yellow, Green]
[Red light,Yellow light,Green light]
*Main> :info TrafficLight
data TrafficLight = Red | Yellow | Green        -- Defined at Main.hs:1:1
instance [safe] Eq TrafficLight -- Defined at Main.hs:3:10
instance [safe] Show TrafficLight -- Defined at Main.hs:9:10

subclass

在 class 声明中添加一条类型约束，将一个类型类实现为另一个类型类的子类

class (Eq a) => Num a where
    ...

此处 a 必须为类型类 Eq 的实例

作为类型类实例的带参数类型

(Maybe m) 取代了 a 在 instance Eq a where 的位置：保留相应的类型参数作为类型变量

我们希望所有 Maybe m 形式的类型都属于 Eq，但这要求 m 也属于 Eq，所以我们在 instance 声明中添加一条类型约束

instance (Eq m) => Eq (Maybe m) where
    Just x == Just y = x == y
    Nothing == Nothing = True
    _ == _ = False

对应的，函数的类型声明如下

(==) :: (Eq m) => Maybe m -> Maybe m -> Bool

:info

查看某类型类拥有哪些实例

Prelude> :info Num
class Num a where
  (+) :: a -> a -> a
  (-) :: a -> a -> a
  (*) :: a -> a -> a
  negate :: a -> a
  abs :: a -> a
  signum :: a -> a
  fromInteger :: Integer -> a
  {-# MINIMAL (+), (*), abs, signum, fromInteger, (negate | (-)) #-}
        -- Defined in 'GHC.Num'
instance Num Word -- Defined in 'GHC.Num'
instance Num Integer -- Defined in 'GHC.Num'
instance Num Int -- Defined in 'GHC.Num'
instance Num Float -- Defined in 'GHC.Float'
instance Num Double -- Defined in 'GHC.Float'

查看类型（构造器）属于哪些类型类

Prelude> :info Maybe
data Maybe a = Nothing | Just a         -- Defined in 'GHC.Maybe'
instance Applicative Maybe -- Defined in 'GHC.Base'
instance Eq a => Eq (Maybe a) -- Defined in 'GHC.Maybe'
instance Functor Maybe -- Defined in 'GHC.Base'
instance Monad Maybe -- Defined in 'GHC.Base'
instance Semigroup a => Monoid (Maybe a) -- Defined in 'GHC.Base'
instance Ord a => Ord (Maybe a) -- Defined in 'GHC.Maybe'
instance Semigroup a => Semigroup (Maybe a)
  -- Defined in 'GHC.Base'
instance Show a => Show (Maybe a) -- Defined in 'GHC.Show'
instance MonadFail Maybe -- Defined in 'Control.Monad.Fail'
instance Read a => Read (Maybe a) -- Defined in 'GHC.Read'
instance Foldable Maybe -- Defined in 'Data.Foldable'
instance Traversable Maybe -- Defined in 'Data.Traversable'

查看值（构造器）属于哪些类型

Prelude> :info True
data Bool = ... | True  -- Defined in 'GHC.Types'

实例：Yes-No typeclass

class YesNo a where
    yesno :: a -> Bool


instance YesNo Int where
    yesno 0 = False
    yesno _ = True


instance YesNo [a] where
    yesno [] = False
    yesno _ = True


instance YesNo Bool where
    yesno = id


instance YesNo (Maybe a) where
    yesno (Just _) = True
    yesno Nothing = False


yesnoIf :: (YesNo y) => y -> a -> a -> a
    yesnoIf yesnoVal yesResult noResult =
        if yesno yesnoVal
        then yesResult
        else noResult

测试

*Main> yesno $ length []
False
*Main> yesno "haha"
True
*Main> yesno ""
False
*Main> yesno $ Just 0
True
*Main> yesno True
True
*Main> :t yesno
yesno :: YesNo a => a -> Bool
*Main> yesnoIf [] "YEAH!" "NO!"
"NO!"
*Main> yesnoIf (Just 500) "YEAH!" "NO!"
"YEAH!"
*Main> :t yesnoIf
yesnoIf :: YesNo y => y -> a -> a -> a
*Main> :t id
id :: a -> a

Functor 类型类

定义

Functor 类型类定义如下，其中 f 不是一个具体类型，而是一个取一个类型参数的类型构造器

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

注意到 map 就是仅处理 List 的 fmap，于是立即可以得到 List 作为 Functor 类型类实例的实现

instance Functor [] where
  fmap = map

其中 [] 是一个取一个类型参数的类型构造器

注意不能写成 instance Functor [a] where，因为 f 是一个取一个类型参数的类型构造器，而 [a] 则已经是一个具体类型

Prelude> :t fmap
fmap :: Functor f => (a -> b) -> f a -> f b
Prelude> :t map
map :: (a -> b) -> [a] -> [b]

对于 List，fmap 只不过是 map

Prelude> fmap (*2) [1..3]
[2,4,6]
Prelude> map (*2) [1..3]
[2,4,6]

术语辨析

Maybe functor

凡是拥有容器性质的类型都可以视作函子

  • 容器是包含值和值的变形关系，这个变形关系就是函数。
  • 在范畴论中，函子 (functor) 是范畴间的一类映射，通俗地说，是范畴间的同态。
instance Functor Maybe where
    fmap f (Just x) = Just (f x)
    fmap f Nothing = Nothing

测试

Prelude> fmap (*2) (Just 200)
Just 400
Prelude> fmap (*2) Nothing
Nothing

Either functor

部分应用，使其成为取一个类型参数的类型构造器，如此，第一个类型保持不变，而第二个类型参数则可以改变，符合 Either 的应用场景

instance Functor (Either a) where
    fmap f (Right x) = Right (f x)
    fmap f (Left x) = Left x

实例：Tree functor

data Tree a = EmptyTree | Node a (Tree a) (Tree a) deriving (Show, Read, Eq)


singleton :: a -> Tree a
singleton x = Node x EmptyTree EmptyTree


treeInsert :: (Ord a) => a -> Tree a -> Tree a
treeInsert x EmptyTree = singleton x
treeInsert x (Node a left right)
    | x == a = Node x left right
    | x < a = Node a (treeInsert x left) right
    | x > a = Node a left (treeInsert x right)


instance Functor Tree where
    fmap f EmptyTree = EmptyTree
    fmap f (Node x leftsub rightsub) = Node (f x) (fmap f leftsub) (fmap f rightsub)

测试

*Main> fmap (*2) EmptyTree
EmptyTree
*Main> fmap (*4) (foldr treeInsert EmptyTree [5,7,3,2,1,7])
Node 28 (Node 4 EmptyTree (Node 8 EmptyTree (Node 12 EmptyTree (Node 20 EmptyTree EmptyTree)))) EmptyTree

kind

值有自己的标签（函数也是值的一种），叫做 type

类型也有自己的标签，叫做 kind

Prelude> :k Int
Int :: *

一个 * 代表这个类型是具体类型，一个具体类型是没有任何类型参数，而值只能属于具体类型

Prelude> :k Maybe
Maybe :: * -> *
Prelude> :k Maybe Int
Maybe Int :: *

Maybe 的类型构造器接受一个具体类型，然后返回一个具体类型；Either 的类型构造器接受两个具体类型作为参数，并返回一个具体类型

Prelude> :k Either
Either :: * -> * -> *
Prelude> :k Either String
Either String :: * -> *
Prelude> :k Either String Int
Either String Int :: *

不难推断出 Functor 类型类中的 f 的 kind 为 * -> *

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

再谈 Functor 类型类

引子

我们观察一下 Functor 类型类拥有哪些实例

Prelude> :info Functor
class Functor (f :: * -> *) where
  fmap :: (a -> b) -> f a -> f b
  (<$) :: a -> f b -> f a
  {-# MINIMAL fmap #-}
        -- Defined in 'GHC.Base'
instance Functor (Either a) -- Defined in 'Data.Either'
instance Functor [] -- Defined in 'GHC.Base'
instance Functor Maybe -- Defined in 'GHC.Base'
instance Functor IO -- Defined in 'GHC.Base'
instance Functor ((->) r) -- Defined in 'GHC.Base'
instance Functor ((,) a) -- Defined in 'GHC.Base'

IO functor

IO 可以成为 Functor 类型类的实例

instance Functor IO where
    fmap f action = do
        result <- action
        return (f result)

于是可以使用 fmap 对 I/O action 进行操作，考虑如下程序

main = do
    line <- getLine
    let line' = reverse line
    putStrLn $ "You said " ++ line' ++ " backwards!"

使用 fmap 改写为

main = do
    line <- fmap reverse getLine
    putStrLn $ "You said " ++ line ++ " backwards!"

测试一下

PS C:\Users\VGalaxy\code> ./Main
hello
You said olleh backwards!

此时，我们可以认为 fmap 的类型为 fmap :: (a -> b) -> IO a -> IO b

function functor

函数也可以成为 Functor 类型类的实例

注意到函数类型 r -> a 可以写成 (->) r a，于是 (->) 可以认为是一个取两个类型参数的类型构造器，类似 Either

然而 Functor 类型类定义中的 f 是一个取一个类型参数的类型构造器，于是我们使用部分应用

function functor 定义在 Control.Monad.Instances 中

instance Functor ((->) r) where
  fmap f g = (\x -> f (g x))

我们来思考 fmap 的类型

fmap :: (a -> b) -> ((->) r a) -> ((->) r b)

即

fmap :: (a -> b) -> (r -> a) -> (r -> b)

这便是函数组合，于是 function functor 有另一种定义

instance Functor ((->) r) where
  fmap = (.)

在交互界面试一试

Prelude> :t fmap (*3) (+100)
fmap (*3) (+100) :: Num b => b -> b
Prelude> fmap (*3) (+100) 1
303
Prelude> (*3) `fmap` (+100) $ 1
303
Prelude> (*3) . (+100) $ 1
303

我们用 Curried functions 的思想，再来思考 fmap 的类型

fmap :: Functor f => (a -> b) -> f a -> f b

上面我们认为 fmap 是一个函数，它接受另一个函数和一个 functor，得到另一个 functor

我们还可以认为 fmap 是一个函数，它接受另一个函数并把它提升 (lifting) 为操作 functor 的函数

这里 functor 是 Functor 类型类的实例

来看几个例子

Prelude> :t fmap (*2)
fmap (*2) :: (Functor f, Num b) => f b -> f b
Prelude> :t fmap (replicate 3)
fmap (replicate 3) :: Functor f => f a -> f [a]

functor laws

一个东西要成为 functor，必须要遵守某些定律，这些定律不会在 Haskell 中自动被检查

这里的 functor 与 Functor 类型类的实例有微妙的区别

  1. fmap id = id，其中 id 为恒等函数
  2. fmap (f . g) = fmap f . fmap g 或 fmap (f . g) x = fmap f (fmap g x)，其中 x 为一个 functor

我们来构造一个 Functor 类型类的实例，但它不满足上述定律

data CMaybe a = CNothing | CJust Int a deriving (Show)


instance Functor CMaybe where
    fmap f CNothing = CNothing
    fmap f (CJust counter x) = CJust (counter + 1) (f x)

导入后我们测试第一条定律

*Main> fmap id (CJust 0 "haha")
CJust 1 "haha"
*Main> id (CJust 0 "haha")
CJust 0 "haha"

不满足

Applicative 类型类

引子

到目前为止，我们调用 fmap 时传入的函数都是单参数函数，若是多参数函数会如何呢，来试一试

Prelude> :t fmap compare (Just 'a')
fmap compare (Just 'a') :: Maybe (Char -> Ordering)
Prelude> :t fmap compare "A LIST OF CHARS"
fmap compare "A LIST OF CHARS" :: [Char -> Ordering]

可以看到，我们得到了一个被包裹起来的 functor，这仍然是 functor

在这里，被包裹起来的 functor 是具体的单参数函数

于是我们可以将这个 functor 继续传入 fmap 中

Prelude> let a = fmap (*) [1,2,3,4]
Prelude> :t a
a :: Num a => [a -> a]
Prelude> fmap (\f -> f 9) a
[9,18,27,36]

我们来考虑一个更复杂的例子

Prelude> let b = fmap (\x y z -> x + y / z) [3,4,5,6]
Prelude> :t b
b :: Fractional a => [a -> a -> a]
Prelude> let c = fmap (\f -> f 1) b
Prelude> :t c
c :: Fractional t => [t -> t]
Prelude> fmap (\f -> f 2) c
[3.5,4.5,5.5,6.5]

回顾一下，目前 fmap 的两个参数，一个是普通函数，另一个是 functor，假如我们想取出某一个 functor 中的函数作为 fmap 参数中的普通函数呢，下面有请 Applicative 类型类

定义

模块 Control.Applicative 中定义了 Applicative 类型类

class (Functor f) => Applicative f where
    pure :: a -> f a
    (<*>) :: f (a -> b) -> f a -> f b

可见 Applicative 类型类是 Functor 类型类的子类

pure 接受一个值，然后返回一个包含那个值的 applicative functor

<*> 则是接受一个装有函数的 applicative functor 和另一个 applicative functor，然后取出 applicative functor 中的函数作用于另一个 applicative functor，返回一个 applicative functor

观察一下 Applicative 类型类拥有哪些实例

Prelude> :info Applicative
class Functor f => Applicative (f :: * -> *) where
  pure :: a -> f a
  (<*>) :: f (a -> b) -> f a -> f b
  GHC.Base.liftA2 :: (a -> b -> c) -> f a -> f b -> f c
  (*>) :: f a -> f b -> f b
  (<*) :: f a -> f b -> f a
  {-# MINIMAL pure, ((<*>) | liftA2) #-}
        -- Defined in 'GHC.Base'
instance Applicative (Either e) -- Defined in 'Data.Either'
instance Applicative [] -- Defined in 'GHC.Base'
instance Applicative Maybe -- Defined in 'GHC.Base'
instance Applicative IO -- Defined in 'GHC.Base'
instance Applicative ((->) a) -- Defined in 'GHC.Base'
instance Monoid a => Applicative ((,) a) -- Defined in 'GHC.Base'

Maybe applicative functor

instance Applicative Maybe where
    pure = Just
    Nothing <*> _ = Nothing
    (Just f) <*> something = fmap f something

在交互界面试试

Prelude> Just (+3) <*> Just 9
Just 12
Prelude> pure (+3) <*> Just 9
Just 12
Prelude> Nothing <*> Just 9
Nothing
Prelude> Just (+9) <*> Nothing
Nothing

只要 <*> 返回的是一个装有函数的 applicative functor，我们就可以把 <*> 串起来用

Prelude> pure (+) <*> Just 3 <*> Just 5
Just 8
Prelude> pure (+) <*> Just 3 <*> Nothing
Nothing
Prelude> pure (+) <*> Nothing <*> Just 5
Nothing

我们来解读第一个例子

pure (+) <*> Just 3 <*> Just 5 =
(<*>) ((<*>) Just (+) Just 3) Just 5 =
(<*>) Just (3+) Just 5 =
Just 8

注意部分应用后是 (3+) 而非 (+3)，因为加法满足交换律，所以这里看不出区别，换为除法便可看出区别

applicative style

现在让 fmap 露个面吧，由定义容易得到 pure f <*> x = fmap f x

为了书写方便，模块 Control.Applicative 定义一个名为 <$> 的函数

(<$>) :: (Functor f) => (a -> b) -> f a -> f b
f <$> x = fmap f x

<$> 就是 fmap 的中缀版本，于是上面的例子可以这样写

Prelude> (+) <$> Just 3 <*> Just 5
Just 8
Prelude> (+) `fmap` Just 3 <*> Just 5
Just 8

对比普通的函数

Prelude> (+) 3 5
8

可知，只需要点缀一点符号，普通函数就能操作这些 applicative functor，并返回 applicative functor

这也被称为 applicative style

List applicative functor

instance Applicative [] where
    pure x = [x]
    fs <*> xs = [f x | f <- fs, x <- xs]

这里我们要回到容器的概念，容器其实就是一个上下文 (context)

pure 是把一个值放进默认的上下文中。换种说法就是一个会产生那个值的最小上下文

对 List 而言，最小上下文就是 []，但由于空的 List 并不包含一个值，这也是为什么 pure 被实现为接受一个值，然后返回一个包含这个值的单元素 List

同样的，Maybe 的最小上下文是 Nothing，但它其实表示的是没有值，所以 pure 被实现为 Just

<*> 被实现为列表推导式，这里 <*> 的类型为 (<*>) :: [a -> b] -> [a] -> [b]

来看几个例子

Prelude> [(*0),(+100),(^2)] <*> [1,2,3]
[0,0,0,101,102,103,1,4,9]
Prelude> [(+),(*)] <*> [1,2] <*> [3,4]
[4,5,5,6,3,4,6,8]

applicative style 处理列表是列表推导式的一个替代品

Prelude> [x*y|x<-[2,5,10],y<-[8,10,11],x*y>50]
[55,80,100,110]
Prelude> filter (>50) $ (*) <$> [2,5,10] <*> [8,10,11]
[55,80,100,110]

IO applicative functor

instance Applicative IO where
    pure = return
    a <*> b = do
        f <- a
        x <- b
        return (f x)

return 产生一个不做任何事的 I/O action，把相同的值作为结果，符合 pure 的定义：把一个值放进最小的上下文中

从一个 I/O action 里取出函数，从另一个 I/O action 取出被函数作用的值，返回一个 I/O action，包含了被作用后的值

来看个例子

main = do
    a <- getLine
    b <- getLine
    putStrLn $ a ++ b

使用 applicative style 改写

main = do
    a <- (++) <$> getLine <*> getLine
    putStrLn a

function applicative functor

instance Applicative ((->) r) where
    pure x = (\_ -> x)
    f <*> g = \x -> f x (g x)

pure 接受一个值，返回一个函数，该函数总是返回那个值

于是这里 pure 的类型为 pure :: a -> (r -> a)，符合 Applicative 类型类中的定义

Prelude> :t pure
pure :: Applicative f => a -> f a

在交互界面试试

Prelude> (pure 3) "hello"
3

来看看 pure 3 的类型

Prelude> :t pure 3
pure 3 :: (Applicative f, Num a) => f a

先看一个例子

Prelude> :t (+) <$> (+3) <*> (*100)
(+) <$> (+3) <*> (*100) :: Num b => b -> b
Prelude> (+) <$> (+3) <*> (*100) $ 5
508

为了更好的理解 <*> 的实现，参考了 functions as applicative functors (Haskell / LYAH) - Stack Overflow 的内容进行解读，并联系之前部分的内容

根据定义

(+) <$> (+3) <*> (*100) $ 5

等价于（看之前的部分）

pure (+) <*> (+3) <*> (*100) $ 5

观察 pure (+) 的类型

Prelude> :t pure (+)
pure (+) :: (Applicative f, Num a) => f (a -> a -> a)

根据 <*> 的实现，先考虑前半部分

pure (+) <*> (+3) =
    \r -> f r (g r) =
    \x r -> (r + 3) + x

这里需要注意 x 的位置，下面的例子作为参考

Prelude> (/) <$> (+3) <*> (*5) $ 5
0.32
Prelude> (flip (/)) <$> (+3) <*> (*5) $ 5
3.125

再考虑后半部分，用 (*100) 替换 lambda 中的 x

pure (+) <*> (+3) <*> (*100) =
    \r -> (r + 3) + (g r)
    \r -> (r + 3) + (r * 100)

最后令 r 等于 5 就破案了

于是最后的效果是，我们创建了一个函数，它将 (+3) 和 (*100) 作用在参数上的各自的结果相加

还有一个例子作为习题

Prelude> (\x y z -> [x,y,z]) <$> (+3) <*> (*2) <*> (/2) $ 5
[8.0,10.0,2.5]

最后的效果是，函数会调用 \x y z -> [x,y,z]，而传递的参数是 (+3)、(*2) 和 (/2) 作用在外界参数上的各自的结果

ZipList

List 实际上有多种方式成为 applicative functor

ZipList 是另一个 Applicative 类型类的实例

instance Applicative ZipList where
    pure x = ZipList (repeat x)
    ZipList fs <*> ZipList xs = ZipList (zipWith (\f x -> f x) fs xs)

注意这里 zipWith 函数的使用，结果列表会和两个列表中较短的那个长度相同

为了满足 pure f <*> x = fmap f x，pure 的实现中用到了 repeat

由于 ZipList 类型并非 Show 类型类的实例，我们需要使用 getZipList 函数从 ZipList 中取出原生的 List

Prelude Control.Applicative> :t getZipList
getZipList :: ZipList a -> [a]

来看几个例子

Prelude Control.Applicative> getZipList $ (+) <$> ZipList [1,2,3] <*> ZipList [100,100,100]
[101,102,103]
Prelude Control.Applicative> getZipList $ max <$> ZipList [1,2,3,4,5,3] <*> ZipList [5,3,1,2]
[5,3,3,4]
Prelude Control.Applicative> getZipList $ (,,) <$> ZipList "dog" <*> ZipList "cat" <*> ZipList "rat"
[('d','c','r'),('o','a','a'),('g','t','t')]
Prelude Control.Applicative> :t (,,)
(,,) :: a -> b -> c -> (a, b, c)

applicative functor laws

这一条在之前的部分中多次提到，也是 applicative style 的核心之一

下面几条留作习题

applicative functions

liftA2

Prelude Control.Applicative> :t liftA2
liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c

先来简单的实现它

liftA2 :: (Applicative f) => (a -> b -> c) -> f a -> f b -> f c
liftA2 f x y = f <$> x <*> y

一方面，它在两个 applicative functor 间应用一个函数，这实际上隐藏了刚刚讨论过的 applicative style

另一方面，这让我们想起了 fmap 的类型

fmap :: Functor f => (a -> b) -> f a -> f b

也就是说，对于普通的 functor，可以把函数应用到一个 functor 上，而对于 applicative functor，可以把函数应用到多个 applicative functor 上

来看几个例子

Prelude Control.Applicative> liftA2 (:) (Just 3) (Just [4])
Just [3,4]
Prelude Control.Applicative> (:) <$> Just 3 <*> Just [4]
Just [3,4]

sequenceA

Prelude Control.Applicative> :t sequenceA
sequenceA :: (Traversable t, Applicative f) => t (f a) -> f (t a)

这让我们想起了 sequence

Prelude> :t sequence
sequence :: (Traversable t, Monad m) => t (m a) -> m (t a)

为了具体起见，我们以 List applicative functor 为基础来实现 sequenceA

一种方式是递归

sequenceA :: (Applicative f) => [f a] -> f [a]
sequenceA [] = pure []
sequenceA (x:xs) = (:) <$> x <*> sequenceA xs

另一种方式是使用折叠

sequenceA :: (Applicative f) => [f a] -> f [a]
sequenceA = foldr (liftA2 (:)) (pure [])

来看几个示例，首先是 Just

Prelude Control.Applicative> sequenceA [Just 3, Just 2, Just 1]
Just [3,2,1]
Prelude Control.Applicative> sequenceA [Just 3, Nothing, Just 1]
Nothing

然后是函数

Prelude Control.Applicative> sequenceA [(+3),(+2),(+1)] 3
[6,5,4]

接着是 List

Prelude Control.Applicative> sequenceA [[1,2,3],[4,5,6]]
[[1,4],[1,5],[1,6],[2,4],[2,5],[2,6],[3,4],[3,5],[3,6]]

总结

applicative functor 允许我们通过 applicative style 组合多种不同行为的计算，比如 I/O 计算、非确定性计算、可能会失败的计算等。只要用上 <$> 和 <∗>，我们就能统一使用普通函数，利用 applicative functor 各自的语义来操作它们，操作任意数量的 applicative functor

Monoid 类型类

newtype

首先让我们观察 ZipList 和 getZipList 的类型

Prelude Control.Applicative> :t ZipList
ZipList :: [a] -> ZipList a
Prelude Control.Applicative> :t getZipList
getZipList :: ZipList a -> [a]

思考我们应该如何定义 ZipList 呢，一种方式是使用 data 关键词

data ZipList a = ZipList [a]

或者用记录语法

data ZipList a = ZipList { getZipList :: [a] }

另一种方式是使用 newtype 关键词

newtype ZipList a = ZipList { getZipList :: [a] }

使用 newtype 关键词，相当于将一个已有类型包裹成一个新的类型

当使用 newtype 来根据已有类型创建新类型时，只能有一个值构造器，这个值构造器也只能有一个字段

我们可以使用 newtype 关键词创建类型类的实例，就像之前对 ZipList 所做的那样，这里再举一个例子

我们希望元组 (a,b) 能够成为 Functor 类型类的实例，但是 (a,b) 有两个类型变量，而且似乎也不好部分应用

于是我们使用 newtype 关键词来创建一个新类型

newtype Pair b a = Pair { getPair :: (a, b) }

注意这里 a 和 b 的顺序，这样部分应用就是限定了元组的第二项了

instance Functor (Pair c) where
  fmap f (Pair (x, y)) = Pair (f x, y)

这里使用了模式匹配，可以认为 fmap 的类型为

fmap :: (a -> b) -> Pair c a -> Pair c b

注意这里 Pair c a 对应 (a,c)，Pair c b 对应 (b,c)

来装载脚本测试一下

*Main> getPair $ fmap (*100) (Pair (2,3))
(200,3)
*Main> getPair $ fmap reverse (Pair ("london calling", 3))
("gnillac nodnol",3)

使用 newtype 关键词和使用 data 关键词还有什么区别呢，实际上 newtype 比 data 模式匹配的惰性程度更深（因此往往也更快）

举个例子来说明，这里迫使 Haskell 计算 undefined 会触发异常，然而利用 List 的惰性就能免于计算 undefined

Prelude> undefined
*** Exception: Prelude.undefined
CallStack (from HasCallStack):
  error, called at libraries\base\GHC\Err.hs:80:14 in base:GHC.Err
  undefined, called at <interactive>:3:1 in interactive:Ghci2
Prelude> head [3,4,5,undefined,2,undefined]
3

现在们考虑下面的类型

data CoolBool = CoolBool { getCoolBool :: Bool }


helloMe :: CoolBool -> String
helloMe (CoolBool _) = "hello"

来装载脚本测试一下

*Main> helloMe undefined
"*** Exception: Prelude.undefined
CallStack (from HasCallStack):
  error, called at libraries\base\GHC\Err.hs:80:14 in base:GHC.Err
  undefined, called at <interactive>:10:9 in interactive:Ghci1

在定义中，无论 CoolBool 里的 Bool 是什么，都会返回 "hello"，然而由于用 data 关键词定义的类型可以有多个值构造器，所以检查提供给函数的参数是否匹配模式 CoolBool _，Haskell 必须要计算这个参数，在这里就是 undefined

现在我们使用 newtype 关键词并重新测试

*Main> helloMe undefined
"hello"

因为用 newtype 关键词定义的类型只能有一个值构造器，所以在这里能够匹配模式 CoolBool _，就不需要计算提供给函数的参数了

Monoid

幺半群

来看看 Monoid 类型类的定义

class Monoid m where
    mempty :: m
    mappend :: m -> m -> m
    mconcat :: [m] -> m
    mconcat = foldr mappend mempty

首先，只有具体类型才能成为 Monoid 类型类的实例，因为这里的 m 没有类型变量

其次，mempty 表示单位元

然后，mappend 表示二元运算，请无视这个有误导性的名字

最后，mconcat 取一个 monoid 组成的列表，并规归约成一个 monoid，它一个默认的实现

monoid laws

主要是满足单位元的性质和二元运算的结合律

List monoid

instance Monoid [a] where
    mempty = []
    mappend = (++)

注意这里的 [a]，表示这里是一个列表的具体类型，而非列表的类型构造器 []

看几个例子

Prelude> mconcat [[1,2],[3,6],[9]]
[1,2,3,6,9]
Prelude> mempty :: [a]
[]

Product and Sum

对应了乘法与加法

现在问题是如何将数变成 Monoid 类型类的实例，我们可以使用 newtype 关键词

模块 Data.Monoid 给出了 Product 的定义

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)

这里有一个 Num a 的类型约束，说明对于任何 Num 类型类的实例 a，Product a 都是 Monoid 类型类的实例

来看个例子

Prelude Data.Monoid> getProduct . mconcat . map Product $ [3,4,2]
24

Sum 与 Product 类似，不再赘述

Any and All

Bool 有两种方式成为 Monoid 类型类的实例

newtype Any = Any { getAny :: Bool }
  deriving (Eq, Ord, Read, Show, Bounded)


instance Monoid Any where
    mempty = Any False
    Any x `mappend` Any y = Any (x || y)

或

newtype All = All { getAll :: Bool }
  deriving (Eq, Ord, Read, Show, Bounded)


instance Monoid All where
    mempty = All True
    All x `mappend` All y = All (x && y)

Ordering monoid

Ordering 类型也可以成为 Monoid 类型类的实例

data Ordering = LT | EQ | GT


instance Monoid Ordering where
    mempty = EQ
    LT `mappend` _ = LT
    EQ `mappend` y = y
    GT `mappend` _ = GT

类比用字典序比较单词（高位优先）

这样操作的好处就是能够允许我们用不同衡量标准来比较事物，并且根据重要性放置衡量标准，来看个例子

我们写一个比较字符串的例子，第一优先级为长度，第二优先级为字典序，可以这样写

lengthCompare :: String -> String -> Ordering
lengthCompare x y = let a = length x `compare` length y
                        b = x `compare` y
                    in  if a == EQ then b else a

如果利用 Ordering 类型是 Monoid 类型类的实例这一点，可以重写为

import Data.Monoid


lengthCompare :: String -> String -> Ordering
lengthCompare x y = (length x `compare` length y) `mappend`
                    (x `compare` y)

这种写法不仅清晰，而且容易扩展

Maybe monoid

Maybe a 有多种方式成为 Monoid 类型类的实例

若类型参数 a 为 monoid 时，可以这样实现

instance Monoid a => Monoid (Maybe a) where
    mempty = Nothing
    Nothing `mappend` m = m
    m `mappend` Nothing = m
    Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)

来测试一下

Prelude> Nothing `mappend` Just "andy"
Just "andy"
Prelude> Just LT `mappend` Nothing
Just LT
Prelude Data.Monoid> Just (Sum 3) `mappend` Just (Sum 4)
Just (Sum {getSum = 7})

如果类型参数 a 不是 monoid，在 mappend 的两个参数都是 Just 时，我们就不能对 Just 包裹的值进行 mappend 操作，一种方案时简单的丢弃第二个 Just，出于这个目的，我们有 First 类型

newtype First a = First { getFirst :: Maybe a } deriving (Eq, Ord, Read, Show)


instance Monoid (First a) where
    mempty = First Nothing
    First (Just x) `mappend` _ = First (Just x)
    First Nothing `mappend` x = x

看一看 First 的类型签名

Prelude Data.Monoid> :t First
First :: Maybe a -> First a

用途是取出第一个非 Nothing，如果没有就返回 Nothing

Prelude Data.Monoid> getFirst . mconcat . map First $ [Nothing, Just 9, Just 10]
Just 9

类似的我们也有 Last 类型

Prelude Data.Monoid> getLast . mconcat . map Last $ [Nothing, Just 9, Just 10]
Just 10

Foldable 类型类

处理 monoid 的一个更有趣的方式是让它们帮我们折叠各种数据结构，比如 List

为此 Haskell 引入了 Foldable 类型类，表示可以折叠的东西，我们可以观察 foldr 的类型签名

Prelude> :t foldr
foldr :: Foldable t => (a -> b -> b) -> b -> t a -> b

除了 List，Maybe 也是 Foldable 类型类的实例

Prelude> foldr (*) 1 [1,2,3]
6
Prelude> foldl (+) 2 (Just 9)
11
Prelude> foldr (||) False (Just True)
True

现在我们想让 Tree 类型成为 Foldable 类型类的实例

data Tree a = EmptyTree | Node a (Tree a) (Tree a) deriving (Show, Read, Eq)

为此我们需要实现 foldMap 方法

Prelude> :t foldMap
foldMap :: (Foldable t, Monoid m) => (a -> m) -> t a -> m

需要注意的是，这里最后要用 mappend 把结果合并为一个 monoid

import Data.Monoid


data Tree a = Empty | Node a (Tree a) (Tree a) deriving (Show, Read, Eq)


instance Foldable Tree where
    foldMap f Empty = mempty
    foldMap f (Node x l r) =
        foldMap f l `mappend`
        f x `mappend`
        foldMap f r


testTree = Node 5 (Node 3 (Node 1 Empty Empty) (Node 6 Empty Empty)) (Node 9 (Node 8 Empty Empty) (Node 10 Empty Empty))

于是在这种实现下，顺序是左子树、当前节点、右子树，也就是中序遍历

装载脚本测试一下

*Main> foldl (+) 0 testTree
42
*Main> foldl (*) 1 testTree
64800
*Main> getAny $ foldMap (\x -> Any $ x == 3) testTree
True
*Main> foldMap (\x -> [x]) testTree
[1,3,6,5,8,9,10]

Monad 类型类

monad，中译为单子

回顾

fmap :: Functor f => (a -> b) -> f a -> f b

一个普通函数，一个 functor

Prelude> fmap (++"!") (Just "wisdom")
Just "wisdom!"
Prelude> fmap (++"!") Nothing
Nothing
(<*>) :: Applicative f => f (a -> b) -> f a -> f b

一个包含函数的 applicative functor，一个 applicative functor

Prelude> Just (+3) <*> Just 3
Just 6
Prelude> Nothing <*> Just "greed"
Nothing
Prelude> Just ord <*> Nothing
Nothing
(<$>) :: Functor f => (a -> b) -> f a -> f b

一个普通函数，任意多个 applicative functor

Prelude> max <$> Just 3 <*> Just 6
Just 6
Prelude> max <$> Just 3 <*> Nothing
Nothing

现在让我们思考这样一个函数

(>>=) :: Monad m => m a -> (a -> m b) -> m b

现在的问题是我们有一个带有上下文的值 m a，如何对它应用这样一个函数，这个函数取类型为 a 的参数，返回一个带有上下文的值。

为了具体起见，我们限定上下文为 Maybe，并实现 (>>=)

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

定义

class Monad m where
    return :: a -> m a


    (>>=) :: m a -> (a -> m b) -> m b


    (>>) :: m a -> m b -> m b
    x >> y = x >>= \_ -> y


    fail :: String -> m a
    fail msg = error msg

这里的 return 和 Applicative 类型类中的 pure 是一样的，这里暗示了 IO 是 Monad 类型类的实例

其余的函数我们后面用到的时候再说

Maybe monad

现在来看看 Maybe 是如何成为 Monad 类型类的实例

instance Monad Maybe where
    return x = Just x
    Nothing >>= f = Nothing
    Just x >>= f = f x
    fail _ = Nothing

和我们之间的实现是差不多的，在交互界面试试

Prelude> return "WHAT" :: Maybe String
Just "WHAT"
Prelude> Just 9 >>= \x -> return (x*10)
Just 90
Prelude> Nothing >>= \x -> return (x*10)
Nothing
Prelude> Just 9 >>= \x -> Nothing
Nothing

现在我们要用 >>= 来处理若干带有 Maybe 上下文的值的计算（Applicative 类型类无法处理）

考虑这样一个问题，一个人拿着平衡杆玩高空绳索行走，这里假设平衡杆两边的鸟的数目差在三之内的时候，人能够保持平衡，我们需要模拟鸟飞来飞去以及人是否能保持平衡

先来定义一些类型

type Birds = Int
type Pole = (Birds, Birds)

接下来便是模拟鸟飞来飞去的函数

因为一旦人失去平衡，Pole 的二元组就失去了意义，所以我们用 Maybe 来表达这种上下文

landLeft :: Birds -> Pole -> Maybe Pole
landLeft n (left, right)
    | abs ((left + n) - right) < 4 = Just (left + n, right)
    | otherwise                    = Nothing


landRight :: Birds -> Pole -> Maybe Pole
landRight n (left, right)
    | abs (left - (right + n)) < 4 = Just (left, right + n)
    | otherwise                    = Nothing

装载脚本测试一下

*Main> landLeft 2 (0,0)
Just (2,0)
*Main> landLeft 10 (0,3)
Nothing

没有问题，现在关键的地方来了，我们可以用 >>= 表达一连串的停靠操作

*Main> return (0,0) >>= landRight 2 >>= landLeft 2 >>= landRight 2
Just (2,4)
*Main> return (0,0) >>= landLeft 1 >>= landRight 4 >>= landLeft (-1) >>= landRight (-2)
Nothing

这都要归功于 >>= 函数的类型和语义，它在变换中保存着上下文（人保持平衡或失去平衡），变换的每一步都会依赖上一步的结果

(>>=) :: Monad m => m a -> (a -> m b) -> m b

现在让我们来设计一个香蕉，它可以让人直接失去平衡

banana :: Pole -> Maybe Pole
banana _ = Nothing

重新装载脚本测试

*Main> return (0,0) >>= landLeft 1 >>= banana >>= landRight 1
Nothing

为了简化这种操作，我们可以使用 >> 函数，来看一下它的类型与默认定义

(>>) :: (Monad m) => m a -> m b -> m b
m >> n = m >>= \_ -> n

可知 >> 函数将一个 monad 传递给一个忽略参数，返回一个 monad 的函数，结果就是返回的那个 monad

Prelude> Nothing >> Just 3
Nothing
Prelude> Just 3 >> Just 4
Just 4
Prelude> Just 3 >> Nothing
Nothing

于是我们把上面的 banana 换成 Nothing

*Main> return (0,0) >>= landLeft 1 >> Nothing >>= landRight 1
Nothing

总结一下，把返回值变成 Maybe 值，把普通的函数应用变成 >>=，我们就可以轻松地处理可能会失败的计算，并传递上下文，在这里，上下文就是可能会失败的计算。

do notation

我们在 IO 的 do blocks 中已经遇到了这种语法，要想理解这种语法，我们需要嵌套使用 >>=

Prelude> Just 3 >>= (\x -> Just "!" >>= (\y -> Just (show x ++ y)))
Just "3!"

为了清晰起见，我们让每一个 monad 单独占一行，并写到脚本里

foo :: Maybe String
foo = Just 3 >>= (\x ->
      Just "!" >>= (\y ->
      Just (show x ++ y)))

使用 do notation，可以写成

foo :: Maybe String
foo = do
    x <- Just 3
    y <- Just "!"
    Just (show x ++ y)

在 do notation 中，每一行都是一个 monad，要获取 monad 的值就使用 <-

如果某一行没有 <-，就相当于我们用 >> 函数忽略了这个 monad 的值

这也解释了为什么在 IO 中最后一个 action 不能绑定任何名字（无法变换为嵌套 >>=）

对于 Nothing 的情形，都可以使用 do notation 改写

Prelude> Nothing >>= (\x -> Just "!" >>= (\y -> Just (show x ++ y)))
Nothing
Prelude> Just 3 >>= (\x -> Nothing >>= (\y -> Just (show x ++ y)))
Nothing
Prelude> Just 3 >>= (\x -> Just "!" >>= (\y -> Nothing))
Nothing

让我们用 do notation 重新描述前面的鸟人问题

routine :: Maybe Pole
routine = do
    start <- return (0,0)
    first <- landLeft 2 start
    second <- landRight 2 first
    landLeft 1 second

使用 do notation，我们需要显式的写出前一步的结果

补充一点，我们可以在 <- 时使用模式匹配

justH :: Maybe Char
justH = do
    (x:xs) <- Just "hello"
    return x

如果模式匹配失败了，fail 函数会被调用，下面是默认实现

fail :: String -> m a
fail msg = error msg

Maybe 的 fail 函数被实现为

fail _ = Nothing

List monad

之前 Maybe 的上下文是可能会失败的计算，现在 List 的上下文是非确定性计算

来看看 List 如何成为 Monad 类型类的实例

instance Monad [] where
    return x = [x]
    xs >>= f = concat (map f xs)
    fail _ = []

下面是几个简单的示例

Prelude> [3,4,5] >>= \x -> [x,-x]
[3,-3,4,-4,5,-5]
Prelude> [1,2,3] >>= \x -> []
[]
Prelude> [] >>= \x -> ["bad","mad","rad"]
[]

这里的 [] 就相当于 Nothing

下面是 >>= 的组合使用

Prelude> [1,2] >>= \n -> ['a','b'] >>= \ch -> return (n,ch)
[(1,'a'),(1,'b'),(2,'a'),(2,'b')]

用 do notation 可以改写为

listOfTuples :: [(Int,Char)]
listOfTuples = do
    n <- [1,2]
    ch <- ['a','b']
    return (n,ch)

还可以用列表推导式改写

Prelude> [(n,ch)|n<-[1,2],ch<-['a','b']]
[(1,'a'),(1,'b'),(2,'a'),(2,'b')]

由此可见，列表推导式正是 List monad 的语法糖

那列表推导式中的过滤呢，我们需要先引入几个概念

MonadPlus 类型类用来表示具有 monoid 行为的 monad

class Monad m => MonadPlus m where
    mzero :: m a
    mplus :: m a -> m a -> m a

List 是这个类型类的实例

instance MonadPlus [] where
    mzero = []
    mplus = (++)

再来看一个函数

guard :: (MonadPlus m) => Bool -> m ()
guard True = return ()
guard False = mzero

guard 函数取一个布尔值，如果为 True，将 () 放在最小上下文中返回（这样做是为了让计算继续进行下去），否则产生一个表示计算失败的 monad

来看几个例子

Prelude Control.Monad> guard (5 > 2) :: Maybe ()
Just ()
Prelude Control.Monad> guard (1 > 2) :: Maybe ()
Nothing
Prelude Control.Monad> guard (5 > 2) :: [()]
[()]
Prelude Control.Monad> guard (1 > 2) :: [()]
[]

在列表推导式的过滤中，我们用 guard 函数来过滤非确定性计算

Prelude Control.Monad> [1..50] >>= (\x -> guard ('7' `elem` show x) >> return x)
[7,17,27,37,47]

使用 do notation 改写

sevensOnly :: [Int]
sevensOnly = do
    x <- [1..50]
    guard ('7' `elem` show x)
    return x

如果忘记写 return x 这一行，结果便是 [()]

monad laws

这样描述也许看起来不太明显，模块 Control.Monad 导出了一个函数 (<=<)，其类型为

(<=<) :: (Monad m) => (b -> m c) -> (a -> m b) -> (a -> m c)
f <=< g = (\x -> g x >>= f)

来测试一下

Prelude Control.Monad let f x = [x,-x]
Prelude Control.Monad let g x = [x*3,x*2]
Prelude Control.Monad let h = f <=< g
Prelude Control.Monad h 3
[9,-9,6,-6]

如此，我们便将两个 monad 式的函数组合了起来，上面的三条定律也可以等价描述为

不难看出，这主要是为了满足单位元的性质和二元运算的结合律

Writer monad

用来表示附有日志的值，这里日志是 Monoid 类型类的实例（便于使用 mappend）

newtype Writer w a = Writer { runWriter :: (a, w) }


instance (Monoid w) => Monad (Writer w) where
    return x = Writer (x, mempty)
    (Writer (x,v)) >>= f = let (Writer (y, v')) = f x in Writer (y, v `mappend` v')

注意这里使用了 newtype 关键词，将一个二元组包裹成一个新的类型

return 函数产生的最小上下文让附着的日志为 mempty，这是合乎逻辑的

让我们理解一下 >>= 函数的实现，这里 f x 返回一个 monad，我们使用模式匹配，取出新的值，并用 mappend 作用于原来的日志与新的日志。

(>>=) :: m a -> (a -> m b) -> m b

来测试一下

Prelude Control.Monad.Writer> runWriter (return 3 :: Writer String Int)
(3,"")
Prelude Control.Monad.Writer> runWriter (return 3 :: Writer (Sum Int) Int)
(3,Sum {getSum = 0})

字符串是 List 的语法糖，当然是 Monoid 类型类的实例

由于 Writer 并非 Show 的实例，我们需要用 runWriter 提取被包裹的二元组

下面我们试试 do notation，将两个数相乘，并附上日志

import Control.Monad.Writer


logNumber :: Int -> Writer [String] Int
logNumber x = writer (x, ["Got number: " ++ show x])


multWithLog :: Writer [String] Int
multWithLog = do
    a <- logNumber 3
    b <- logNumber 5
    return (a*b)

我们用 return 让 a*b 成为结果，因为 return 让附着的日志为 mempty，所以不会往日志里添加内容

需要提醒的时，模块 Control.Monad.Writer 没有导出 Writer 的值构造器，而导出了 writer 函数（作用与值构造器相同，包裹一个二元组）

Prelude Control.Monad.Writer> :t writer
writer :: MonadWriter w m => (a, w) -> m a

装载测试一下

*Main> runWriter multWithLog
(15,["Got number: 3","Got number: 5"])

有时候我们想显式地扩充日志，可以使用 tell 函数，它创建了一个表示 () 的 monad

Prelude Control.Monad.Writer> :t tell
tell :: MonadWriter w m => w -> m ()

我们修改上面的例子

import Control.Monad.Writer


logNumber :: Int -> Writer [String] Int
logNumber x = writer (x, ["Got number: " ++ show x])


multWithLog :: Writer [String] Int
multWithLog = do
    a <- logNumber 3
    b <- logNumber 5
    tell ["Gonna multiply these two"]
    return (a*b)

重新装载测试

*Main> runWriter multWithLog
(15,["Got number: 3","Got number: 5","Gonna multiply these two"])

再来一个例子，我们为欧几里得算法配备日志功能

import Control.Monad.Writer


gcd' :: Int -> Int -> Writer [String] Int
gcd' a b
    | b == 0 = do
        tell ["Finished with " ++ show a]
        return a
    | otherwise = do
        tell [show a ++ " mod " ++ show b ++ " = " ++ show (a `mod` b)]
        gcd' b (a `mod` b)

这里 b == 0 的情况也可以用一行解决

writer (a, ["Finished with " ++ show a])

装载测试一下

*Main> fst $ runWriter (gcd' 8 3)
1
*Main> mapM_ putStrLn $ snd $ runWriter (gcd' 8 3)
8 mod 3 = 2
3 mod 2 = 1
2 mod 1 = 0
Finished with 1

妙极了

然而，如果我们记录日志的顺序反过来，就像这样

import Control.Monad.Writer


gcdReverse :: Int -> Int -> Writer [String] Int
gcdReverse a b
    | b == 0 = do
        tell ["Finished with " ++ show a]
        return a
    | otherwise = do
        result <- gcdReverse b (a `mod` b)
        tell [show a ++ " mod " ++ show b ++ " = " ++ show (a `mod` b)]
        return result

装载测试的结果

*Main> mapM_ putStrLn $ snd $ runWriter (gcdReverse 8 3)
Finished with 1
2 mod 1 = 0
3 mod 2 = 1
8 mod 3 = 2

List 拼接的效率就会降低（原来是右结合，现在是左结合），更多解释见 performance - Why are difference lists more efficient than regular concatenation in Haskell? - Stack Overflow

这是我们就要引入一个新的数据结构 DiffList

DiffList

DiffList 实际上就是一个取 List 为参数，把另一个 List 放在其前面的函数

比如 [1,2,3] 的 DiffList 便是 \xs -> [1,2,3] ++ xs，简写为 [1,2,3]++

我们给出类型定义

newtype DiffList a = DiffList { getDiffList :: [a] -> [a] }

并给出 List 和 DiffList 的互相转换

toDiffList :: [a] -> DiffList a
toDiffList xs = DiffList (xs++)


fromDiffList :: DiffList a -> [a]
fromDiffList (DiffList f) = f []

下面让 DiffList 成为 Monoid 类型类的实例

newtype DiffList a = DiffList { getDiffList :: [a] -> [a] }


toDiffList :: [a] -> DiffList a
toDiffList xs = DiffList (xs++)


fromDiffList :: DiffList a -> [a]
fromDiffList (DiffList f) = f []


instance Semigroup (DiffList a) where
    (DiffList f) <> (DiffList g) = DiffList (\xs -> f (g xs))


instance Monoid (DiffList a) where
    mempty = DiffList (\xs -> [] ++ xs)

这里要注意的是，原书中的写法已经过时了，遂按照 A basic Monoid definition gives “No instance for (Semigroup MyMonoid) arising from the superclasses of an instance declaration” - Stack Overflow 中的回答修改

关键是下面这段话：

(<>) has been moved from Monoid to Semigroup, and all Monoid instances are required to also be Semigroup. mappend is just a synonym for (<>).

装载后测试

*Main> fromDiffList (toDiffList [1,2,3,4] `mappend` toDiffList [1,2,3])
[1,2,3,4,1,2,3]

这样我们就可以提升 gcdReverse 的性能了

import Control.Monad.Writer


newtype DiffList a = DiffList { getDiffList :: [a] -> [a] }


toDiffList :: [a] -> DiffList a
toDiffList xs = DiffList (xs++)


fromDiffList :: DiffList a -> [a]
fromDiffList (DiffList f) = f []


instance Semigroup (DiffList a) where
    (DiffList f) <> (DiffList g) = DiffList (\xs -> f (g xs))


instance Monoid (DiffList a) where
    mempty = DiffList (\xs -> [] ++ xs)


gcd' :: Int -> Int -> Writer (DiffList String) Int
gcd' a b
    | b == 0 = do
        tell (toDiffList ["Finished with " ++ show a])
        return a
    | otherwise = do
        result <- gcd' b (a `mod` b)
        tell (toDiffList [show a ++ " mod " ++ show b ++ " = " ++ show (a `mod` b)])
        return result

装载后测试良好

*Main> mapM_ putStrLn $ fromDiffList $ snd $ runWriter (gcd' 8 3)
Finished with 1
2 mod 1 = 0
3 mod 2 = 1
8 mod 3 = 2

Reader monad

回顾函数类型是 Functor 函子和 Applicative 函子

Prelude> (fmap (+3) (*8)) 8
67
Prelude> (+) <$> (*2) <*> (+10) $ 3
19

其实函数类型也是 Monad 类型类的实例，函数的上下文是结果值还没有得到，我们需要给函数提供一个参数来得到结果

instance Monad ((->) r) where
    return x = \_ -> x
    h >>= f = \w -> f (h w) w

来解读一下 >>= 的实现，这里的 h 是一个函数，(h w) 得到结果后，再对结果应用 f，返回一个 lambda 形式的匿名函数

我们把上面 Applicative 函子的例子用 do notation 重写为

import Control.Monad


addStuff :: Int -> Int
addStuff = do
    a <- (*2)
    b <- (+10)
    return (a+b)

装载后测试

*Main> addStuff 3
19

由于这里所有的函数都从一个共同的源头读取参数，function monad 也被称为 Reader monad

State monad

我们可以使用 State monad 优雅的表示带状态的计算

newtype State s a = State { runState :: s -> (a,s) }


instance Monad (State s) where
    return x = State $ \s -> (x,s)
    (State h) >>= f = State $ \s -> let (a, newState) = h s
                                        (State g) = f a
                                    in g newState

其中 s 表示状态类型，a 表示结果类型

联系 Writer monad 和 Reader monad 来解读这里的实现

来看看如何用 State monad 实现一个栈

import Control.Monad.State


type Stack = [Int]


pop :: State Stack Int
pop = state $ \(x:xs) -> (x,xs)


push :: Int -> State Stack ()
push a = state $ \xs -> ((),a:xs)


stackManip :: State Stack Int
stackManip = do
    push 3
    a <- pop
    pop

和 Writer monad 一样，我们使用 state 函数充当值构造器

Prelude Control.Monad.State> :t state
state :: MonadState s m => (s -> (a, s)) -> m a

装载后测试一下

*Main> runState stackManip [5,8,2,1]
(5,[8,2,1])

当然我们这里的 stackManip 也是一个带状态的计算，我们可以在其他的带状态的计算中将其复用

import Control.Monad.State


type Stack = [Int]


pop :: State Stack Int
pop = state $ \(x:xs) -> (x,xs)


push :: Int -> State Stack ()
push a = state $ \xs -> ((),a:xs)


stackManip :: State Stack Int
stackManip = do
    push 3
    a <- pop
    pop


stackStuff :: State Stack ()
stackStuff = do
    a <- stackManip
    if a == 5
        then push 5
        else do
            push 3
            push 8

这里还要介绍两个重要的函数 get 和 put

Prelude Control.Monad.State> :t get
get :: MonadState s m => m s
Prelude Control.Monad.State> :t put
put :: MonadState s m => s -> m ()

可以这样去理解

get = State $ \s -> (s,s)
put newState = State $ \s -> ((),newState)

我们可以用 get 和 put 来实现入栈和出栈的操作

import Control.Monad.State


type Stack = [Int]


pop :: State Stack Int
pop = do
    now <- get
    if length now >= 1
        then do
            let (x:xs) = now
            return x
        else
            return undefined


push :: Int -> State Stack ()
push x = do
    xs <- get
    put (x:xs)

特别要注意上面实现中的模式匹配，需要保证栈中元素数目不为零才能进行模式匹配，否则返回 undefined

State monad 可以让我们不用显式地写出每一步的状态，这可以帮助我们优化前面的鸟人问题的 do notation 写法以及随机数的产生，来回顾一下掷三个硬币的问题

import System.Random


threeCoins :: StdGen -> (Bool, Bool, Bool)
threeCoins gen =
    let (firstCoin, newGen) = random gen
        (secondCoin, newGen') = random newGen
        (thirdCoin, newGen'') = random newGen'
    in (firstCoin, secondCoin, thirdCoin)

使用 State monad，我们可以这样写

import System.Random
import Control.Monad.State


randomSt :: (RandomGen g, Random a) => State g a
randomSt = state random


threeCoins :: State StdGen (Bool,Bool,Bool)
threeCoins = do
    a <- randomSt
    b <- randomSt
    c <- randomSt
    return (a,b,c)

装载测试一下

*Main> runState threeCoins (mkStdGen 33)
ghc.exe: addLibrarySearchPath: C:\Users\VGalaxy\AppData\Local\Programs\stack\x86_64-windows\msys2-20180531\mingw64\lib (Win32 error 3):
ghc.exe: addLibrarySearchPath: C:\Users\VGalaxy\AppData\Local\Programs\stack\x86_64-windows\msys2-20180531\mingw64\bin (Win32 error 3):
((True,False,True),680029187 2103410263)

Either monad

类似 Maybe monad，上下文是可能失败的计算，但是这里有失败的具体信息

instance (Error e) => Monad (Either e) where
    return x = Right x
    Right x >>= f = f x
    Left err >>= f = Left err
    fail msg = Left (strMsg msg)

这里的 return 类似 Maybe monad 中的 return

>>= 检查左边的参数，若为 Right x，将 f 作用在 x 上，否则保持 Left err 不变

这里还要求 Left 包裹的值的类型是 Error 类型类的实例

尝试导入 Control.Monad.Error，发现好像被废弃了，那就不管 fail 和 strMsg 函数了

Prelude> import Control.Monad.Error


<interactive>:1:1: warning: [-Wdeprecations]
    Module 'Control.Monad.Error' is deprecated:
      Use "Control.Monad.Except" instead
Prelude Control.Monad.Error> :info Error
class Error a where
  noMsg :: a
  strMsg :: String -> a
        -- Defined in 'Control.Monad.Trans.Error'
instance [safe] Control.Monad.Trans.Error.ErrorList a => Error [a]
  -- Defined in 'Control.Monad.Trans.Error'
Prelude Control.Monad.Error> :t strMsg


<interactive>:1:1: warning: [-Wdeprecations]
    In the use of 'strMsg'
    (imported from Control.Monad.Error, but defined in Control.Monad.Trans.Error):
    Deprecated: "Use Control.Monad.Trans.Except instead"
strMsg :: Error a => String -> a

来测试一下

Prelude> Left "boom" >>= \x -> return (x+1)
Left "boom"
Prelude> Right 100 >>= \x -> Left "no way!"
Left "no way!"
Prelude> Right 3 >>= \x -> return (x + 100) :: Either String Int
Right 103

注意最后一个例子，Haskell 无法推断出 Either e 中的类型参数 e，所以我们显式加上类型注解

我们用 Either monad 优化前面的鸟人问题，用错误信息表示杆子的两边分别有几只鸟

type Birds = Int
type Pole = (Birds, Birds)


landLeft :: Birds -> Pole -> Either String Pole
landLeft n (left, right)
    | abs ((left + n) - right) < 4 = Right (left + n, right)
    | otherwise                    = Left (show (left + n) ++ " on left pole, " ++ show right ++ " on right pole.")


landRight :: Birds -> Pole -> Either String Pole
landRight n (left, right)
    | abs (left - (right + n)) < 4 = Right (left, right + n)
    | otherwise                    = Left (show left ++ " on left pole, " ++ show (right + n) ++ " on right pole.")

装载测试

*Main> return (0,0) >>= landRight 2 >>= landLeft 2 >>= landRight 2
Right (2,4)
*Main> return (0,0) >>= landLeft 1 >>= landRight 4 >>= landLeft (-1) >>= landRight (-2)
Left "0 on left pole, 4 on right pole."

monadic functions

以 monad 为参数或返回值的函数称为 monadic functions

liftM

先看类型

liftM :: Monad m => (a1 -> r) -> m a1 -> m r

我们发现 liftM 的类型与 fmap 几乎一致，只不过两者的类型约束不同

fmap :: Functor f => (a -> b) -> f a -> f b

回顾一下，在 Monad 类型类的定义中，我们并没有对实例的类型进行约束

这就意味着，如果我们能够实现 liftM 函数，那么 monad 提供的功能不会弱于 functor（我们只用 Monad 类型类提供给我们的函数，就实现了和 fmap 相同的效果）

现在我们来实现 liftM 函数

liftM :: (Monad m) => (a -> b) -> m a -> m b
liftM f m = m >>= (\x -> return (f x))

或使用 do notation

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

来测试一下

Prelude Control.Monad.Writer> runWriter $ liftM not $ writer (True, "chickpeas")
(False,"chickpeas")
Prelude Control.Monad.Writer> runWriter $ fmap not $ writer (True, "chickpeas")
(False,"chickpeas")

可以发现，liftM 函数或者 fmap 不会改变 monad 的上下文（在这里便是附有的日志）

ap

先看类型

ap :: Monad m => m (a -> b) -> m a -> m b

我们发现 ap 的类型与 (<*>) 几乎一致，只不过两者的类型约束不同

(<*>) :: Applicative f => f (a -> b) -> f a -> f b

于是相似的一幕将要发生了，我们来实现 ap 函数

ap :: (Monad m) => m (a -> b) -> m a -> m b
ap mf m = do
    f <- mf
    x <- m
    return (f x)

于是，monad 提供的功能不会弱于 applicative functor

来测试一下

Prelude Control.Monad> [(+1),(+2),(+3)] `ap` [10,11]
[11,12,12,13,13,14]
Prelude Control.Monad> [(+1),(+2),(+3)] <*> [10,11]
[11,12,12,13,13,14]

liftM2

对于 applicative style，我们有类似的 liftM2 函数，对应了 liftA2 函数

liftM2 :: Monad m => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r

其实现与 liftM 类似，来测试一下

Prelude Control.Monad> liftM2 (:) (Just 3) (Just [4])
Just [3,4]
Prelude Control.Monad> liftA2 (:) (Just 3) (Just [4])
Just [3,4]

Monad 类型类已经杀疯了，我们来总结一下，如果某类型是 Monad 类型类的实例：

join

更进一步，可以将嵌套的 monad 展平，例如让 Just (Just 9) 变成 Just 9，我们可以使用 join 函数

join :: Monad m => m (m a) -> m a

我们来实现它

join :: (Monad m) => m (m a) -> m a
join mm = do
    m <- mm
    m

这里的关键是，当执行 m <- mm 时，monad 的上下文已经被考虑到了

先试试 Maybe 和 Either

Prelude Control.Monad> join (Just (Just 9))
Just 9
Prelude Control.Monad> join (Just Nothing)
Nothing
Prelude Control.Monad> join Nothing
Nothing
Prelude Control.Monad> join (Right (Right 9)) :: Either String Int
Right 9
Prelude Control.Monad> join (Right (Left "error")) :: Either String Int
Left "error"
Prelude Control.Monad> join (Left "error") :: Either String Int
Left "error"

对于 List，join 等价于 concat

Prelude Control.Monad> join [[1,2,3],[4,5,6]]
[1,2,3,4,5,6]

注意这里 mappend 的顺序

Prelude Control.Monad.Writer> runWriter $ join (writer (writer (1,"aaa"),"bbb"))
(1,"bbbaaa")

装载上我们栈的实现来试试

*Main> runState (join (state $ \s -> (push 10, 1:2:s))) [0,0,0]
((),[10,1,2,0,0,0])

这里的 [0,0,0] 作为参数传入 lambda 中的 s

对于 join 函数，一个重要的特性是 m >>= f 等同于 join (fmap f m)，先举一个例子

Prelude Control.Monad> Just 9 >>= \x -> Just (Just (x + 1))
Just (Just 10)

这等价于 join (fmap (\x -> Just (Just (x + 1))) Just 9)，也就是 join (Just (Just (Just 10)))，即 Just (Just 10)（不过好像不能直接在交互界面计算），其用途在后面会得到体现

对于 join 函数，另一个重要的特性是它无法通过 Applicative 类型类或者 Functor 类型类提供的函数实现

filterM

filterM :: Applicative m => (a -> m Bool) -> [a] -> m [a]

对比 filter 的类型

filter :: (a -> Bool) -> [a] -> [a]

filterM 的谓词函数有一个上下文，举个例子，我们让过滤带上日志功能

import Control.Monad.Writer


keepSmall :: Int -> Writer [String] Bool
keepSmall x
    | x < 4 = do
        tell ["Keeping " ++ show x]
        return True
    | otherwise = do
        tell [show x ++ " is too large, throwing it away"]
        return False

装载测试一下

*Main> fst $ runWriter $ filterM keepSmall [9,1,5,2,10,3]
[1,2,3]
*Main> mapM_ putStrLn $ snd $ runWriter $ filterM keepSmall [9,1,5,2,10,3]
9 is too large, throwing it away
Keeping 1
5 is too large, throwing it away
Keeping 2
10 is too large, throwing it away
Keeping 3

另一个例子是我们可以用 filterM 得到一个列表的幂集

import Control.Monad


powerset :: [a] -> [[a]]
powerset xs = filterM (\x -> [True, False]) xs

这里的上下文是非确定性，装载测试一下

*Main> powerset [1,2,3]
[[1,2,3],[1,2],[1,3],[1],[2,3],[2],[3],[]]

foldM

foldM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b

对应 foldl

foldl :: Foldable t => (b -> a -> b) -> b -> t a -> b

举个例子，下面的折叠拥有可能会失败的上下文

import Control.Monad


binSmalls :: Int -> Int -> Maybe Int
binSmalls acc x
    | x > 9     = Nothing
    | otherwise = Just (acc + x)

装载测试一下

*Main> foldM binSmalls 0 [2,8,3,1]
Just 14
*Main> foldM binSmalls 0 [2,11,3,1]
Nothing

Making monads

概率列表，令列表中的每一个元素都伴随着这个元素出现的概率

[(3,0.5),(5,0.25),(9,0.25)]

由于浮点数有精度问题，我们将浮点数换为有理数

[(3,1%2),(5,1%4),(9,1%4)]

其中模块 Data.Ratio 导入了有理数

Prelude Data.Ratio> 1%4
1 % 4
Prelude Data.Ratio> 1%3 + 5%4
19 % 12

我们来创建一个新的类型

import Data.Ratio


newtype Prob a = Prob { getProb :: [(a,Rational)] } deriving Show

这首先是 Functor 类型类的实例，我们保持上下文（概率）不变

instance Functor Prob where
    fmap f (Prob xs) = Prob $ map (\(x,p) -> (f x,p)) xs

下面我们让它成为 Monad 类型类的实例

return 函数容易实现，单元素列表，对应的概率上下文为 1

思考 >>= 函数，由于 m >>= f 等同于 join (fmap f m)，我们只要实现对应的 join 就可以了，我们称它为 flatten

flatten :: Prob (Prob a) -> Prob a
flatten (Prob xs) = Prob $ concat $ map multAll xs
    where multAll (Prob innerxs,p) = map (\(x,r) -> (x,p*r)) innerxs

在新版本中，还要让其成为 Applicative 类型类的实例

import Data.Ratio
import Control.Monad
import Data.List (all)


newtype Prob a = Prob { getProb :: [(a,Rational)] } deriving Show


instance Functor Prob where
    fmap f (Prob xs) = Prob $ map (\(x,p) -> (f x,p)) xs


instance Applicative Prob where
    pure x = Prob [(x,1%1)]
    (Prob x) <*> (Prob xs) = let [(fx,y)] = x in Prob $ map (\(x,p) -> (fx x,p*y)) xs


flatten :: Prob (Prob a) -> Prob a
flatten (Prob xs) = Prob $ concat $ map multAll xs
    where multAll (Prob innerxs,p) = map (\(x,r) -> (x,p*r)) innerxs


instance Monad Prob where
    return x = Prob [(x,1%1)]
    m >>= f = flatten (fmap f m)


data Coin = Heads | Tails deriving (Show, Eq)


coin :: Prob Coin
coin = Prob [(Heads,1%2),(Tails,1%2)]


loadedCoin :: Prob Coin
loadedCoin = Prob [(Heads,1%10),(Tails,9%10)]


flipThree :: Prob Bool
flipThree = do
    a <- coin
    b <- coin
    c <- loadedCoin
    return (all (==Tails) [a,b,c])

概率列表可以帮助我们处理概率，比如说我们有两枚普通硬币和一枚不均匀的硬币，如果同时投掷三枚硬币，三枚都是反面朝上的概率是多少，我们装载模块进行测试

*Main> getProb flipThree
[(False,1 % 40),(False,9 % 40),(False,1 % 40),(False,9 % 40),(False,1 % 40),(False,9 % 40),(False,1 % 40),(True,9 % 40)]

这里 True（也就是三枚都是反面朝上）的占比是 9/40（思考如何合并同类项）

另一个重要的话题是，我们需要确认类型 Prob 满足三个类型类的定律

在这里 Applicative 类型类的实现似乎有点问题（第一个参数只能是单元素列表，而且类型会报错）

*Main> (Prob [((+ 3), 1 % 1)]) (<*>) (Prob [(2, 1 % 2)])

我的想法是让函数和参数都拥有概率的上下文，对于函数的概率

Prob [((+ 3), 1 % 3)]

相当于

Prob [((+ 3), 1 % 3), (id, 2 % 3)]

总之每次计算后，合并同类项，并使概率之和为 1 % 1

问题求解

快速排序

知识点：递归函数

quicksort :: (Ord a) => [a] -> [a]
quicksort [] = []
quicksort (x:xs) =
    let smallerSorted = quicksort [a | a <- xs, a <= x]
        biggerSorted = quicksort [a | a <- xs, a > x]
    in smallerSorted ++ [x] ++ biggerSorted

TODO

知识点：IO、文件读写、命令行参数

最短路径

知识点：数据类型的创建

马走日

知识点：List monad、composing monadic functions

先简单介绍一下 composing monadic functions，其实核心就是在 monad laws 中提到的函数 (<=<)

(<=<) :: (Monad m) => (b -> m c) -> (a -> m b) -> (a -> m c)
f <=< g = (\x -> g x >>= f)

对于普通的函数列表，想将其组合起来，可以这样做

Prelude> foldr (.) id [(+1),(*100),(+1)] 1
201

对于 monad 式的函数列表，我们只要用 (<=<) 来代替 (.)，return 来代替 id 就可以完成相同的效果

Prelude Control.Monad> foldr (<=<) return [\x -> return (x + 1), \x -> return (x * 100), \x -> return (x + 1)] 1
201

现在我们来考虑马走日问题，给定初始位置，在给定步数内，能否走到终点位置，限定棋盘为 8×8 的大小

import Data.List
import Control.Monad


type KnightPos = (Int, Int)


moveKnight :: KnightPos -> [KnightPos]
moveKnight (c,r) = do
    (c',r') <- [(c+2,r-1),(c+2,r+1),(c-2,r-1),(c-2,r+1)
               ,(c+1,r-2),(c+1,r+2),(c-1,r-2),(c-1,r+2)]
    guard (c' `elem` [1..8] && r' `elem` [1..8])
    return (c',r')


inMany :: Int -> KnightPos -> [KnightPos]
inMany x start = return start >>= foldr (<=<) return (replicate x moveKnight)


canReachIn :: Int -> KnightPos -> KnightPos -> Bool
canReachIn x start end = end `elem` inMany x start

我们用二元组表示马的位置

函数 moveKnight 中的 <- 表示 List monad，是非确定性计算，并使用 guard 处理越界的情况

函数 inMany 表示在给定步数内马能够走到的位置

装载测试一下

*Main> canReachIn 3 (6,2) (6,1)
True
*Main> canReachIn 5 (6,2) (7,1)
False

若这些计算都是惰性的，那么蕴藏在这段程序后的思想便是 BFS

逆波兰表达式求值

知识点：foldM、Maybe monad

import Control.Monad
import Data.List


solveRPN :: String -> Maybe Double
solveRPN st = do
    [result] <- foldM foldingFunction [] (words st)
    return result


readMaybe :: (Read a) => String -> Maybe a
readMaybe st = case reads st of [(x,"")] -> Just x
                                _ -> Nothing


foldingFunction :: [Double] -> String -> Maybe [Double]
foldingFunction (x:y:ys) "*" = return ((x * y):ys)
foldingFunction (x:y:ys) "+" = return ((x + y):ys)
foldingFunction (x:y:ys) "-" = return ((y - x):ys)
foldingFunction xs numberString = liftM (:xs) (readMaybe numberString)

我们用一个被 Maybe 包裹的列表表示操作数栈，由于这里表示可能会失败的计算，我们使用 return 和 liftM 对被包裹的列表进行拼接

这里的 readMaybe 中用到了 reads 函数

reads :: Read a => ReadS a


type ReadS a = String -> [(a, String)]
        -- Defined in 'Text.ParserCombinators.ReadP'

当解析成功时，reads 返回一个单元素的列表，这个元素是一个二元组，前面的是成功读入的值，后面是没有被消耗的部分，若解析失败，则返回一个空列表（这里的解析是对 Double 类型的解析，如 "3.14" 可以被成功解析，"hello" 则不能被解析）

read :: Read a => String -> a

在 readMaybe 中，我们认为只有消耗了完整的输入才算读入成功

装载测试一下

*Main> solveRPN "1 2 * 4 +"
Just 6.0
*Main> solveRPN "1 2 * 4 + 5 *"
Just 30.0

来几个失败的例子

*Main> solveRPN "1 2 * 4"
Nothing
*Main> solveRPN "1 2 * * 4 5"
Nothing
*Main> solveRPN "1 8 wharglbllargh"
Nothing

第一次失败是因为最后栈的长度大于 1，solveRPN 函数中的模式匹配失败了，第三次失败是因为没有消耗了完整的输入

来看一下第二次失败的原因，在得到 ["1","2","*","*","4","5"] 后，第一个和第二个读取的是数字，压入栈中，第三个读取到了 *，函数模式匹配和列表模式匹配成功，return 后栈中只有一个数字，第四个读取到了 *，此时列表模式匹配失败（对 (x:y:ys) 的匹配）

Zipper

Zipper - HaskellWiki

在某个数据结构的基础上，使用 Zipper 来定位数据结构中的一个特定部分

List

场景：文本编辑器，表示光标所在的行

type ListZipper a = ([a],[a])


goForward :: ListZipper a -> ListZipper a
goForward (x:xs, bs) = (xs, x:bs)


goBack :: ListZipper a -> ListZipper a
goBack (xs, b:bs) = (b:xs, bs)


(-:) :: ListZipper a -> (ListZipper a -> ListZipper a) -> ListZipper a
(-:) x f = f x


testList :: [Int]
testList = [1,2,3,4]

装载测试一下

*Main> (testList,[]) -: goForward -: goForward
([3,4],[2,1])
*Main> (testList,[]) -: goForward -: goBack
([1,2,3,4],[])

Tree

场景：文件系统，文件和文件夹

import Control.Monad


data Tree a = Empty | Node a (Tree a) (Tree a) deriving (Show)
data Crumb a = LeftCrumb a (Tree a) | RightCrumb a (Tree a)
type Breadcrumbs a = [Crumb a]
type Zipper a = (Tree a, Breadcrumbs a)


instance Show (Crumb a) where
    show (LeftCrumb a t) = "L"
    show (RightCrumb a t) = "R"


goLeft :: Zipper a -> Maybe (Zipper a)
goLeft (Node x l r, bs) = Just (l, LeftCrumb x r:bs)
goLeft (Empty, _) = Nothing


goRight :: Zipper a -> Maybe (Zipper a)
goRight (Node x l r, bs) = Just (r, RightCrumb x l:bs)
goRight (Empty, _) = Nothing


goUp :: Zipper a -> Maybe (Zipper a)
goUp (t, LeftCrumb x r:bs) = Just (Node x t r, bs)
goUp (t, RightCrumb x l:bs) = Just (Node x l t, bs)
goUp (_, []) = Nothing


topMost :: Zipper a -> Maybe (Zipper a)
topMost (t,[]) = Just (t,[])
topMost z = (topMost <=< goUp) z


modify :: (a -> a) -> Zipper a -> Maybe (Zipper a)
modify f (Node x l r, bs) = Just (Node (f x) l r, bs)
modify f (Empty, bs) = Just (Empty, bs)


attach :: Tree a -> Zipper a -> Maybe (Zipper a)
attach t (_, bs) = Just (t, bs)


testTree :: Tree Char
testTree =
    Node 'P'
        (Node 'O'
            (Node 'L'
                (Node 'N' Empty Empty)
                (Node 'T' Empty Empty)
            )
            (Node 'Y'
                (Node 'S' Empty Empty)
                (Node 'A' Empty Empty)
            )
        )
        (Node 'L'
            (Node 'W'
                (Node 'C' Empty Empty)
                (Node 'R' Empty Empty)
            )
            (Node 'A'
                (Node 'A' Empty Empty)
                (Node 'C' Empty Empty)
            )
        )

解读一下 Zipper 数据类型，第一个分量记录了以当前焦点为根节点的树的信息，第二个分量记录了在树上移动的轨迹，这里的轨迹是一个列表，列表中的每一个元素代表了向左走（并且记录了向左走时离开的那个节点以及没有被我们访问的右子树）或是向右走

为了更加清楚的显示移动轨迹，这里自定义了 Crumb 类型的表示方法

由于 goLeft、goRight 和 goUp 在移动当前焦点的位置时，可能会导致模式匹配失败（例如在空树上向左或向右走，或者在原树根上向上走）因此在函数的实现中引入了 Maybe monad

goLeft、goRight 和 goUp 移动当前焦点的位置，同时记录移动的轨迹

modify 修改当前焦点代表的树的根节点，若当前焦点代表了空树，则保持原样

attach 替换当前焦点代表的树，使用场景一般是当前焦点代表了空树，我们替换成一棵非空的树

topMost 则移动到原树根

装载测试一下

*Main> return (testTree,[]) >>= goLeft >>= goRight
Just (Node 'Y' (Node 'S' Empty Empty) (Node 'A' Empty Empty),[R,L])
*Main> return (testTree,[]) >>= goLeft >>= goRight >>= modify (\_ -> 'P')
Just (Node 'P' (Node 'S' Empty Empty) (Node 'A' Empty Empty),[R,L])
*Main> return (testTree,[]) >>= goLeft >>= goRight >>= goLeft >>= goUp >>= modify (\_ -> 'P')
Just (Node 'P' (Node 'S' Empty Empty) (Node 'A' Empty Empty),[R,L])
*Main> return (testTree,[]) >>= goLeft >>= goRight >>= goLeft >>= goRight >>= attach (Node 'Z' Empty Empty)
Just (Node 'Z' Empty Empty,[R,L,R,L])
*Main> return (testTree,[]) >>= goLeft >>= goRight >>= goLeft >>= goRight >>= attach (Node 'Z' Empty Empty) >>= topMost
Just (Node 'P' (Node 'O' (Node 'L' (Node 'N' Empty Empty) (Node 'T' Empty Empty)) (Node 'Y' (Node 'S' Empty (Node 'Z' Empty Empty)) (Node 'A' Empty Empty))) (Node 'L' (Node 'W' (Node 'C' Empty Empty) (Node 'R' Empty Empty)) (Node 'A' (Node 'A' Empty Empty) (Node 'C' Empty Empty))),[])

来些 Nothing 的例子

*Main> return (testTree,[]) >>= goUp
Nothing
*Main> return (testTree,[]) >>= goUp >>= attach (Node 'Z' Empty Empty)
Nothing
*Main> return (testTree,[]) >>= goLeft >>= goRight >>= goLeft >>= goRight >>= goLeft
Nothing

需要注意的是，当我们通过 modify 和 attach 改变了一棵树时，并没有修改原来的树，而是返回了一棵新的树，这是因为 Haskell 的纯粹性，不允许赋值。也就是说，通过使用 Zipper，我们无偿获得了版本功能，这便是 Haskell 数据结构的持久性所带来的价值。