Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
let
nixpkgs = import ./nixpkgs.nix;
in
nixpkgs.haskellPackages.callCabal2nix "lenses-and-functional-references" ./. {}
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
{-# 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'
let
nixpkgs-source = builtins.fetchTarball {
url = https://releases.nixos.org/nixos/19.03/nixos-19.03beta171931.3a4ffdd38b5/nixexprs.tar.xz;
};
in
import nixpkgs-source {}
let
nixpkgs = import ./nixpkgs.nix;
package = import ./.;
tools = [nixpkgs.haskellPackages.doctest];
in
(nixpkgs.haskell.lib.addBuildDepends package tools).env
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.