Representing optics by the set of actions they support.

ActionSetOptics.hs

-- An alternative representation of optics.
--
-- I represent an optic as the set of actions it supports. Composition
-- intersects the sets, which is how e.g. composing a Lens with a Prism gives a
-- Traversal.

{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, GADTs, KindSignatures, MultiParamTypeClasses, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
{-# OPTIONS -Wno-name-shadowing #-}
module Main where
import Test.DocTest

import Control.Category ((>>>), (<<<))
import Control.Monad ((>=>))
import Data.Functor.Const
import Data.Functor.Identity
import Data.Maybe (listToMaybe)


-- An action is a function like 'view' or 'over' which uses an optic to examine
-- or manipulate a structure. I wrap some of those actions as newtypes
-- parameterized over the four s t a b type parameters. These newtypes will
-- allow me to talk about actions at the type level.

newtype View       s t a b = View       { runView       :: s -> a }
newtype ToListOf   s t a b = ToListOf   { runToListOf   :: s -> [a] }
newtype Review     s t a b = Review     { runReview     :: b -> t }
newtype Over       s t a b = Over       { runOver       :: (a -> b) -> (s -> t) }
newtype TraverseOf s t a b = TraverseOf { runTraverseOf :: forall f. Applicative f => (a -> f b) -> (s -> f t) }


-- We normally compose optics e.g. (_1 % _1), and then apply an action to that
-- composition, e.g.
--
-- >>> view (_1 % _1) (("foo", "bar"), "baz")
-- "foo"
--
-- but it turns out the actions themselves compose as well!
--
-- >>> :t composeActions (View fst) (View fst)
-- _ :: View ((a, x), y) ((b, x), y) a b

class ComposeActions action where
  composeActions
    :: action s t u v
    -> action u v a b
    -> action s t a b

instance ComposeActions View where
  composeActions (View f) (View g) = View (f >>> g)

instance ComposeActions ToListOf where
  composeActions (ToListOf f) (ToListOf g) = ToListOf (f >=> g)

instance ComposeActions Review where
  composeActions (Review f) (Review g) = Review (f <<< g)

instance ComposeActions Over where
  composeActions (Over f) (Over g) = Over (f . g)

instance ComposeActions TraverseOf where
  composeActions (TraverseOf f) (TraverseOf g) = TraverseOf (f . g)


-- The core idea of this post is that we can thus represent an optic as the set
-- of actions it supports. We can then compose optics by composing the actions,
-- and apply actions by pulling them from the set.

type Action = * -> * -> * -> * -> *

data Optic (actions :: [Action])
           (s :: *)
           (t :: *)
           (a :: *)
           (b :: *) where
  Nil  :: Optic '[] s t a b
  Cons :: action s t a b
       -> Optic actions s t a b
       -> Optic (action ': actions) s t a b
infixr 5 `Cons`

type Optic' actions s a = Optic actions s s a a


-- Like I said we can apply an action by pulling it from the set. This is where
-- the newtypes come in: since each action has a type-level name (the newtype),
-- we can look through the type-level list in order to find the action we want.

class Elem needle haystack where
  runOptic :: Optic haystack s t a b
           -> needle s t a b

instance Elem needle (needle ': haystack) where
  runOptic (Cons needle _) = needle

instance {-# OVERLAPPABLE #-}
         Elem needle haystack
      => Elem needle (hay ': haystack) where
  runOptic (Cons _ haystack) = runOptic haystack

view
  :: Elem View actions
  => Optic' actions s a
  -> s -> a
view = runView . runOptic

toListOf
  :: Elem ToListOf actions
  => Optic' actions s a
  -> s -> [a]
toListOf = runToListOf . runOptic

review
  :: Elem Review actions
  => Optic' actions s a
  -> a -> s
review = runReview . runOptic

over
  :: Elem Over actions
  => Optic actions s t a b
  -> (a -> b)
  -> (s -> t)
over = runOver . runOptic

traverseOf
  :: Elem TraverseOf actions
  => Optic actions s t a b
  -> forall f. Applicative f
  => (a -> f b)
  -> (s -> f t)
traverseOf = runTraverseOf . runOptic


-- Of course, we can also implement derived actions which are not themselves in
-- the set, but which can be implemented in terms of actions which are in the set.

preview
  :: Elem ToListOf actions
  => Optic' actions s a
  -> s -> Maybe a
preview optic = listToMaybe . toListOf optic

set
  :: Elem Over actions
  => Optic actions s t a b
  -> b -> s -> t
set optic = over optic . const


-- In this formalism, the traditional optics like Lens, Prism, etc. are simply
-- synonyms for the set of operations which those optics support.

type Fold   s a = Optic' '[      ToListOf                          ] s a
type Setter     = Optic  '[                        Over            ]
type Getter s a = Optic' '[View, ToListOf                          ] s a
type Traversal  = Optic  '[      ToListOf,         Over, TraverseOf]
type Lens       = Optic  '[View, ToListOf,         Over, TraverseOf]
type Prism      = Optic  '[      ToListOf, Review, Over, TraverseOf]
type Iso        = Optic  '[View, ToListOf, Review, Over, TraverseOf]

mkFold
  :: (s -> [a])
  -> Fold s a
mkFold f
      = ToListOf f
 `Cons` Nil

mkSetter
  :: ((a -> b) -> (s -> t))
  -> Setter s t a b
mkSetter f
      = Over f
 `Cons` Nil

mkGetter
  :: (s -> a)
  -> Getter s a
mkGetter f
      = View f
 `Cons` ToListOf (\s -> [f s])
 `Cons` Nil

mkTraversal
  :: (forall f. Applicative f => (a -> f b) -> (s -> f t))
  -> Traversal s t a b
mkTraversal f
      = ToListOf (getConst . f (\a -> Const [a]))
 `Cons` Over (\a2b -> runIdentity . f (\a -> Identity (a2b a)))
 `Cons` TraverseOf f
 `Cons` Nil

mkLens
  :: (s -> a)
  -> (b -> s -> t)
  -> Lens s t a b
mkLens get set
      = View get
 `Cons` ToListOf (\s -> [get s])
 `Cons` Over (\a2b s -> let a = get s
                            b = a2b a
                         in set b s)
 `Cons` TraverseOf (\a2fb s -> let a = get s
                               in set <$> a2fb a <*> pure s)
 `Cons` Nil

mkPrism
  :: (s -> Either t a)
  -> (b -> t)
  -> Prism s t a b
mkPrism match ctor
      = ToListOf (\s -> case match s of
                          Left _ -> []
                          Right a -> [a])
 `Cons` Review ctor
 `Cons` Over (\a2b s -> case match s of
                          Left t -> t
                          Right a -> ctor (a2b a))
 `Cons` TraverseOf (\a2fb s -> case match s of
                                 Left t -> pure t
                                 Right a -> ctor <$> a2fb a)
 `Cons` Nil

mkIso
  :: (s -> a)
  -> (b -> t)
  -> Iso s t a b
mkIso s2a b2t
      = View s2a
 `Cons` ToListOf (\s -> [s2a s])
 `Cons` Review b2t
 `Cons` Over (\a2b -> s2a >>> a2b >>> b2t)
 `Cons` TraverseOf (\a2fb -> s2a >>> a2fb >>> fmap b2t)
 `Cons` Nil


-- Composing two optics is a bit more involved. If the two optics being
-- composed contain the same set of actions, then we can simply compose the
-- actions pairwise. If they don't, we take the intersection: we compose the
-- actions they both support, and we drop the rest.
--
-- For example, composing a Lens with a Prism means taking the intersection of
-- [View, ToListOf, Over, TraverseOf] and [ToListOf, Review, Over, TraverseOf].
-- The result is [ToListOf, Over, TraverseOf], aka a Traversal.

-- These type families give the overall plan of how we are going to perform
-- this intersection:

type family Intersection actions1 actions2 :: [Action] where
  Intersection '[]                  _        = '[]
  Intersection (action ': actions1) actions2 = Intersection1 action actions2 actions1 actions2

type family Intersection1 needle haystack actions1 actions2 :: [Action] where
  Intersection1 _      '[]              actions1 actions2 = Intersection actions1 actions2
  Intersection1 needle (needle ': _)    actions1 actions2 = needle ': Intersection actions1 actions2
  Intersection1 needle (_' ': haystack) actions1 actions2 = Intersection1 needle haystack actions1 actions2

-- The rest looks complicated, but is merely filling-in the blanks, by defining
-- one typeclass per type family and one instance for each equation in the type
-- family.

class ComposeActionSets actions1 actions2 where
  (%) :: Optic actions1 s t u v
      -> Optic actions2 u v a b
      -> Optic (Intersection actions1 actions2) s t a b

instance ComposeActionSets '[] actions2 where
  Nil % _ = Nil

instance ComposeActionSets1 action actions2 actions1 actions2
      => ComposeActionSets (action ': actions1) actions2 where
  Cons action actions1 % actions2
    = composeActionSets1 action actions2 actions1 actions2

class ComposeActionSets1 needle haystack actions1 actions2 where
  composeActionSets1
    :: needle s t u v
    -> Optic haystack u v a b
    -> Optic actions1 s t u v
    -> Optic actions2 u v a b
    -> Optic (Intersection1 needle haystack actions1 actions2) s t a b

instance ( ComposeActions needle
         , ComposeActionSets actions1 actions2
         )
      => ComposeActionSets1 needle '[] actions1 actions2 where
  composeActionSets1 _ _ actions1 actions2
    = actions1 % actions2

instance ( ComposeActions needle
         , ComposeActionSets actions1 actions2
         )
      => ComposeActionSets1 needle (needle ': haystack) actions1 actions2 where
  composeActionSets1 needle1 (Cons needle2 _) actions1 actions2
    = Cons (composeActions needle1 needle2)
           (actions1 % actions2)

instance {-# OVERLAPPABLE #-}
         ( Intersection1 needle (hay ': haystack) actions1 actions2
         ~ Intersection1 needle haystack actions1 actions2
         , ComposeActionSets1 needle haystack actions1 actions2
         )
      => ComposeActionSets1 needle (hay ': haystack) actions1 actions2 where
  composeActionSets1 needle (Cons _ haystack) actions1 actions2
    = composeActionSets1 needle haystack actions1 actions2


-- Tada! We can now write a few tests to demonstrate that optic composition
-- works the way it should.
  
_1 :: Lens (a, x) (b, x) a b
_1 = mkLens fst (\b (_, x) -> (b, x))

_Just :: Prism (Maybe a) (Maybe b) a b
_Just = mkPrism (\s -> case s of
                         Just a -> Right a
                         Nothing -> Left Nothing)
                Just

traversed :: Traversable f
          => Traversal (f a) (f b) a b
traversed = mkTraversal traverse

-- |
-- >>> view (_1 % _1) (("foo", "bar"), "baz")
-- "foo"
-- >>> set (_1 % _1 % traversed) '!' (("foo", "bar"), "baz")
-- (("!!!","bar"),"baz")
-- >>> preview (_1 % _Just % _1) (Just ("foo", "bar"), "baz")
-- Just "foo"
-- >>> toListOf (traversed % _Just) [Just "foo", Nothing, Just "bar"]
-- ["foo","bar"]
main :: IO ()
main = doctest ["ActionSetOptics.hs"]

@etorreborre asks about the quality of the error messages. Let's take a look! Here are the error messages I get when I try to use view on a Traversal or set on a Fold.

>>> view (_1 % _Just % _1) (Just ("foo", "bar"), "baz")
...
... No instance for (Elem View '[]) arising from a use of ‘view’
...
>>> set (_Just % mkGetter show) "!" (Just 42)
...
... Could not deduce (Elem Over '[]) arising from a use of ‘set’
...

Not bad, I guess? I think it's clearly communicating "you cannot use view here", it's just not giving much information about why not.

Let's compare with the lens library.

>>> import Control.Lens
>>> view (_1 . _Just . _1) (Just ("foo", "bar"), "baz")
"foo"

No error message! Why did it succeed? Confusingly, because the target is a String. Here's what happens when the target is an Int:

>>> view (_1 . _Just . _1) (Just (42::Int, "bar"), "baz")
...
... No instance for (Monoid Int) arising from a use of ‘_Just’
...

It turns out Control.Lens.view has a different meaning depending on whether it is applied to a Getter or a Fold: in one case it gets the target, and in the other it mappends all the targets. I personally find this needlessly error-prone, but I guess others might see that as a feature.

Let's now look at calling set on a Fold:

>>> set (_Just . to show) "!" (Just 42)
...
... Could not deduce (Contravariant Identity)
...

Inscrutable unless one is intimately familiar with all the implementation details: Fold s a is represented as forall f . (Contravariant f, Applicative f) => ..., and set instantiates that f to Identity.

Let's now move on to the optics library, known for having better error messages than the lens library.

>>> import Optics
>>> view (_1 % _Just % _1) (Just ("foo", "bar"), "baz")
...
... An_AffineTraversal cannot be used as A_Getter
...   Perhaps you meant one of these:
...     ‘preview’ (from Optics.AffineFold)
...     ‘over’ (from Optics.Setter)
...     ‘set’ (from Optics.Setter)
...     ‘(^?)’ ‘(%~)’ ‘(.~)’ (from Optics.Operators)
...
>>> set (_Just % to show) "!" (Just 42)
...
... An_AffineFold cannot be used as A_Setter
...   Perhaps you meant one of these:
...     ‘preview’ (from Optics.AffineFold)
...     ‘(^?)’ (from Optics.Operators)
...

Wow, those error messages are great! Interestingly, the error message proposes a list of actions which are supported by the given optic. This list should be (relatively) easy to construct using my representation!

I just need a variant of Elem which takes an extra actions type parameter it can use to construct the nice error message...

{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}
import Data.Proxy
import GHC.TypeLits

class ElemWithError1 needle haystack (actions :: [Action]) where
  runOpticWithError1
    :: Proxy actions
    -> Optic haystack s t a b
    -> needle s t a b

instance TypeError ( 'Text "This optic does not support "
               ':<>: 'ShowType action
               ':$$: 'Text "Perhaps you meant one of "
               ':<>: 'ShowType actions
               ':<>: 'Text "?"
                   )
      => ElemWithError1 action '[] actions where
  runOpticWithError1 = undefined

instance ElemWithError1 needle (needle ': haystack) actions where
  runOpticWithError1 _ (Cons needle _)
    = needle

instance {-# OVERLAPPABLE #-}
         ElemWithError1 needle haystack actions
      => ElemWithError1 needle (hay ': haystack) actions where
  runOpticWithError1 actions (Cons _ haystack)
    = runOpticWithError1 actions haystack

And, for ease of use, a variant of ElemWithError1 which only takes one copy of the list of actions...

class ElemWithError1 needle haystack haystack
   => ElemWithError needle haystack where
  runOpticWithError
    :: Optic haystack s t a b
    -> needle s t a b

instance ElemWithError1 needle haystack haystack
      => ElemWithError needle haystack where
  runOpticWithError
    = runOpticWithError1 (Proxy @haystack)

And now, in order to get nice error messages, view and friends simply need to use runOpticWithError instead of runOptic:

-- |
-- >>> view (_1 % _Just % _1) (Just ("foo", "bar"), "baz")
-- ...
-- ... This optic does not support View
-- ... Perhaps you meant one of '[ToListOf, Over, TraverseOf]?
-- ...
view
  :: ElemWithError View actions
  => Optic' actions s a
  -> s -> a
view = runView . runOpticWithError