{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RankNTypes #-}
module MicroLens where
import Control.Applicative import Data.Monoid importqualified Data.Traversable as T import Prelude hiding (sum) import Unsafe.Coerce
--------------------------------------------------------- -- Some basic libraries classProfunctor p where dimap :: (a' -> a) -> (b -> b') -> (p a b -> p a' b') dimap f g = lmap f . rmap g lmap :: (a' -> a) -> (p a b -> p a' b) lmap f = dimap f id rmap :: (b -> b') -> (p a b -> p a b') rmap f = dimap id f classProfunctor p => Choice p where left' :: p a b -> p (Either a c) (Either b c) right' :: p a b -> p (Either c a) (Either c b) instanceProfunctor (->) where dimap f g h = g . h . f instanceChoice (->) where left' f = either (Left . f) Right right' f = either Left (Right . f) classContravariant f where contramap :: (a' -> a) -> (f a -> f a')
-- Control.Applicative.Const replicated here for your -- convenience newtypeK b a = K { getK :: b } derivingFunctor instanceMonoid b => Applicative (Kb) where pure _ = K mempty K e <*> K f = K (e <> f) instanceContravariant (Kb) where contramap f (K b) = K b
newtypeId a = Id { getId :: a } derivingFunctor instanceApplicativeIdwhere pure = Id Id f <*> Id x = Id (f x)
--------------------------------------------------------- -- The lens types you'll implement
-- | Optic is the general pattern for all other lens types. typeOptic p f s t a b = p a (f b) -> p s (f t)
typeIso s t a b = forall p f . (Profunctor p, Functor f) => Optic p f s t a b
typeLens s t a b = forall f . Functor f => Optic (->) f s t a b
typeTraversal s t a b = forall f . Applicative f => Optic (->) f s t a b
typeFold s a = forall f . (Contravariant f, Applicative f) => Optic (->) f s s a a
typePrism s t a b = forall p f . (Choice p, Applicative f) => Optic p f s t a b
-- | A function which takes a lens and looks through it. -- The type given is specialized to provide a hint as to -- how to write 'view'. The more intuitive type for its use -- is -- -- @ -- view :: Lens s t a b -> (s -> a) -- @ view :: Optic (->) (K a) s t a b -> (s -> a) view l = getK . l K
-- | A function which takes a lens and a transformation function -- and applies that transformer at the focal point of the lens. -- The type given is specialized to provide a hint as to how to -- write 'over'. The more intuitive type for its use is -- -- @ -- over :: Lens s t a b -> (a -> b) -> (s -> t) -- @ over :: Optic (->) Id s t a b -> (a -> b) -> (s -> t) over l f = getId . l (Id . f)
-- | A function from a lens and a value which sets the value -- at the focal point of the lens. The type given has been -- specialized to provide a hint as to how to write 'set'. The -- more intuitive type for its use is -- -- @ -- set :: Lens s t a b -> b -> (s -> t) -- @ set :: Optic (->) Id s t a b -> b -> (s -> t) set l b = getId . l (Id . const b)
-- | A traversal which focuses on each element in any -- Traversable container. elements :: T.Traversable f => Traversal (f a) (f b) a b elements = T.traverse
-- | A function which takes a Traversal and pulls out each -- element it focuses on in order. The type has been -- specialized, as the others, but a more normal type might be -- -- @ -- toListOf :: Traversal s s a a -> (s -> [a]) -- @ toListOf :: Optic (->) (K (Endo [a])) s s a a -> (s -> [a]) toListOf l s = appEndo (getK $ l (\a -> K $ Endo (a:)) s) []
-- | A function which takes any kind of Optic which might -- be focused on zero subparts and returns Just the first -- subpart or else Nothing. -- -- @ -- preview :: Traversal s s a a -> (s -> Maybe a) -- @ preview :: Optic (->) (K (First a)) s s a a -> (s -> Maybe a) preview l s = getFirst (getK $ l (\a -> K $ First $ Just a) s)
-- | A helper function which witnesses the fact that any -- container which is both a Functor and a Contravariant -- must actually be empty. coerce :: (Contravariant f, Functor f) => f a -> f b coerce = contramap (const ()) . fmap (const ())
-- f a -> f Void
-- | A Fold which views the result of a function application to :: (a -> b) -> Fold a b to f g = contramap f . g . f
-- | A prism which focuses on the left branch of an Either _Left :: Prism (Either a x) (Either b x) a b _Left = rmap (either (fmap Left) (pure . Right)) . left' -- | A prism which focuses on the right branch of an Either _Right :: Prism (Either x a) (Either x b) a b _Right = rmap (either (pure . Left) (fmap Right)) . right'
-- | An iso which witnesses that tuples can be flipped without -- losing any information _flip :: Iso (a, b) (a, b) (b, a) (b, a) _flip = dimap swap (fmap swap) where swap (a, b) = (b, a)
比如说我需要装各种haskell插件，于是M-x configuration-layer/create-layer先创建一个layer，位置在private就好（文档上看似乎只有private是装包能用的，不过git will be ignored是怎么回事…）。之后就会要求给这个layer起个名字，我这里叫Haskell（然而规范都是小写，好孩子不要学）。
-- u : input type d : output type newtypeCoroutine r u d a = Coroutine { runCoroutine :: (a -> r) -> r } derivingFunctor
dataCommand r u d a = Done a | Out d (Coroutine r u d a) | In (\u -> Coroutine r u d a) derivingFunctor
这里详细的解释一下。Coroutine实际上和Cotinuation是一个东西，只不过多了额外的两个类型参数。u为输入参数的类型，d为输出参数的类型。Command r u d a里则定义了三种基本类型，分别为Done a表示计算完成，没有输入输出；Out d (Coroutine r u d a)表示输出类型为d的数据，同时执行参数中的计算；In (\u -> Coroutine r u d a)表示需要输入数据，并在等待输入时执行参数中的计算。很优雅的抽象，对吧？下一步就是将Coroutine声明为Monad：
1 2 3 4 5 6 7 8 9 10 11 12 13 14
-- useful alias apply = runCoroutine instanceApplicative (Coroutinerud) where pure = return (<*>) = ap instanceMonad (Coroutinerud) where return a = Coroutine ($ a) f >>= g = Coroutine $ \k -> apply f $ \a -> case a of Done x -> (g x) `apply` k Out d c -> k $ Out d (c >>= g) In fn -> k $ In (\u -> fn u >>= g)
这里在做的实际上和原来并没有太大区别，只是在每一个lambda表达式中多了一个判断。
如果计算完成了（Done a），那么直接进行下一个计算。
如果计算需要输出类型为d的数据（`Out d (Coroutine r u d a))，那么挂起这个计算，直到另一个计算返回结果，并将函数应用到这个结果上。
output :: a -> Coroutine r u a () input :: Coroutine r v d v produce :: [a] -> Coroutine r u a () consume :: Coroutine [t] u t a -> [t] filterC :: (v -> Bool) -> Coroutine r v v () limit :: Int -> Coroutine r v v () suppress :: Int -> Coroutine r v v ()
-- alias mkCoroutine :: Command r u d a -> Coroutine r u d a mkCoroutine command = Coroutine ($ command)
先来看output，我们希望它立刻输出一些东西，于是可以写出：
1 2
output :: a -> Coroutine r u a () output v = mkCoroutine $ Out v (return ())
然后是input，它在获取一个输入后返回它：
1 2
input :: Coroutine r v d v input u = mkCoroutine $ In (\u -> return u)
produce连续的产生输出，而consume将所有的Out提取出来：
1 2 3 4 5 6 7 8
produce :: [a] -> Coroutine r u a () produce xs = mapM_ output xs
consume :: Coroutine [t] u t a -> [t] consume c = runCoroutine c go where go (Done _) = [] go (Out d n) = d : consume n go (In _) = []
filterC挑选出每一个符合条件的输入并输出：
1 2 3 4 5
filterC :: (v -> Bool) -> Coroutine r v v () filterC p = do i <- input when (p i) (output i) filterC p
最后，limit类似于take，suppress类似于drop：
1 2 3 4 5 6 7
limit :: Int -> Coroutine r v v () limit n = replicateM_ n (input >>= output)
suppress :: Int -> Coroutine r v v () suppress n | n > 0 = input >> suppress (n-1) | otherwise = forever $ input >>= output
newtypeCont r a = Cont { runCont :: (a -> r) -> r } instanceMonad (Contr) where return a = Cont ($ a) m >>= k = Cont $ \c -> runCont m $ \a -> runCont (k a) c
那么Continuation究竟是一个什么概念？一般来说，Continuation表示的是“剩下的计算”的概念。熟悉命令式语言的读者可能对此没有什么概念，不过在命令式的世界里这件事可以粗略的表示为“分号后面的部分”。举个例子来说，假设我们这样一个表达式foo (bar x y) z，观察括号里面的部分，(bar x y)求值之后，需要应用到foo _ z。写成合法的表达式就是\a -> foo a z，这也就是“剩下的计算”的语义。这样，我们就可以通过把bar x y应用到\a -> foo a z来重新构建原来的形式。
不过这样看起来实在不太雅观，我们能不能把它变的好看一点呢？不如试试把外面的放到里面，把里面的放到外面？这样我们就有了\k -> k (bar a b)。这里k表示剩余的计算。
这样表示起来我们就获得了很好的灵活性。看看原来的表达式foo (bar a b) z，我们不仅仅把bar a b从上下文中提取了出来，而且还能在这个subexpression中操作外面的上下文！等等这个是不是听起来很耳熟？仿佛已经闻到了一股清新的Monad的气味！
不妨把这个想象成一种挂起的计算，并且我们能够显式地控制接下来将要发生什么。那么，我们要怎么推广到一般情况呢？观察到内部的subexpression并没有变化，不妨把它作为参数，得到\x k -> k x。呃…这不就是单纯的flip ($)吗！看起来，Continuation本质上并没有比函数应用多出什么东西。
那么这个Monad的上下文是什么？对于x :: a来说，这仅仅意味着我们对它应用flip ($)。$的类型签名为(a -> b) -> a -> b，flip ($)的类型则是简单的a -> (a -> b) -> b。噢，看起来已经有点像Cont的形式了！正如一个continuation代表着“未来的”某种计算，类型a自然就代表着某种意义上的“过去”。把(a -> b) -> b替换成Cont b a，我们就得到了return的类型a -> Cont b a！
所以一个Cont r a究竟意味着什么？不过是一个等待着接受一个函数a -> r，并把它应用到a类型的函数罢了。实际上，如果给一个id函数进去，Cont r a和a完全是等价的！在这种语义下，>>=该怎么实现呢？
我们再来观察一下>>=的类型：(>>=) :: Cont r a -> (a -> Cont r b) -> Cont r b，展开类型之后即(>>=) :: (a -> r) -> r -> (a -> (b -> r) -> r) -> (b -> r) -> r。注意到返回类型应该是(b -> r) -> r，我们应该能够很自然的写出
1
(x |>) >>= (|>) = \f -> x |> (\b -> b |> f)
现在一切都很显然了，我们所做的不过是一连串的函数应用而已。把|>翻译为runCont c f，我们就得到了前面看到的m >>= k = \f -> runCont m (\b -> runCont (k b) f)。不怎么好理解是不是？人肉展开一下可以知道，我们实际上就是构造了这样一大串无用的表达式\f -> x |> (\a -> a |> (\b -> b |> ........ (\z -> z |> f))))。对，没错，你已经得到了Continuation Monad。是不是有一种上当的感觉？绕了这么大一个圈子最后只是把一个好好的f x变成了一大串无用的lambda表达式？别着急，就连最“无用”的id都能起到很大的作用，在下一篇文章里我们就介绍Continuation Monad的应用：Coroutine。
-- Standalone data family datafamilyXList a data instance XListChar = XNil | XConsChar (XLista) data instance XList () = XListInt
-- Standalone type family typefamilyGMap k v type instance GMapIntInt = MapIntInt type instance GMap () a = a
-- Associated form classFamilyClass m where dataFoo m :: * -> * typeBar foobar :: Foo -> Bar instanceFamilyClassIntwhere dataFooInt v = Foo (MapIntv) typeBar = [Int] foobar = ...
{-# LANGUAGE FunctionalDependencies, TypeFamilies #-} classFuncClass a b | b -> a where foo :: a -> b -> a classFamClass a where dataElem a :: * -> * -> * bar :: a -> Elem a -> a
bar :: StateTInt (StateString) (String,Int) bar = do modify (+1) -- outer monad lift $ modify (++ "1") -- inner monad a <- get b <- lift get return (b,a)