Optics in Programming (https://lahteenmaki.net/dev_*16/) - code. Executable file. Or paste to Haskell-for-Mac.

oip.hs

#! /usr/bin/env nix-shell
#! nix-shell -i bash -p "haskellPackages.ghcWithPackages(p: with p; [profunctors mtl lens])"
ghci <<---EOF
:set +m
:set -XRank2Types
:set -XScopedTypeVariables

{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}
import Data.Tuple (swap)
import Data.Monoid (First(..), getFirst, (<>))
import Data.Traversable (traverse)
import Data.Time.Clock.POSIX (getPOSIXTime)
import qualified Data.Char as Char
import qualified Data.Profunctor as P
import qualified Data.Tagged as T
import Control.Monad.Identity
import Control.Applicative (Const(..), getConst, (<**>))
import Control.Category ((>>>))
import qualified Control.Lens as L
import Numeric.Natural

-- Lens as a pair of getter and setter:
data MyLens s a = MyLens {
    getter :: s -> a
  , setter :: a -> s -> s
  }

let get :: MyLens s a -> s -> a
    get = getter

let set :: MyLens s a -> a -> s -> s
    set = setter
    
let modify :: MyLens s a -> (a -> a) -> s -> s
    modify l f s = (setter l) (f $ getter l s) s

data Employee = Employee { _salary :: Int } deriving Show

let salary = MyLens _salary (\a s -> s { _salary = a } )

get salary (Employee 42)
-- > 42
set salary 42 (Employee 1)
-- > Employee { _salary = 42 }
modify salary (+1) (Employee 41)
-- > Employee { _salary = 42 }

-- That's it!
-- But the huge win with lenses is composition.

-- Define our own composition operator:
let (@.) :: MyLens a b -> MyLens b c -> MyLens a c
    (@.) l@(MyLens g1 s1) r@(MyLens g2 s2) = MyLens (g2 . g1) (\c a -> modify l (\b -> set r c b) a)
    
data Department = Department { _manager :: Employee } deriving Show
let manager = MyLens _manager (\a s -> s { _manager = a } )

get (manager @. salary) (Department (Employee 42))
-- > 42




-- Setting needs to do a silly getting. Let's replace the setter with a modifier:
data MyLens_modifier s a = MyLens_modifier {
    getter :: s -> a
  , modifier :: (a -> a) -> s -> s
  }

-- Now 'modify' == modifier, and 'set' is easy to implement:
let modify :: MyLens_modifier s a -> (a -> a) -> s -> s
    modify = modifier
    set :: MyLens_modifier s a -> a -> s -> s
    set l a = modifier l (const a)


-- We can even get rid of the getter.
-- return old value alongside new structure:
type MyLens_noGetter s a = (a -> a) -> s -> (a, s)

let get :: MyLens_noGetter s a -> s -> a
    get l s = fst $ l id s
    modify :: MyLens_noGetter s a -> (a -> a) -> s -> s
    modify l f s = snd $ l f s
    set :: MyLens_noGetter s a -> a -> s -> s
    set l a s = snd $ l (const a) s

let salary :: MyLens_noGetter Employee Int = \f s -> let a = _salary s in (a, s { _salary = f a })

get salary (Employee 42)
-- > 42
set salary 42 (Employee 1)
-- > Employee { _salary = 42 }
modify salary (+1) (Employee 41)
-- > Employee { _salary = 42 }


-- An interesting way to define a lens:
type MyLens_destructuring s a = s -> (a, a -> s)

let get :: MyLens_destructuring s a -> s -> a
    get l s = fst $ l s
    modify :: MyLens_destructuring s a -> (a -> a) -> s -> s
    modify l f s = let aas = l s in snd aas $ f (fst aas)
    set :: MyLens_destructuring s a -> a -> s -> s
    set l a s = (snd $ l s) a

let salary :: MyLens_destructuring Employee Int = \s -> (_salary s, \a -> s { _salary = a })

get salary (Employee 42)
-- > 42
set salary 42 (Employee 1)
-- > Employee { _salary = 42 }
modify salary (+1) (Employee 41)
-- > Employee { _salary = 42 }

-- it still works, and now the intuition is "something that breaks a Structure to a Value and a new Structure without a Value".






-- Make illegal states unrepresentable:

-- Think about: (s -> t) and (a -> b), and s == "source" and t == "target"
data MyLens_typeChanging s t a b = MyLens_typeChanging {
    getter :: s -> a
  , modifier :: (a -> b) -> s -> t
  }
  
type MyLens_noGetter s a = MyLens_typeChanging s s a a

let get = getter; modify = modifier; set l a = modifier l (const a)
    
data EmployeeWithoutSalary = EmployeeWithoutSalary { _salaryProposal :: Int } deriving Show
data InvalidDepartment = InvalidDepartment { _imanager :: EmployeeWithoutSalary } deriving Show

-- We know how to make department valid, given a function (f) that can make its manager valid:
let makeDepartmentValid f s@(InvalidDepartment m) = Department { _manager = f m }

-- So we can make a manager Lens which turns an invalid department to a valid one:
let manager :: MyLens_typeChanging InvalidDepartment Department EmployeeWithoutSalary Employee
    manager = MyLens_typeChanging _imanager makeDepartmentValid

    someInvalidDepartment = InvalidDepartment $ EmployeeWithoutSalary 42

modify manager (Employee . _salaryProposal) someInvalidDepartment
-- > Department { _manager = Employee { _salary = 42 } }





-- Moving beyond:


-- Regular functions are boring. What if we change to "monadic" functions, i.e. functions returning a wrapped value?
data MyLens_functor s t a b = MyLens_functor {
    getter :: s -> a
  , modifier :: forall f. Functor f => (a -> f b) -> (s -> f t)
  }
  
let modify :: Functor f => MyLens_functor s t a b -> (a -> f b) -> (s -> f t)
    modify = modifier
    
    salary = MyLens_functor _salary (\f s -> fmap (\a -> s { _salary = a }) (f $ _salary s) )
    
    updateSalary = (+1)

-- Needs a functor, so let's use Identity
runIdentity $ modify salary (Identity . updateSalary) (Employee 41)
-- > Employee { _salary = 42 }
-- This looks like the previous modification!
-- In Control.Lens, 'over' does exactly this wrapping and unwrapping Identity.

getConst $ modify salary (Const . updateSalary) (Employee 41)
-- > 42
-- This looks like the regular get!
-- In Control.Lens, 'view' does exactly this wrapping and unwrapping Const.

let debugging f oldValue = do
    putStrLn $ "Old value: " ++ show oldValue
    started <- getPOSIXTime
    let newVal = f oldValue
    finished <- getPOSIXTime
    putStrLn $ "New value: " ++ show newVal ++ ". Execution took " ++ show (finished-started) ++ " ms"
    return newVal

-- Let's use a bit more interesting functor, like... I don't know... IO?
modify salary (debugging updateSalary) $ Employee 41
-- > IO (Employee { _salary = 42 })
-- and outputs a debugging string when executed!

-- Who says purity prevents us from doing stuff ;)





