Instantly share code, notes, and snippets.

@jyrimatti /oip.hs
Last active Oct 6, 2016

Embed
What would you like to do?
Optics in Programming (https://lahteenmaki.net/dev_*16/) - code. Executable file. Or paste to Haskell-for-Mac.
#! /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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment