Lenses and functional references notes: https://en.wikibooks.org/wiki/Haskell/Lenses_and_functional_references

default.nix

let
  nixpkgs = import ./nixpkgs.nix;
in
  nixpkgs.haskellPackages.callCabal2nix "lenses-and-functional-references" ./. {}

lenses-and-functional-references.cabal

name: lenses-and-functional-references
version: 0.1.0.0
license: BSD3
author: Brad Parker
maintainer: hi@bradparker.com
build-type: Simple
cabal-version: >=1.10

library
  exposed-modules: LensesAndFunctionalReferences
  build-depends: base >=4.12 && <4.13, profunctors >=5.3 && <5.4
  default-language: Haskell2010

LensesAndFunctionalReferences.hs

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

module LensesAndFunctionalReferences where

import Data.Char (chr, ord, toUpper)
import Data.Functor.Const (Const(Const, getConst))
import Data.Functor.Contravariant (Contravariant(contramap))
import Data.Functor.Identity (Identity(Identity, runIdentity))
import Data.Monoid (All(All, getAll), First(First, getFirst), Sum(Sum, getSum))
import Data.Profunctor (Profunctor(dimap))

data Point = Point
  { _positionX :: Double
  , _positionY :: Double
  } deriving (Show)

data Segment = Segment
  { _segmentStart :: Point
  , _segmentEnd :: Point
  } deriving (Show)

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

pointCoordinates :: Traversal Point Point Double Double
pointCoordinates g (Point x y) = Point <$> g x <*> g y

extremityCoordinates :: Traversal Segment Segment Double Double
extremityCoordinates g (Segment start end) =
  Segment <$> pointCoordinates g start <*> pointCoordinates g end

type Setter s t a b =
  (a -> Identity b) -> s -> Identity t

over :: Setter s t a b -> (a -> b) -> s -> t
over setter f = runIdentity . setter (Identity . f)

-- | Over examples
--
-- >>> over pointCoordinates negate (Point 1 2)
-- Point {_positionX = -1.0, _positionY = -2.0}

mapped :: Functor f => Setter (f a) (f b) a b
mapped f = Identity . fmap (runIdentity . f)

-- | Mapped examples
--
-- >>> over mapped negate [1, 2, 3]
-- [-1,-2,-3]
-- >>> over mapped negate (Just 3)
-- Just (-3)

set :: Setter s t a b -> b -> s -> t
set setter = over setter . const

scaleSegment :: Double -> Segment -> Segment
scaleSegment x = over extremityCoordinates (* x)

type Fold' s a =
  forall r. Monoid r => (a -> Const r a) -> s -> Const r s

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

toListOf :: Fold s a -> s -> [a]
toListOf fold = getConst . fold (\a -> Const [a])

-- | Fold examples
--
-- >>> toListOf extremityCoordinates (Segment (Point 0 1) (Point 2 3))
-- [0.0,1.0,2.0,3.0]

preview :: Fold s a -> s -> Maybe a
preview fold = getFirst . getConst . fold (Const . First . Just)

-- | Preview examples
--
-- >>> preview traverse [1..10]
-- Just 1

type Getter s a =
  forall f. (Contravariant f, Functor f) => (a -> f a) -> s -> f s

-- A more general type which allows `view` to be used with both
-- `Getter`s and `Traversal`s (as long as `b` is a Monoid) or `Fold`s
type Getting r s a = (a -> Const r a) -> s -> Const r s

view :: Getting a s a -> s -> a
view getting = getConst . getting Const

to :: (s -> a) -> Getter s a
to s2a a2fa s = contramap s2a (a2fa (s2a s))
-- `contramap s2a` turns the result into an `f s` ... the `s` is phantom

-- | View and to examples
--
-- >>> view (to fst) (1, True)
-- 1
-- >>> view (to snd) (1, True)
-- True
-- >>> view traverse (fmap Sum [1..10])
-- Sum {getSum = 55}

