{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Foci where
import Control.Applicative
import qualified Control.Category as Cat
import Control.Lens.Combinators
import Control.Monad
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.
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
}
-- | 'Focus' forms a category. The identity element is simply a focus where the
-- match is empty and the traversal is identity too. The composition operator is
-- just 'zoomFocus'.
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 first (small) 'Focus' at
-- the zoomed in position of the second (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 #-}
type Foci' a = Foci a a
type Focus' a = Focus a a
-- | A 'Focus'' is a semigroup. /WARNING/: the semigroup composition and the
-- category composition are opposite in direction! This can lead to subtle and
-- hard-to-debug errors if you accidentally switched the order: it's hard to
-- debug because the error message will tell you the migration has successfully
-- but that is because the focus did not match at all.
instance Semigroup (Focus' a) where
(<>) = flip (Cat..)
{-# INLINE (<>) #-}
-- | A 'Focus'' is a monoid. /WARNING/: See warning at the 'Semigroup' instance.
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 #-}
-- | A version of 'foldMap' that operates on monadic functions aka Kleisli
-- arrows of the form @a -> m a@, where the monoidal identity is 'return' and
-- the monoidal operation is '>=>'.
--
-- Compare the signatures:
--
-- @
-- foldMapKleisli :: (Foldable t, Monad m) => (b -> (a -> m a)) -> (t b -> (a -> m a))
-- foldMap :: (Foldable t, Monoid m) => (b -> m ) -> (t b -> m )
-- @
foldMapKleisli :: (Foldable t, Monad m) => (b -> a -> m a) -> t b -> a -> m a
foldMapKleisli = foldMapBy (>=>) return
{-# INLINE foldMapKleisli #-}