Optics via fused-effects

Optics.hs

{-# LANGUAGE RankNTypes #-}
module Optics where

import           Control.Category ((>>>))
import qualified Control.Category as Cat
import           Control.Effect.Empty
import           Control.Effect.NonDet hiding (empty)
import           Control.Monad ((<=<))

-- riffing off of @serras’s post https://gist.github.com/serras/5152ec18ec5223b676cc67cac0e99b70

-- we use fused-effects to describe varieties of optic & their relationships to one another via effect constraints

data Optic m s a = Optic { get :: s -> m a, set :: (a -> a) -> (s -> s) }

instance Monad m => Cat.Category (Optic m) where
  id = Optic pure id
  Optic get1 set1 . Optic get2 set2 = Optic (get1 <=< get2) (set2 . set1)


type Lens s a = forall m . Applicative m => Optic m s a

lens :: (s -> a) -> (s -> a -> s) -> Lens s a
lens from to = Optic (pure . from) (\ aa s -> to s (aa (from s)))

_1 :: Lens (a, b) a
_1 = lens fst (\ ~(_, b) a -> (a, b))

_2 :: Lens (a, b) b
_2 = lens snd (\ ~(a, _) b -> (a, b))


type Prism s a = forall sig m . Has Empty sig m => Optic m s a

prism :: (a -> s) -> (s -> Maybe a) -> Prism s a
-- it feels weird that set is partial; it feels weird that it even receives an s to begin with!
-- but, it appears to work?
prism to from = Optic (maybe empty pure . from) (\ aa s -> maybe s (to . aa) (from s))

_Left :: Prism (Either a b) a
_Left = prism Left (\case{ Left a -> pure a ; _ -> empty })

_Right :: Prism (Either a b) b
_Right = prism Right (\case{ Right a -> pure a ; _ -> empty })


type Traversal s a = forall sig m . Has NonDet sig m => Optic m s a -- is this right? who knows!
-- whether or not it’s exactly what we mean, it’s cool that composing a Traversal and a Prism gets you a Traversal


-- it’s a little weird that composing a lens and a prism gets you … a prism? this seems to be a consequence of the setter receiving the whole and projecting the partial value out of it before updating
x :: Prism (Either c b, a) c
x = _1 >>> _Left


y, z :: (Either Char (), Int)
y = (Left 'y', 0)
z = (Right (), 1)


test1 :: Maybe Char
test1 = y & get x
-- Just 'y'

test2 :: Maybe Char
test2 = z & get x
-- Nothing

test3 :: (Either Char (), Int)
test3 = y & set (x :: Optic Maybe (Either c b, a) c) (const '3') -- have to annotate the type here or the signature is ambiguous, because set doesn’t use m
-- ( Left '3'
-- , 0
-- )

test4 :: (Either Char (), Int)
test4 = z & set (x :: Optic Maybe (Either c b, a) c) (const '4') -- have to annotate the type here or the signature is ambiguous, because set doesn’t use m
-- ( Right ()
-- , 1
-- )