composable bundles of traversals

Foci.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
module Control.Lens.Foci where

import qualified Control.Category as Cat
import Control.Applicative
import Control.Monad
import Control.Lens.Combinators
import Data.Semigroup

-- | A 'Focus' specifies two things. First, whether a pattern matches within the
-- value 'a'. This is done by having a list of 'Matcher's, and all of them need to
-- match. Second, the positions to modify if the pattern does match, given by the Traversal' a b.
data Focus a b =
  Focus
  { focusMatchers :: [ Matcher a ] -- ^ the 'Focus' matches if all the 'Matcher's match
  , focusTraverse :: Traversal' a b -- ^ the position at which to modify
  }

instance Cat.Category Focus where
  id = Focus [] id
  {-# INLINE id #-}
  (.) = zoomFocus
  {-# INLINE (.) #-}

-- | A 'Matcher a' matches a pattern in some 'a' value
data Matcher a = forall m. Matcher (Traversal' a m)

matchFocus :: Focus a b -> a -> Bool
matchFocus Focus{..} val = all (`runMatcher` val) focusMatchers
  where
    runMatcher :: Matcher a -> a -> Bool
    runMatcher (Matcher m) = has m
{-# INLINE matchFocus #-}

-- | traverses 'a' only if all the 'Matcher's in the 'Foci' match
traverseFocus :: Applicative f => (b -> f b) -> Focus a b -> a -> f a
traverseFocus f focus a = traverseOf possiblyIgnored f a
  where possiblyIgnored =
          if matchFocus focus a
          then focusTraverse focus
          else ignored
{-# INLINE traverseFocus #-}

-- | traverses the 'Focus'es in the 'Foci' serially in the order they appear within the list
traverseFoci :: Monad f => Foci a b -> (b -> f b) -> a -> f a
traverseFoci (Foci foci) f = foldMapKleisli (traverseFocus f) foci
{-# INLINE traverseFoci #-}

-- | We compose two 'Focus' by zooming further with the second (small) 'Focus' at the zoomed in position of the first (big) 'Focus'. The semantics of the resulting 'Focus':
--
--   * The new focus matches if the big focus matches, /and/ the small focus matches when zoomed in at the 'focusTraverse' of the big focus
--   * The new 'focusTraverse' is simply "zooming in": the big 'focusTraverse' composed with the small 'focusTraverse'
zoomFocus :: Focus b c -> Focus a b -> Focus a c
zoomFocus g f =
  Focus
  { focusMatchers = focusMatchers f ++ map (\(Matcher m) -> Matcher $ focusTraverse f . m) (focusMatchers g)
  , focusTraverse = focusTraverse f . focusTraverse g
  }
{-# INLINE zoomFocus #-}

newtype Foci a b = Foci { unFoci :: [ Focus a b ] }

instance Cat.Category Foci where
  id = Foci [ Cat.id ]
  {-# INLINE id #-}
  (.) = zoomFoci
  {-# INLINE (.) #-}

-- | Two 'Foci' compose by composing all possible combinations of their constituent 'Focus'es
-- conceptually, we want the resulting 'Foci' to have 'Focus'es from second (small) 'Foci' but with their roots given by the roots of first (big) 'Focus'es
zoomFoci :: Foci b c -> Foci a b -> Foci a c
zoomFoci (Foci gs) (Foci fs) = Foci (liftA2 zoomFocus gs fs)
{-# INLINE zoomFoci #-}

-- endomonoids

type Foci' a = Foci a a
type Focus' a = Focus a a

instance Semigroup (Focus' a) where
  (<>) = flip (Cat..)
  {-# INLINE (<>) #-}

instance Monoid (Focus' a) where
  mempty = Cat.id
  {-# INLINE mempty #-}
  mappend = (<>)
  {-# INLINE mappend #-}

instance Semigroup (Foci' a) where
  (<>) = flip (Cat..)
  {-# INLINE (<>) #-}

instance Monoid (Foci' a) where
  mempty = Cat.id
  {-# INLINE mempty #-}
  mappend = (<>)
  {-# INLINE mappend #-}

-- TODO: extract
foldMapKleisli :: (Foldable t, Monad m) => (b -> a -> m a) -> t b -> a -> m a
foldMapKleisli f = foldr ((>=>) . f) return
{-# INLINE foldMapKleisli #-}