# dramforever

a row of my life

2017-01-25
``````{-# LANGUAGE DeriveFunctor #-}

``````import Control.Monad.Free
import Prelude.Extras (Show1)``````

``````data B a = B a a
deriving (Functor, Show)``````
``instance Show1 B``
``type Tree = Free B``
``````leaf :: a -> Tree a
leaf = Pure``````
``````fork :: Tree a -> Tree a -> Tree a
fork a b = Free (B a b)``````

``````ghci> fork (leaf 2) (leaf 3)
Free (B (Pure 2) (Pure 3))``````

``````ghci> fork (leaf 2) (leaf 3) >>= (\x -> fork (leaf \$ 5 * x) (leaf \$ 6 * x))
Free (B (Free (B (Pure 10) (Pure 12))) (Free (B (Pure 15) (Pure 18))))``````

Monads provide substitution (fmap) and renormalization (join) — Edward Kmett

``````instance Functor f => Monad (Free f) where
return = Pure
Pure a >>= f = f a
Free m >>= f = Free ((>>= f) <\$> m)``````

`>>=` 读作“替换”之后，这就变得非常显然了。

``return a >>= f = f a``

``m >>= return = m``

`Pure a` 替换成 `Pure a`。也挺对的。

``(m >>= f) >>= g = m >>= (\x -> f x >>= g)``

### 变量的替换

``````data Var a = X | U a
deriving (Show, Functor)``````
``````AST a
AST (Var a)``````

``````data AST a
= FV a
| AST a :@ AST a
| Lam (AST (Var a))
deriving (Functor, Show)``````
``````instance Applicative AST where
pure = FV
(<*>) = ap``````

``````instance Monad AST where
FV a >>= f = f a
Lam m >>= f = Lam (m >>= go)
where go X = return X
go (U r) = U <\$> (f r)``````

`AST a` 中的 `a` 是所有未被绑定的变量，所以在 `(>>=)` 中我们把绑定了的变量单独考虑就好了。

``    (m :@ n) >>= f = (m >>= f) :@ (n >>= f)``

``````abstract :: Eq a => a -> AST a -> AST (Var a)
abstract v e = go <\$> e
where go x = if x == v then X else U x``````

``````instantiate :: AST a -> AST (Var a) -> AST a
instantiate m e = e >>= go
where go X = m
go (U x) = return x``````
``````lam :: Eq a => a -> AST a -> AST a
lam v e = Lam (abstract v e)``````
``````ghci> abstract "a" (FV "a" :@ FV "b")
FV X :@ FV (U "b")
ghci> instantiate (FV "x" :@ FV "y") it      -- it 指的是上一个表达式的值哦
(FV "x" :@ FV "y") :@ FV "b"
ghci> lam "x" it
Lam ((FV X :@ FV (U "y")) :@ FV (U "b"))
it :: AST [Char]
(0.01 secs, 175,712 bytes)
ghci> lam "y" it
Lam (Lam ((FV X :@ FV (U X)) :@ FV (U (U "b"))))
it :: AST [Char]
(0.01 secs, 184,816 bytes)
ghci> lam "b" it
Lam (Lam (Lam ((FV X :@ FV (U X)) :@ FV (U (U X)))))``````