Kata:Lens-Maker

最近在研究Profunctor这个东西。其定义虽然很简单但却有点意义不明..
听人安利这个Kata做完就会有个大概的认识于是试一试。

这个Kata基本上就是从头造个Lens库出来.. 难度自然也是鬼畜级别的。所以可能会坑很多天..

首先是一些基本类型定义。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RankNTypes    #-}

module MicroLens where

import           Control.Applicative
import           Data.Monoid
import qualified Data.Traversable    as T
import           Prelude             hiding (sum)
import           Unsafe.Coerce

---------------------------------------------------------
-- Some basic libraries

class Profunctor 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

class Profunctor 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)

instance Profunctor (->) where
  dimap f g h = g . h . f

instance Choice (->) where
  left'  f = either (Left . f) Right
  right' f = either Left (Right . f)

class Contravariant f where
  contramap :: (a' -> a) -> (f a -> f a')

-- Control.Applicative.Const replicated here for your
-- convenience
newtype K b a = K { getK :: b } deriving Functor

instance Monoid b => Applicative (K b) where
  pure _ = K mempty
  K e <*> K f = K (e <> f)

instance Contravariant (K b) where
  contramap f (K b) = K b

newtype Id a = Id { getId :: a } deriving Functor

instance Applicative Id where
  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.
type Optic p f s t a b =
  p a (f b) -> p s (f t)

type Iso s t a b =
  forall p f . (Profunctor p, Functor f) =>
  Optic p f s t a b

type Lens s t a b =
  forall f . Functor f =>
  Optic (->) f s t a b

type Traversal s t a b =
  forall f . Applicative f =>
  Optic (->) f s t a b

type Fold s a =
  forall f . (Contravariant f, Applicative f) =>
  Optic (->) f s s a a

type Prism s t a b =
  forall p f . (Choice p, Applicative f) =>
  Optic p f s t a b

那么先从最简单的_1,_2开始。它们的语义很简单，分别“聚焦”于一个pair的第一个元素和第二个元素。

1
2
3
4
5
6
7
-- | A lens focusing on the first element in a pair
_1 :: Lens (a, x) (b, x) a b
_1 = undefined

-- | A lens focusing on the second element in a pair
_2 :: Lens (x, a) (x, b) a b
_2 = undefined

类型签名可能有些吓人，不过我们展开之后可以发现，_1的类型为(a -> f b) -> ((a, x) -> f (b, x))，某种意义上相当于pair的fmap。
Follow the type，我们可以很容易地写出实现：

1
2
3
4
5
6
7
-- | A lens focusing on the first element in a pair
_1 :: Lens (a, x) (b, x) a b
_1 = \f (a,x) -> (, x) <$> f a

-- | A lens focusing on the second element in a pair
_2 :: Lens (x, a) (x, b) a b
_2 = \f (x,a) -> (x, ) <$> f a

update : 今天肝完了后半部分.. 然而完全不理解自己在做什么。于是放上看到的最优雅的实现，希望有朝一日我也能解释（

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
-- | 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)