both :: Traversal (a,a) (b,b) a b
both f (a,a') = (,) <$> f a <*> f a'

-- | More view examples
--
-- >>> view both ([1, 2], [3, 4, 5])
-- [1,2,3,4,5]

hasn't :: Getting All s a -> s -> Bool
hasn't getting = getAll . getConst . getting (const (Const (All False)))

-- | Hasn't examples
--
-- >>> hasn't traverse [1..4]
-- False
-- >>> hasn't traverse Nothing
-- True

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

_1 :: Lens (a, c) (b, c) a b
_1 a2fb (a, c) = (, c) <$> a2fb a

-- | _1 examples
--
-- >>> _1 (\x -> [0..x]) (4, 1) -- Traversal
-- [(0,1),(1,1),(2,1),(3,1),(4,1)]
-- >>> set _1 7 (4, 1) -- Setter
-- (7,1)
-- >>> over _1 length ("orange", 1) -- Setter, changing the types
-- (6,1)
-- >>> toListOf _1 (4, 1) -- Fold
-- [4]
-- >>> view _1 (4, 1) -- Getter
-- 4

positionX :: Lens Point Point Double Double
positionX x2fx (Point x y) = (`Point` y) <$> x2fx x

positionY :: Lens Point Point Double Double
positionY y2fy (Point x y) = Point x <$> y2fy y

segmentStart :: Lens Segment Segment Point Point
segmentStart p2fp (Segment start end) = (`Segment` end) <$> p2fp start

segmentEnd :: Lens Segment Segment Point Point
segmentEnd p2fp (Segment start end) = Segment start <$> p2fp end

-- | Segment and point lens examples
--
-- >>> view (segmentEnd . positionY) (Segment (Point 0 1) (Point 2 4))
-- 4.0

-- Here this is the same as `Lens`, because I've
-- specialized Profunctor p to (->)
--
-- type Iso s t a b =
--   forall f. Functor f => (a  -> f b) -> s -> f t
--
-- The profunctor constraint allows `lens` to reverse
-- `Iso`s. When wanting to reverse, an `Iso` can be passed to
-- `from` at which point the `Profunctor p` is specialized to
-- `Exchange`, which is a pair of the two functions. When
-- passed to other combinators it's specialized to `(->)` so
-- it can be run.
--
-- If I wanted make this work like lens we would need this
-- type:

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

-- So this is speciaized to (->)
--
-- iso :: (s -> a) -> (b -> t) -> Iso s t a b
-- iso get set a2fb s = set <$> a2fb (get s)

-- For all `Profunctor`s
iso :: (s -> a) -> (b -> t) -> Iso s t a b
iso get set = dimap get (fmap set)

-- | An iso example
--
-- >>> over (iso ord chr) (+ 7) 'a'
-- 'h'

-- To make this reversable we can introduce another Profunctor
-- `Exchange`

data Exchange a b s t = Exchange (s -> a) (b -> t)

instance Profunctor (Exchange a b) where
  dimap :: (s' -> s) -> (t -> t') -> Exchange a b s t -> Exchange a b s' t'
  dimap f g (Exchange get set) = Exchange (get . f) (g . set)

-- Now we can define `AnIso`

type AnIso s t a b =
  Exchange a b a (Identity b) -> Exchange a b s (Identity t)

-- Which is useful when writing `withIso`

withIso :: AnIso s t a b -> ((s -> a) -> (b -> t) -> r) -> r
withIso anIso f =
  case anIso (Exchange id Identity) of
    Exchange get set -> f get (runIdentity . set)

-- Which allows us to recover the two functions that where used
-- to construct the Iso ... pretty cool

-- Which can be used to reverse an Iso ... crazy

from :: AnIso s t a b -> Iso b a t s
from anIso = withIso anIso $ \get set ->
  iso set get

under :: AnIso s t a b -> (t -> s) -> b -> a
under = over . from

-- | Under on an Iso
--
-- >>> under (iso chr ord) (+ 7) 'a'
-- 'h'
-- >>> ord 'h'
-- 104
-- >>> over (iso chr ord) toUpper 104
-- 72
-- >>> chr 72
-- 'H'

nixpkgs.nix

let
  nixpkgs-source = builtins.fetchTarball {
    url = https://releases.nixos.org/nixos/19.03/nixos-19.03beta171931.3a4ffdd38b5/nixexprs.tar.xz;
  };
in
  import nixpkgs-source {}

shell.nix

let
  nixpkgs = import ./nixpkgs.nix;
  package = import ./.;
  tools = [nixpkgs.haskellPackages.doctest];
in
  (nixpkgs.haskell.lib.addBuildDepends package tools).env