Fp15SimpleLens.hs

{-# LANGUAGE Rank2Types #-}
module Fp15SimpleLens where

{-
Линза - инструмент для манипулирования элементом типа a некоторой структуры данных типа s,
находящимся в фокусе этой линзы.
Технически линза - это АТД составленный из пары геттер-сеттер
lens :: (s -> a) -> (s -> a -> s) -> Lens s a

Законы:

1) view l (set l v s)  = v

2) set l (view l s) s  = s

3) set l v' (set l v s) = set l v' s

Наивный подход:
-}
data LensNaive s a = MkLens (s -> a) (s -> a -> s)

_1Naive :: LensNaive (a,b) a 
_1Naive = MkLens (\(x,_) -> x) (\(_,y) v -> (v,y)) 

viewNaive :: LensNaive s a -> s -> a
viewNaive (MkLens get _) s = get s

{-
GHCi> viewNaive _1Naive (5,7)
5

Это работает, но 
(1) неэффективно (конструктор данных MkLens дает дополнительный барьер
во время исполнения);
(2) имеет проблемы с расширением и обобщением (например, хотелось бы, чтобы
 композиция линз была линзой).
 
мы пишем сеттер и геттер вручную, но для записей с метками полей 
туда вкладываются непосредственно эти метки (в случае сеттера в синтаксисе обновления).
-}

----------------------------------------------
{-  
van Laarhoven lenses (Functor transformer lenses)
Линзы ван Ларховена 

Линза --- это функция, которая превращает вложение a в функтор f 
во вложение s в этот функтор.
-}
type Lens s a =
  forall f. Functor f =>
  (a -> f a) -> s -> f s

{-
NB Композиция в обратном порядке происходит отсюда!!!

l1 :: Lens t s -- (s -> f s) -> t -> f t
l2 :: Lens s a -- (a -> f a) -> s -> f s
l1 . l2 :: Lens t a


Как упаковать в такую конструкцию геттер и сеттер?
-}
  
--      (s -> a) -> (s -> a -> s) -> (a -> f a) -> s -> f s
lens :: (s -> a) -> (s -> a -> s) -> Lens s a
lens get set = \ret s -> fmap (set s) (ret $ get s)
{-
get s :: a
ret $ get s :: f a
set s :: a -> s
-}


-- Пример для пар: s == (a,b)

--    (a -> f a) -> (a,b) -> f (a,b)
_1 :: Lens (a,b) a
_1 = lens (\(x,_) -> x)        -- get
          (\(_,y) v -> (v,y))  -- set

--    (b -> f b) -> (a,b) -> f (a,b)
_2 :: Lens (a,b) b 
-- _2 = lens (\(_,y) -> y) (\(x,_) v -> (x,v))
-- _2 = \ret (x,y) -> fmap ((\(x,_) v -> (x,v)) (x,y)) (ret $ (\(_,y) -> y) (x,y))
-- _2 = \ret (x,y) -> fmap (\v -> (x,v)) (ret $ y)
_2 ret (x,y) = fmap ((,) x) (ret y)




{-
Как вынуть из линзы геттер и сеттер?
Использовать вместо f подходящий функтор!
-}

-- Геттер (x - фантомный параметр тпа)
newtype Const a x = Const {getConst :: a}
{-
Const    :: a -> Const a x
getConst :: Const a x -> a
-}

instance Functor (Const a) where
-- fmap :: (x -> y) -> Const a x -> Const a y
  fmap _ (Const v) = Const v
-- игнорирует функцию!
  
--      ((a -> Const a a) -> s -> Const a s) -> s -> a
view :: Lens s a                             -> s -> a
view lns s = getConst (lns Const s)
-- lns Const :: s -> Const a s
-- lns Const s :: Const a s
-- getConst :: Const a s -> a

{-
GHCi> view _1 (5,7)
5
GHCi> view _2 (5,7)
7
GHCi> view (_2 . _1) (5,(6,7))
6
-}

{-
view _2 (5,7) ~> 
getConst $ _2 Const (5,7) ~> 
getConst $ (\f (x,y) -> fmap ((,) x) (f y)) Const (5,7) ~> 
getConst $ fmap ((,) 5) (Const 7)) ~> 
getConst (Const 7) ~> 7

-}


-- Сеттер
newtype Identity a = Identity {runIdentity :: a}
{-
Identity :: a -> Identity a
runIdentity :: Identity a -> a
-}

instance Functor Identity where
  fmap f (Identity x) = Identity (f x)

--      ((a -> Identity a) -> s -> Identity s) -> (a -> a) -> s -> s
over :: Lens s a                               -> (a -> a) -> s -> s
over lns fn s = runIdentity $ lns (Identity . fn) s

{-
GHCi> over _1 (+5) (5,7)
(10,7)
GHCi> over _2 (+5) (5,7)
(5,12)
GHCi> over (_2 . _1) (+5) ("abc",(6,True))
("abc",(11,True))
-}

{-
over _2 (+5) (5,7) ~>
runIdentity $ _2 (Identity . (+5)) (5,7) ~>
runIdentity $ (\f (x,y) -> fmap ((,) x) (f y)) (Identity . (+5)) (5,7) ~>
runIdentity $ fmap ((,) 5) ((Identity . (+5)) 7) ~>
runIdentity $ fmap ((,) 5) ((Identity 12) ~>
runIdentity $  ((Identity (5,12)) ~>
(5,12)
-}



--     ((a -> Identity a) -> s -> Identity s) -> a -> s -> s
set :: Lens s a                               -> a -> s -> s

set lns a s = over lns (const a) s
--set lns a s = runIdentity $ lns (Identity . const a) s 

{-
GHCi> set _2 42 (5,7)
(5,42)
GHCi> set (_2 . _1) 33 ("abc",(6,True))
("abc",(33,True))
-}