lensmaker.hs

lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
lens get set next value = fmap (set value) . next . get $ value

-- | A lens focusing on the first element in a pair
_1 :: Lens (a, x) (b, x) a b
_1 = lens fst (\(_, b) a -> (a, b))

-- | A lens focusing on the second element in a pair
_2 :: Lens (x, a) (x, b) a b
_2 = lens snd (\(a, _) b -> (a, b))

-- | A function which takes a lens and looks through it.
-- The type given is specialized to provide a hint as to
-- how to write 'view'. The more intuitive type for its use
-- is
--
-- @
-- view :: Lens s t a b -> (s -> a)
-- @
view :: Optic (->) (K a) s t a b -> (s -> a)
view getter = getK . getter K

-- | A function which takes a lens and a transformation function
-- and applies that transformer at the focal point of the lens.
-- The type given is specialized to provide a hint as to how to
-- write 'over'. The more intuitive type for its use is
--
-- @
-- over :: Lens s t a b -> (a -> b) -> (s -> t)
-- @
over :: Optic (->) Id s t a b -> (a -> b) -> (s -> t)
over setter f = getId . setter (Id . f)

-- | A function from a lens and a value which sets the value
-- at the focal point of the lens. The type given has been
-- specialized to provide a hint as to how to write 'set'. The
-- more intuitive type for its use is
--
-- @
-- set :: Lens s t a b -> b -> (s -> t)
-- @
set :: Optic (->) Id s t a b -> b -> (s -> t)
set setter = over setter . const

-- | A traversal which focuses on each element in any
-- Traversable container.
elements :: Traversable f => Traversal (f a) (f b) a b
elements = traverse

-- | A function which takes a Traversal and pulls out each
-- element it focuses on in order. The type has been
-- specialized, as the others, but a more normal type might be
--
-- @
-- toListOf :: Traversal s s a a -> (s -> [a])
-- @
toListOf :: Optic (->) (K (Endo [a])) s s a a -> (s -> [a])
toListOf getter = flip appEndo [] . view (getter . to (\x -> (Endo ([x] <>))))

-- | A function which takes any kind of Optic which might
-- be focused on zero subparts and returns Just the first
-- subpart or else Nothing.
--
-- @
-- preview :: Traversal s s a a -> (s -> Maybe a)
-- @
preview :: Optic (->) (K (First a)) s s a a -> (s -> Maybe a)
preview getter = getFirst . view (getter . to (First . Just))

-- | A helper function which witnesses the fact that any
-- container which is both a Functor and a Contravariant
-- must actually be empty.
coerce :: (Contravariant f, Functor f) => f a -> f b
coerce = contramap (const ()) . fmap (const ())

-- | A Fold which views the result of a function application
to :: (a -> b) -> Fold a b
to f next value = contramap f $ next (f value)

prism :: (s -> Either t a) -> (b -> t) -> Prism s t a b
prism unwrap wrap = rmap (\case Left t -> pure t; Right x -> fmap wrap x) . lmap unwrap . right'

-- | A prism which focuses on the left branch of an Either
_Left :: Prism (Either a x) (Either b x) a b
_Left = prism (\case Left x -> Right x; Right x -> Left (Right x)) Left

-- | A prism which focuses on the right branch of an Either
_Right :: Prism (Either x a) (Either x b) a b
_Right = prism (\case Right x -> Right x; Left x -> Left (Left x)) Right

-- | An iso which witnesses that tuples can be flipped without
-- losing any information
_flip :: Iso (a, b) (a, b) (b, a) (b, a)
_flip = lmap swap . rmap (fmap swap)
  where
    swap (a, b) = (b, a)