-- Lens "zooms in" to a single value inside a structure.

-- What if we want to "zoom in" to multiple values?

-- Use Applicative instead of a Functor

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

-- Traversal can read and update multiple fields.





-- What if we want to "zoom in" to a part that may not be there?

type MyPrism s a = forall p f. (L.Choice p, Applicative f) => p a (f a) -> p s (f s)

let myPrism :: (a -> s) -> (s -> Maybe a) -> MyPrism s a
    myPrism as sma = P.dimap (\s -> maybe (Left s) Right (sma s)) (either pure (fmap as)) . L.right'
    
    review r = runIdentity . T.unTagged . r . T.Tagged . Identity
    preview l = getFirst . L.foldMapOf l (First . Just)

-- conditional constructor to create a department with a suitable manager
let newDepartment emp | _salary emp > 5000 = Just $ Department emp
    newDepartment _                        = Nothing
    
    -- prism breaking down the construction of a Department to
    -- the "missing" value and the function taking the missing value
let department :: MyPrism Employee Department
    department = myPrism _manager newDepartment

review department $ Department (Employee 42)
-- > Employee {_salary = 42}
preview department $ Employee 42
-- > Nothing
preview department $ Employee 5042
-- > Just (Department {_manager = Employee {_salary = 5042})

-- So, we can test if the function accepts the given argument.
-- I guess all this would be utterly useless if it didn't compose:

-- Only allow an Employee with a positive salary
let newEmployee sal = if sal > 0 then Just $ Employee sal else Nothing
    employee = myPrism _salary newEmployee

L.has employee $ 42
-- > True
L.has employee $ -42
-- > False
review employee $ Employee 42
-- > 42
preview employee $ -42
-- > Nothing
preview employee $ 42
-- > Just (Employee {_salary = 42})

-- prism for a valid department, that is, a department with an employee (manager) with salary >= 5000
let validDepartment = employee . department

L.has validDepartment $ 42
-- > False
L.has validDepartment $ 5042
-- > True
preview validDepartment $ 42
-- > Nothing
preview validDepartment $ 5042
-- > Just (Department {_manager = Employee {_salary = 5042})

-- With prisms we can build structures with "validation in constructors" functionally.







-- What if we are zoomed in to a part inside a huge structure, and want to observe the neighborhood? Zooming in again and again not acceptable performancewise.

-- a Zipper can move inside a structure.
-- e.g. forwards and backwards in a list, or up and down a binary tree.

-- Maybe some other year about zippers...





-- In (category) theory?

-- Let's define an 'Optic' as something that goest from 's' to 't' and from 'a' to 'b'.
-- Or something that "zooms in" to an 'a' inside an 's' and can transform them to 'b' and 't' respectively:
type Optic p s t a b = p a b -> p s t
-- 'p' is something that can wrap this whole mess.

-- Isomorphism is something that can go "there and back again".
-- A transformation that preserves information.

-- Remember Profunctor from here https://lahteenmaki.net/dev_*15/#/?
-- A Bifunctor where the first argument is contravariant ("input") and the second is covariant ("output"):
class Profunctor p where
  dimap :: (a -> b) -> (c -> d) -> p b c -> p a d

-- We get an isomorphism as an Optic with a profunctor wrapper:
type Iso s t a b = forall p. Profunctor p => Optic p s t a b

-- create an isomorphism
let iso :: (s -> a) -> (b -> t) -> Iso s t a b
    iso = dimap

let charAsInt :: Iso Int Int Char Char
    charAsInt = iso toEnum fromEnum

let charOptic :: Profunctor p => Optic p Int Int Char Char
    charOptic = charAsInt
    


-- If we "Forget" the output transformation 'g'...
newtype Forget r a b = Forget { runForget :: a -> r }
instance Profunctor (Forget r) where
  dimap f _ (Forget k) = Forget (k . f)

-- ...we get a view to what an optic is "zoomed in to"
let view :: Optic (Forget a) s t a b -> s -> a
    view o = runForget $ o $ Forget id
    
view charOptic 120
-- > 'x'



-- If we "Tag in" a final value 'b'...
newtype Tagged s b = Tagged { unTagged :: b }
instance Profunctor Tagged where
  dimap _ g (Tagged b) = Tagged (g b)
  

-- ...we get back "its source"
let review :: Optic Tagged s t a b -> b -> t
    review o = unTagged . o . Tagged
    
review charOptic 'x'
-- > 120



-- With Forget and Tagged, an isomorphism can be inverted:
let from :: Iso s t a b -> Iso b a t s
    from i = iso (review i) (view i)
 
view charOptic 120
-- > 'x'
view (from charOptic) 'x'
-- > 120



-- If we use regular function for the Optic, we get modifier and setter:
instance Profunctor (->) where
  dimap ab cd bc = cd . bc . ab
  
let over :: Optic (->) s t a b -> (a -> b) -> (s -> t)
    over = id
    
let set :: Optic (->) s t a b -> b -> s -> t
    set o = over o . const

over charOptic (Char.toUpper) 120
-- > 88 (== 'X')

set charOptic 'X' 120
-- > 88



-- If we use Strength to "Pass through values" we get Lens:
class Profunctor p => Strong p where
  first' :: p a b  -> p (a, c) (b, c)
  first' = dimap swap swap . second'
  second' :: p a b -> p (c, a) (c, b)
  second' = dimap swap swap . first'

instance Strong (->) where
  first' ab ~(a, c) = (ab a, c)
instance Strong (Forget r) where
  first' (Forget k) = Forget (k . fst)
  
type Lens s t a b = forall p. Strong p => Optic p s t a b

let (***) :: (b -> c) -> (b' -> c') -> (b,b') -> (c,c')
    (***) f g = first' f >>> swap >>> first' g >>> swap
    (&&&) :: (b -> c) -> (b -> c') -> b -> (c,c')
    (&&&) f g = (\b -> (b,b)) >>> f *** g
    lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
    lens f g = dimap (f &&& id) (uncurry $ flip g) . first'
 
let charLens :: Lens Int Int Char Char
    charLens = lens toEnum (\s b -> fromEnum b)
    
let salary :: Lens Employee Employee Int Int
    salary = lens _salary (\s b -> s { _salary = b })

view charLens 120
-- > 'x'

set charLens 'x' 42
-- > 120
   
over charLens (Char.toUpper) 120
-- > 88 (== 'X')



-- Lens composition:
let toUpperLens = lens Char.toUpper $ \s -> Char.toLower

view (charLens . toUpperLens) 120
-- > 'X'



-- By using Choice as the wrapper...
class Profunctor p => Choice p where
  left' :: p a b -> p (Either a c) (Either b c)
  left' =  dimap (either Right Left) (either Right Left) . right'
  right' :: p a b -> p (Either c a) (Either c b)
  right' =  dimap (either Right Left) (either Right Left) . left'

instance Choice Tagged where
  left' (Tagged b) = Tagged (Left b)

instance Monoid r => Choice (Forget r) where
  left' (Forget k) = Forget (either k (const mempty))

-- ... we get Prism:
type Prism s t a b = forall p. Choice p => Optic p s t a b
                
let prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
    prism f g = dimap g (either id f) . right'
    
let preview :: Prism s t a b -> s -> (Maybe a)
    preview l = getFirst . (runForget . l . Forget $ First . pure)

let charPrism :: Prism Int Int Char Char
    charPrism = prism fromEnum (\s -> if s > 0 then Right (toEnum s) else Left s)

review charPrism 'x'
-- > 120

preview charPrism 120
-- > Just 'x'

preview charPrism (-120)
-- > Nothing




-- Traversals

instance Choice (->) where
  left' ab (Left a) = Left (ab a)
  left' _ (Right c) = Right c

class (Strong p, Choice p) => Wander p where
  wander :: (forall f. Applicative f => (a -> f b) -> s -> f t) -> p a b -> p s t

instance Wander (->) where
  wander t f = runIdentity . t (Identity . f)

type Traversal s t a b = forall p. Wander p => Optic p s t a b

let traversed :: forall t a b. (Traversable t) => Traversal (t a) (t b) a b
    traversed = wander traverse




-- If instead of a regular function we use a monadic function
-- that is, a function of the form "a -> m b" wrapped inside a data type (Kleisli),
-- we get IO etc.

data Kleisli m a b = Kleisli { runKleisli :: a -> m b }

instance Functor f => Profunctor (Kleisli f) where
  dimap f g (Kleisli h) = Kleisli (fmap g . h . f)

instance Applicative f => Choice (Kleisli f) where
  right' (Kleisli f) = Kleisli foo
        where foo (Left c) = pure $ Left c
              foo (Right a) = sequenceA $ Right (f a)

instance Functor f => Strong (Kleisli f) where
  second' (Kleisli h) = Kleisli $ \(x,y) -> (,) x <$> (h y)

let modifyM :: Optic (Kleisli f) s t a b -> (a -> f b) -> s -> f t
    modifyM l = runKleisli . l . Kleisli
    
modifyM charLens (\c -> do putStrLn "You see me!"; return $ Char.toUpper c) 120
-- > IO 88
-- and outputs "You see me!" when executed!




-- Similarly, we can wrap a comonadic function to a CoKleisli type to
-- be able to use comonadic (w a > b) instead of monadic functions:

data CoKleisli w a b = CoKleisli { runCoKleisli :: w a -> b }

instance Functor f => Profunctor (CoKleisli f) where
  dimap f g (CoKleisli h) = CoKleisli (g . h . fmap f)
  
let modifyW :: Optic (CoKleisli f) s t a b -> (f a -> b) -> f s -> t
    modifyW l = runCoKleisli . l . CoKleisli

data MyEnv v = MyEnv Int v
instance Functor MyEnv where
  fmap f (MyEnv e v) = MyEnv e $ f v
  
let getEnv (MyEnv e v) = e
    getValue (MyEnv e v) = v

let someComonadicFunction :: MyEnv Char -> Char
    someComonadicFunction env = Char.toUpper $ toEnum $ fromEnum (getValue env) + getEnv env
    
view charOptic $ modifyW charOptic someComonadicFunction (MyEnv 1 120)
-- > 'Y'




-- We can finally reference "things" inside complex hierarchies:

data Money      = Money      { _amount    :: Natural, _currency :: String } deriving Show
data Employee   = Employee   { _salary    :: Maybe Money }                  deriving Show
data Department = Department { _employees :: [Employee] }                   deriving Show

let employees :: Lens Department Department [Employee] [Employee]
    employees = lens _employees (\d es -> d { _employees = es })

let salary :: Lens Employee Employee (Maybe Money) (Maybe Money)
    salary = lens _salary (\e s -> e { _salary = s })
    
let amount :: Lens Money Money Natural Natural
    amount = lens _amount (\m a -> m { _amount = a })
    
let just :: Prism (Maybe a) (Maybe b) a b
    just = prism Just $ maybe (Left Nothing) Right

let someDepartment = Department [Employee (Just $ Money 42 "Euro")]

let nilled = set (employees.traversed.salary) Nothing someDepartment
-- > Department {_employees = [Employee {_salary = Nothing}]}

over (employees.traversed.salary.just.amount) (+1) nilled
-- > Department {_employees = [Employee {_salary = Nothing}]}

over (employees.traversed.salary.just.amount) (+1) someDepartment
-- > Department {_employees = [Employee {_salary = Just (Money {_amount = 43, _currency = "Euro"})}]}

--EOF