simple-lens.hs

-- ref: https://www.youtube.com/watch?v=k-QwBL9Dia0&ab_channel=SkillsMatter%28formerlyYOW%21Conferences%29

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}

import Data.Functor.Identity
import Data.Functor.Const

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

get :: Lens s t a b -> s -> a
get l s = getConst (l Const s)

set :: Lens s t a b -> s -> b -> t
set l s a = runIdentity $ l (const (Identity a)) s

modify :: Lens s t a b -> s -> (a -> b) -> t
modify l s f = runIdentity $ l (Identity . f) s

-- example lens
firstElem :: Lens (s1,s2)  (t1,s2) s1 t1
firstElem afb (a,b) = (,b) <$> afb a

-- >>> set firstElem ("hello", 1) "goodbye"
-- ("goodbye",1)

-- >>> set firstElem ("hello", 1) 1
-- (1,1)

-- >>> get firstElem ("hello", 1)
-- "hello"

-- >>> modify firstElem ("hello", 1) (++" world")
-- ("hello world",1)

-- composition
secondElem :: Lens (s1,s2)  (s1,t2) s2 t2
secondElem afb (b,a) = (b,) <$> afb a

--firstThenSecond :: Lens' ((a,b),c) b
firstThenSecond :: Lens ((s1,s2),s3) ((s1,t2),s3) s2 t2
firstThenSecond = firstElem . secondElem

-- >>> get firstThenSecond ((1,2),3)
-- 2
-- >>> set firstThenSecond ((1,2),3) "hello"
-- ((1,"hello"),3)

data NaiveLens s t a b = NaiveLens { _get :: s -> a, _set :: s -> b -> t }
type NaiveLens' s a = NaiveLens s s a a

-- NaiveLens and Lens are isomorphic. Proof below.

lensToNaive :: Lens s t a b -> NaiveLens s t a b
lensToNaive l = NaiveLens { _get = get l, _set = set l }

naiveToLens :: NaiveLens s t a b -> Lens s t a b
naiveToLens (NaiveLens getter setter) afb s =
    let
        a = getter s
        fb = afb a
        as = setter s
    in
        fmap as fb

-- naive example lens
firstElemNaive :: NaiveLens (s1,s2)  (t1,s2) s1 t1
firstElemNaive = NaiveLens fst (\(_,b) a' -> (a',b))

firstElem' :: Lens (s1,s2) (t1,s2) s1 t1
firstElem' = naiveToLens firstElemNaive

-- >>> set firstElem' ("hello", 1) "goodbye"
-- ("goodbye",1)

-- >>> get firstElem' ("hello", 1)
-- "hello"

-- >>> modify firstElem' ("hello", 1) (++" world")
-- ("hello world",1)