{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}

#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-} -- template-haskell
#endif

#include "lens-common.h"

-------------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.Plated
-- Copyright   :  (C) 2012-16 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  Rank2Types
--
-- The name \"plate\" stems originally from \"boilerplate\", which was the term
-- used by the \"Scrap Your Boilerplate\" papers, and later inherited by Neil
-- Mitchell's \"Uniplate\".
--
-- <https://www.cs.york.ac.uk/fp/darcs/uniplate/uniplate.htm>
--
-- The combinators in here are designed to be compatible with and subsume the
-- @uniplate@ API with the notion of a 'Traversal' replacing
-- a 'Data.Data.Lens.uniplate' or 'Data.Data.Lens.biplate'.
--
-- By implementing these combinators in terms of 'plate' instead of
-- 'Data.Data.Lens.uniplate' additional type safety is gained, as the user is
-- no longer responsible for maintaining invariants such as the number of
-- children they received.
--
-- Note: The @Biplate@ is /deliberately/ excluded from the API here, with the
-- intention that you replace them with either explicit traversals, or by using the
-- @On@ variants of the combinators below with 'Data.Data.Lens.biplate' from
-- @Data.Data.Lens@. As a design, it forced the user into too many situations where
-- they had to choose between correctness and ease of use, and it was brittle in the
-- face of competing imports.
--
-- The sensible use of these combinators makes some simple assumptions.  Notably, any
-- of the @On@ combinators are expecting a 'Traversal', 'Setter' or 'Fold'
-- to play the role of the 'Data.Data.Lens.biplate' combinator, and so when the
-- types of the contents and the container match, they should be the 'id' 'Traversal',
-- 'Setter' or 'Fold'.
--
-- It is often beneficial to use the combinators in this module with the combinators
-- from @Data.Data.Lens@ or @GHC.Generics.Lens@ to make it easier to automatically
-- derive definitions for 'plate', or to derive custom traversals.
-------------------------------------------------------------------------------
module Control.Lens.Plated
  (
  -- * Uniplate
    Plated(..)

  -- * Uniplate Combinators
  , children
  , rewrite, rewriteOf, rewriteOn, rewriteOnOf
  , rewriteM, rewriteMOf, rewriteMOn, rewriteMOnOf
  , universe, universeOf, universeOn, universeOnOf
  , cosmos, cosmosOf, cosmosOn, cosmosOnOf
  , transform, transformOf, transformOn, transformOnOf
  , transformM, transformMOf, transformMOn, transformMOnOf
  , contexts, contextsOf, contextsOn, contextsOnOf
  , holes, holesOn, holesOnOf
  , para, paraOf
  , (...), deep

  -- * Compos
  -- $compos
  , composOpFold

  -- * Parts
  , parts

  -- * Generics
  , gplate
  , gplate1
  , GPlated
  , GPlated1
  )
  where

import Prelude ()

import Control.Comonad.Cofree
import qualified Control.Comonad.Trans.Cofree as CoTrans
import Control.Lens.Fold
import Control.Lens.Getter
import Control.Lens.Indexed
import Control.Lens.Internal.Context
import Control.Lens.Internal.Prelude
import Control.Lens.Type
import Control.Lens.Setter
import Control.Lens.Traversal
import Control.Monad.Free as Monad
import Control.Monad.Free.Church as Church
import Control.Monad.Trans.Free as Trans
import qualified Language.Haskell.TH as TH
import Data.Data
import Data.Data.Lens
import Data.Tree
import GHC.Generics

-- $setup
-- >>> :set -XDeriveGeneric -XDeriveDataTypeable
-- >>> import Control.Applicative
-- >>> import Data.Data (Data)
-- >>> import GHC.Generics (Generic)
-- >>> import Control.Lens

-- | A 'Plated' type is one where we know how to extract its immediate self-similar children.
--
-- /Example 1/:
--
-- @
-- import Control.Applicative
-- import Control.Lens
-- import Control.Lens.Plated
-- import Data.Data
-- import Data.Data.Lens ('Data.Data.Lens.uniplate')
-- @
--
-- @
-- data Expr
--   = Val 'Int'
--   | Neg Expr
--   | Add Expr Expr
--   deriving ('Eq','Ord','Show','Read','Data')
-- @
--
-- @
-- instance 'Plated' Expr where
--   'plate' f (Neg e) = Neg '<$>' f e
--   'plate' f (Add a b) = Add '<$>' f a '<*>' f b
--   'plate' _ a = 'pure' a
-- @
--
-- /or/
--
-- @
-- instance 'Plated' Expr where
--   'plate' = 'Data.Data.Lens.uniplate'
-- @
--
-- /Example 2/:
--
-- @
-- import Control.Applicative
-- import Control.Lens
-- import Control.Lens.Plated
-- import Data.Data
-- import Data.Data.Lens ('Data.Data.Lens.uniplate')
-- @
--
-- @
-- data Tree a
--   = Bin (Tree a) (Tree a)
--   | Tip a
--   deriving ('Eq','Ord','Show','Read','Data')
-- @
--
-- @
-- instance 'Plated' (Tree a) where
--   'plate' f (Bin l r) = Bin '<$>' f l '<*>' f r
--   'plate' _ t = 'pure' t
-- @
--
-- /or/
--
-- @
-- instance 'Data' a => 'Plated' (Tree a) where
--   'plate' = 'uniplate'
-- @
--
-- Note the big distinction between these two implementations.
--
-- The former will only treat children directly in this tree as descendents,
-- the latter will treat trees contained in the values under the tips also
-- as descendants!
--
-- When in doubt, pick a 'Traversal' and just use the various @...Of@ combinators
-- rather than pollute 'Plated' with orphan instances!
--
-- If you want to find something unplated and non-recursive with 'Data.Data.Lens.biplate'
-- use the @...OnOf@ variant with 'ignored', though those usecases are much better served
-- in most cases by using the existing 'Lens' combinators! e.g.
--
-- @
-- 'toListOf' 'biplate' ≡ 'universeOnOf' 'biplate' 'ignored'
-- @
--
-- This same ability to explicitly pass the 'Traversal' in question is why there is no
-- analogue to uniplate's @Biplate@.
--
-- Moreover, since we can allow custom traversals, we implement reasonable defaults for
-- polymorphic data types, that only 'Control.Traversable.traverse' into themselves, and /not/ their
-- polymorphic arguments.

class Plated a where
  -- | 'Traversal' of the immediate children of this structure.
  --
  -- If you're using GHC 7.2 or newer and your type has a 'Data' instance,
  -- 'plate' will default to 'uniplate' and you can choose to not override
  -- it with your own definition.
  plate :: Traversal' a a
  default plate :: Data a => Traversal' a a
  plate = (a -> f a) -> a -> f a
forall a. Data a => Traversal' a a
uniplate

instance Plated [a] where
  plate :: ([a] -> f [a]) -> [a] -> f [a]
plate [a] -> f [a]
f (a
x:[a]
xs) = (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> f [a] -> f [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> f [a]
f [a]
xs
  plate [a] -> f [a]
_ [] = [a] -> f [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

instance Traversable f => Plated (Monad.Free f a) where
  plate :: (Free f a -> f (Free f a)) -> Free f a -> f (Free f a)
plate Free f a -> f (Free f a)
f (Monad.Free f (Free f a)
as) = f (Free f a) -> Free f a
forall (f :: * -> *) a. f (Free f a) -> Free f a
Monad.Free (f (Free f a) -> Free f a) -> f (f (Free f a)) -> f (Free f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Free f a -> f (Free f a)) -> f (Free f a) -> f (f (Free f a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Free f a -> f (Free f a)
f f (Free f a)
as
  plate Free f a -> f (Free f a)
_ Free f a
x         = Free f a -> f (Free f a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Free f a
x

instance (Traversable f, Traversable m) => Plated (Trans.FreeT f m a) where
  plate :: (FreeT f m a -> f (FreeT f m a)) -> FreeT f m a -> f (FreeT f m a)
plate FreeT f m a -> f (FreeT f m a)
f (Trans.FreeT m (FreeF f a (FreeT f m a))
xs) = m (FreeF f a (FreeT f m a)) -> FreeT f m a
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
Trans.FreeT (m (FreeF f a (FreeT f m a)) -> FreeT f m a)
-> f (m (FreeF f a (FreeT f m a))) -> f (FreeT f m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FreeF f a (FreeT f m a) -> f (FreeF f a (FreeT f m a)))
-> m (FreeF f a (FreeT f m a)) -> f (m (FreeF f a (FreeT f m a)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((FreeT f m a -> f (FreeT f m a))
-> FreeF f a (FreeT f m a) -> f (FreeF f a (FreeT f m a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FreeT f m a -> f (FreeT f m a)
f) m (FreeF f a (FreeT f m a))
xs

instance Traversable f => Plated (Church.F f a) where
  plate :: (F f a -> f (F f a)) -> F f a -> f (F f a)
plate F f a -> f (F f a)
f = (Free f a -> F f a) -> f (Free f a) -> f (F f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Free f a -> F f a
forall (f :: * -> *) a. Functor f => Free f a -> F f a
Church.toF (f (Free f a) -> f (F f a))
-> (F f a -> f (Free f a)) -> F f a -> f (F f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Free f a -> f (Free f a)) -> Free f a -> f (Free f a)
forall a. Plated a => Traversal' a a
plate ((F f a -> Free f a) -> f (F f a) -> f (Free f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap F f a -> Free f a
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
Church.fromF (f (F f a) -> f (Free f a))
-> (Free f a -> f (F f a)) -> Free f a -> f (Free f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. F f a -> f (F f a)
f (F f a -> f (F f a))
-> (Free f a -> F f a) -> Free f a -> f (F f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Free f a -> F f a
forall (f :: * -> *) a. Functor f => Free f a -> F f a
Church.toF) (Free f a -> f (Free f a))
-> (F f a -> Free f a) -> F f a -> f (Free f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. F f a -> Free f a
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
Church.fromF

-- -- This one can't work
--
-- instance (Traversable f, Traversable m) => Plated (ChurchT.FT f m a) where
--   plate f = fmap ChurchT.toFT . plate (fmap ChurchT.fromFT . f . ChurchT.toFT) . ChurchT.fromFT

instance (Traversable f, Traversable w) => Plated (CoTrans.CofreeT f w a) where
  plate :: (CofreeT f w a -> f (CofreeT f w a))
-> CofreeT f w a -> f (CofreeT f w a)
plate CofreeT f w a -> f (CofreeT f w a)
f (CoTrans.CofreeT w (CofreeF f a (CofreeT f w a))
xs) = w (CofreeF f a (CofreeT f w a)) -> CofreeT f w a
forall (f :: * -> *) (w :: * -> *) a.
w (CofreeF f a (CofreeT f w a)) -> CofreeT f w a
CoTrans.CofreeT (w (CofreeF f a (CofreeT f w a)) -> CofreeT f w a)
-> f (w (CofreeF f a (CofreeT f w a))) -> f (CofreeT f w a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CofreeF f a (CofreeT f w a) -> f (CofreeF f a (CofreeT f w a)))
-> w (CofreeF f a (CofreeT f w a))
-> f (w (CofreeF f a (CofreeT f w a)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((CofreeT f w a -> f (CofreeT f w a))
-> CofreeF f a (CofreeT f w a) -> f (CofreeF f a (CofreeT f w a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse CofreeT f w a -> f (CofreeT f w a)
f) w (CofreeF f a (CofreeT f w a))
xs

instance Traversable f => Plated (Cofree f a) where
  plate :: (Cofree f a -> f (Cofree f a)) -> Cofree f a -> f (Cofree f a)
plate Cofree f a -> f (Cofree f a)
f (a
a :< f (Cofree f a)
as) = a -> f (Cofree f a) -> Cofree f a
forall (f :: * -> *) a. a -> f (Cofree f a) -> Cofree f a
(:<) a
a (f (Cofree f a) -> Cofree f a)
-> f (f (Cofree f a)) -> f (Cofree f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Cofree f a -> f (Cofree f a))
-> f (Cofree f a) -> f (f (Cofree f a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Cofree f a -> f (Cofree f a)
f f (Cofree f a)
as

instance Plated (Tree a) where
  plate :: (Tree a -> f (Tree a)) -> Tree a -> f (Tree a)
plate Tree a -> f (Tree a)
f (Node a
a Forest a
as) = a -> Forest a -> Tree a
forall a. a -> Forest a -> Tree a
Node a
a (Forest a -> Tree a) -> f (Forest a) -> f (Tree a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Tree a -> f (Tree a)) -> Forest a -> f (Forest a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Tree a -> f (Tree a)
f Forest a
as

{- Default uniplate instances -}
instance Plated TH.Exp
instance Plated TH.Dec
instance Plated TH.Con
instance Plated TH.Type
instance Plated TH.Stmt
instance Plated TH.Pat


infixr 9 ...
-- | Compose through a plate
(...) :: (Applicative f, Plated c) => LensLike f s t c c -> Over p f c c a b -> Over p f s t a b
LensLike f s t c c
l ... :: LensLike f s t c c -> Over p f c c a b -> Over p f s t a b
... Over p f c c a b
m = LensLike f s t c c
l LensLike f s t c c -> Over p f c c a b -> Over p f s t a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c -> f c) -> c -> f c
forall a. Plated a => Traversal' a a
plate ((c -> f c) -> c -> f c) -> Over p f c c a b -> Over p f c c a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Over p f c c a b
m
{-# INLINE (...) #-}


-- | Try to apply a traversal to all transitive descendants of a 'Plated' container, but
-- do not recurse through matching descendants.
--
-- @
-- 'deep' :: 'Plated' s => 'Fold' s a                 -> 'Fold' s a
-- 'deep' :: 'Plated' s => 'IndexedFold' s a          -> 'IndexedFold' s a
-- 'deep' :: 'Plated' s => 'Traversal' s s a b        -> 'Traversal' s s a b
-- 'deep' :: 'Plated' s => 'IndexedTraversal' s s a b -> 'IndexedTraversal' s s a b
-- @
deep :: (Conjoined p, Applicative f, Plated s) => Traversing p f s s a b -> Over p f s s a b
deep :: Traversing p f s s a b -> Over p f s s a b
deep = LensLike f s s s s -> Traversing p f s s a b -> Over p f s s a b
forall (p :: * -> * -> *) (f :: * -> *) s t a b.
(Conjoined p, Applicative f) =>
LensLike f s t s t -> Traversing p f s t a b -> Over p f s t a b
deepOf LensLike f s s s s
forall a. Plated a => Traversal' a a
plate

-------------------------------------------------------------------------------
-- Children
-------------------------------------------------------------------------------

-- | Extract the immediate descendants of a 'Plated' container.
--
-- @
-- 'children' ≡ 'toListOf' 'plate'
-- @
children :: Plated a => a -> [a]
children :: a -> [a]
children = Getting (Endo [a]) a a -> a -> [a]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf Getting (Endo [a]) a a
forall a. Plated a => Traversal' a a
plate
{-# INLINE children #-}

-------------------------------------------------------------------------------
-- Rewriting
-------------------------------------------------------------------------------

-- | Rewrite by applying a rule everywhere you can. Ensures that the rule cannot
-- be applied anywhere in the result:
--
-- @
-- propRewrite r x = 'all' ('Data.Just.isNothing' '.' r) ('universe' ('rewrite' r x))
-- @
--
-- Usually 'transform' is more appropriate, but 'rewrite' can give better
-- compositionality. Given two single transformations @f@ and @g@, you can
-- construct @\\a -> f a '<|>' g a@ which performs both rewrites until a fixed point.
rewrite :: Plated a => (a -> Maybe a) -> a -> a
rewrite :: (a -> Maybe a) -> a -> a
rewrite = ASetter a a a a -> (a -> Maybe a) -> a -> a
forall a b. ASetter a b a b -> (b -> Maybe a) -> a -> b
rewriteOf ASetter a a a a
forall a. Plated a => Traversal' a a
plate
{-# INLINE rewrite #-}

-- | Rewrite by applying a rule everywhere you can. Ensures that the rule cannot
-- be applied anywhere in the result:
--
-- @
-- propRewriteOf l r x = 'all' ('Data.Just.isNothing' '.' r) ('universeOf' l ('rewriteOf' l r x))
-- @
--
-- Usually 'transformOf' is more appropriate, but 'rewriteOf' can give better
-- compositionality. Given two single transformations @f@ and @g@, you can
-- construct @\\a -> f a '<|>' g a@ which performs both rewrites until a fixed point.
--
-- @
-- 'rewriteOf' :: 'Control.Lens.Iso.Iso'' a a       -> (a -> 'Maybe' a) -> a -> a
-- 'rewriteOf' :: 'Lens'' a a      -> (a -> 'Maybe' a) -> a -> a
-- 'rewriteOf' :: 'Traversal'' a a -> (a -> 'Maybe' a) -> a -> a
-- 'rewriteOf' :: 'Setter'' a a    -> (a -> 'Maybe' a) -> a -> a
-- @
rewriteOf :: ASetter a b a b -> (b -> Maybe a) -> a -> b
rewriteOf :: ASetter a b a b -> (b -> Maybe a) -> a -> b
rewriteOf ASetter a b a b
l b -> Maybe a
f = a -> b
go where
  go :: a -> b
go = ASetter a b a b -> (b -> b) -> a -> b
forall a b. ASetter a b a b -> (b -> b) -> a -> b
transformOf ASetter a b a b
l (\b
x -> b -> (a -> b) -> Maybe a -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
x a -> b
go (b -> Maybe a
f b
x))
{-# INLINE rewriteOf #-}

-- | Rewrite recursively over part of a larger structure.
--
-- @
-- 'rewriteOn' :: 'Plated' a => 'Control.Lens.Iso.Iso'' s a       -> (a -> 'Maybe' a) -> s -> s
-- 'rewriteOn' :: 'Plated' a => 'Lens'' s a      -> (a -> 'Maybe' a) -> s -> s
-- 'rewriteOn' :: 'Plated' a => 'Traversal'' s a -> (a -> 'Maybe' a) -> s -> s
-- 'rewriteOn' :: 'Plated' a => 'ASetter'' s a   -> (a -> 'Maybe' a) -> s -> s
-- @
rewriteOn :: Plated a => ASetter s t a a -> (a -> Maybe a) -> s -> t
rewriteOn :: ASetter s t a a -> (a -> Maybe a) -> s -> t
rewriteOn ASetter s t a a
b = ASetter s t a a -> (a -> a) -> s -> t
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter s t a a
b ((a -> a) -> s -> t)
-> ((a -> Maybe a) -> a -> a) -> (a -> Maybe a) -> s -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe a) -> a -> a
forall a. Plated a => (a -> Maybe a) -> a -> a
rewrite
{-# INLINE rewriteOn #-}

-- | Rewrite recursively over part of a larger structure using a specified 'Setter'.
--
-- @
-- 'rewriteOnOf' :: 'Control.Lens.Iso.Iso'' s a       -> 'Control.Lens.Iso.Iso'' a a       -> (a -> 'Maybe' a) -> s -> s
-- 'rewriteOnOf' :: 'Lens'' s a      -> 'Lens'' a a      -> (a -> 'Maybe' a) -> s -> s
-- 'rewriteOnOf' :: 'Traversal'' s a -> 'Traversal'' a a -> (a -> 'Maybe' a) -> s -> s
-- 'rewriteOnOf' :: 'Setter'' s a    -> 'Setter'' a a    -> (a -> 'Maybe' a) -> s -> s
-- @
rewriteOnOf :: ASetter s t a b -> ASetter a b a b -> (b -> Maybe a) -> s -> t
rewriteOnOf :: ASetter s t a b -> ASetter a b a b -> (b -> Maybe a) -> s -> t
rewriteOnOf ASetter s t a b
b ASetter a b a b
l = ASetter s t a b -> (a -> b) -> s -> t
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter s t a b
b ((a -> b) -> s -> t)
-> ((b -> Maybe a) -> a -> b) -> (b -> Maybe a) -> s -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter a b a b -> (b -> Maybe a) -> a -> b
forall a b. ASetter a b a b -> (b -> Maybe a) -> a -> b
rewriteOf ASetter a b a b
l
{-# INLINE rewriteOnOf #-}

-- | Rewrite by applying a monadic rule everywhere you can. Ensures that the rule cannot
-- be applied anywhere in the result.
rewriteM :: (Monad m, Plated a) => (a -> m (Maybe a)) -> a -> m a
rewriteM :: (a -> m (Maybe a)) -> a -> m a
rewriteM = LensLike (WrappedMonad m) a a a a -> (a -> m (Maybe a)) -> a -> m a
forall (m :: * -> *) a b.
Monad m =>
LensLike (WrappedMonad m) a b a b -> (b -> m (Maybe a)) -> a -> m b
rewriteMOf LensLike (WrappedMonad m) a a a a
forall a. Plated a => Traversal' a a
plate
{-# INLINE rewriteM #-}

-- | Rewrite by applying a monadic rule everywhere you recursing with a user-specified 'Traversal'.
-- Ensures that the rule cannot be applied anywhere in the result.
rewriteMOf :: Monad m => LensLike (WrappedMonad m) a b a b -> (b -> m (Maybe a)) -> a -> m b
rewriteMOf :: LensLike (WrappedMonad m) a b a b -> (b -> m (Maybe a)) -> a -> m b
rewriteMOf LensLike (WrappedMonad m) a b a b
l b -> m (Maybe a)
f = a -> m b
go where
  go :: a -> m b
go = LensLike (WrappedMonad m) a b a b -> (b -> m b) -> a -> m b
forall (m :: * -> *) a b.
Monad m =>
LensLike (WrappedMonad m) a b a b -> (b -> m b) -> a -> m b
transformMOf LensLike (WrappedMonad m) a b a b
l (\b
x -> b -> m (Maybe a)
f b
x m (Maybe a) -> (Maybe a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m b -> (a -> m b) -> Maybe a -> m b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
x) a -> m b
go)
{-# INLINE rewriteMOf #-}

-- | Rewrite by applying a monadic rule everywhere inside of a structure located by a user-specified 'Traversal'.
-- Ensures that the rule cannot be applied anywhere in the result.
rewriteMOn :: (Monad m, Plated a) => LensLike (WrappedMonad m) s t a a -> (a -> m (Maybe a)) -> s -> m t
rewriteMOn :: LensLike (WrappedMonad m) s t a a -> (a -> m (Maybe a)) -> s -> m t
rewriteMOn LensLike (WrappedMonad m) s t a a
b = LensLike (WrappedMonad m) s t a a -> (a -> m a) -> s -> m t
forall (m :: * -> *) s t a b.
LensLike (WrappedMonad m) s t a b -> (a -> m b) -> s -> m t
mapMOf LensLike (WrappedMonad m) s t a a
b ((a -> m a) -> s -> m t)
-> ((a -> m (Maybe a)) -> a -> m a)
-> (a -> m (Maybe a))
-> s
-> m t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m (Maybe a)) -> a -> m a
forall (m :: * -> *) a.
(Monad m, Plated a) =>
(a -> m (Maybe a)) -> a -> m a
rewriteM
{-# INLINE rewriteMOn #-}

-- | Rewrite by applying a monadic rule everywhere inside of a structure located by a user-specified 'Traversal',
-- using a user-specified 'Traversal' for recursion. Ensures that the rule cannot be applied anywhere in the result.
rewriteMOnOf :: Monad m => LensLike (WrappedMonad m) s t a b -> LensLike (WrappedMonad m) a b a b -> (b -> m (Maybe a)) -> s -> m t
rewriteMOnOf :: LensLike (WrappedMonad m) s t a b
-> LensLike (WrappedMonad m) a b a b
-> (b -> m (Maybe a))
-> s
-> m t
rewriteMOnOf LensLike (WrappedMonad m) s t a b
b LensLike (WrappedMonad m) a b a b
l = LensLike (WrappedMonad m) s t a b -> (a -> m b) -> s -> m t
forall (m :: * -> *) s t a b.
LensLike (WrappedMonad m) s t a b -> (a -> m b) -> s -> m t
mapMOf LensLike (WrappedMonad m) s t a b
b ((a -> m b) -> s -> m t)
-> ((b -> m (Maybe a)) -> a -> m b)
-> (b -> m (Maybe a))
-> s
-> m t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensLike (WrappedMonad m) a b a b -> (b -> m (Maybe a)) -> a -> m b
forall (m :: * -> *) a b.
Monad m =>
LensLike (WrappedMonad m) a b a b -> (b -> m (Maybe a)) -> a -> m b
rewriteMOf LensLike (WrappedMonad m) a b a b
l
{-# INLINE rewriteMOnOf #-}

-------------------------------------------------------------------------------
-- Universe
-------------------------------------------------------------------------------

-- | Retrieve all of the transitive descendants of a 'Plated' container, including itself.
universe :: Plated a => a -> [a]
universe :: a -> [a]
universe = Getting [a] a a -> a -> [a]
forall a. Getting [a] a a -> a -> [a]
universeOf Getting [a] a a
forall a. Plated a => Traversal' a a
plate
{-# INLINE universe #-}

-- | Given a 'Fold' that knows how to locate immediate children, retrieve all of the transitive descendants of a node, including itself.
--
-- @
-- 'universeOf' :: 'Fold' a a -> a -> [a]
-- @
universeOf :: Getting [a] a a -> a -> [a]
universeOf :: Getting [a] a a -> a -> [a]
universeOf Getting [a] a a
l = a -> [a]
go where
  go :: a -> [a]
go a
a = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Getting [a] a a -> (a -> [a]) -> a -> [a]
forall r s a. Getting r s a -> (a -> r) -> s -> r
foldMapOf Getting [a] a a
l a -> [a]
go a
a
{-# INLINE universeOf #-}

-- | Given a 'Fold' that knows how to find 'Plated' parts of a container retrieve them and all of their descendants, recursively.
universeOn ::  Plated a => Getting [a] s a -> s -> [a]
universeOn :: Getting [a] s a -> s -> [a]
universeOn Getting [a] s a
b = Getting [a] s a -> Getting [a] a a -> s -> [a]
forall a s. Getting [a] s a -> Getting [a] a a -> s -> [a]
universeOnOf Getting [a] s a
b Getting [a] a a
forall a. Plated a => Traversal' a a
plate
{-# INLINE universeOn #-}

-- | Given a 'Fold' that knows how to locate immediate children, retrieve all of the transitive descendants of a node, including itself that lie
-- in a region indicated by another 'Fold'.
--
-- @
-- 'toListOf' l ≡ 'universeOnOf' l 'ignored'
-- @
universeOnOf :: Getting [a] s a -> Getting [a] a a -> s -> [a]
universeOnOf :: Getting [a] s a -> Getting [a] a a -> s -> [a]
universeOnOf Getting [a] s a
b = Getting [a] s a -> (a -> [a]) -> s -> [a]
forall r s a. Getting r s a -> (a -> r) -> s -> r
foldMapOf Getting [a] s a
b ((a -> [a]) -> s -> [a])
-> (Getting [a] a a -> a -> [a]) -> Getting [a] a a -> s -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting [a] a a -> a -> [a]
forall a. Getting [a] a a -> a -> [a]
universeOf
{-# INLINE universeOnOf #-}

-- | Fold over all transitive descendants of a 'Plated' container, including itself.
cosmos :: Plated a => Fold a a
cosmos :: Fold a a
cosmos = LensLike' f a a -> LensLike' f a a
forall (f :: * -> *) a.
(Applicative f, Contravariant f) =>
LensLike' f a a -> LensLike' f a a
cosmosOf LensLike' f a a
forall a. Plated a => Traversal' a a
plate
{-# INLINE cosmos #-}

-- | Given a 'Fold' that knows how to locate immediate children, fold all of the transitive descendants of a node, including itself.
--
-- @
-- 'cosmosOf' :: 'Fold' a a -> 'Fold' a a
-- @
cosmosOf :: (Applicative f, Contravariant f) => LensLike' f a a -> LensLike' f a a
-- The 'Contravariant' constraint isn't required for the implementation. Since any 'Traversal' produced with 'cosmosOf' is more likely than
-- not to be broken, the additional constraint serves to restrict 'cosmosOf' to 'Fold's.
cosmosOf :: LensLike' f a a -> LensLike' f a a
cosmosOf LensLike' f a a
d a -> f a
f a
s = a -> f a
f a
s f a -> f a -> f a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> LensLike' f a a
d (LensLike' f a a -> LensLike' f a a
forall (f :: * -> *) a.
(Applicative f, Contravariant f) =>
LensLike' f a a -> LensLike' f a a
cosmosOf LensLike' f a a
d a -> f a
f) a
s
{-# INLINE cosmosOf #-}

-- | Given a 'Fold' that knows how to find 'Plated' parts of a container fold them and all of their descendants, recursively.
--
-- @
-- 'cosmosOn' :: 'Plated' a => 'Fold' s a -> 'Fold' s a
-- @
cosmosOn :: (Applicative f, Contravariant f, Plated a) => LensLike' f s a -> LensLike' f s a
cosmosOn :: LensLike' f s a -> LensLike' f s a
cosmosOn LensLike' f s a
d = LensLike' f s a -> LensLike' f a a -> LensLike' f s a
forall (f :: * -> *) s a.
(Applicative f, Contravariant f) =>
LensLike' f s a -> LensLike' f a a -> LensLike' f s a
cosmosOnOf LensLike' f s a
d LensLike' f a a
forall a. Plated a => Traversal' a a
plate
{-# INLINE cosmosOn #-}

-- | Given a 'Fold' that knows how to locate immediate children, fold all of the transitive descendants of a node, including itself that lie
-- in a region indicated by another 'Fold'.
--
-- @
-- 'cosmosOnOf' :: 'Fold' s a -> 'Fold' a a -> 'Fold' s a
-- @
cosmosOnOf :: (Applicative f, Contravariant f) => LensLike' f s a -> LensLike' f a a -> LensLike' f s a
cosmosOnOf :: LensLike' f s a -> LensLike' f a a -> LensLike' f s a
cosmosOnOf LensLike' f s a
d LensLike' f a a
p = LensLike' f s a
d LensLike' f s a -> LensLike' f a a -> LensLike' f s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensLike' f a a -> LensLike' f a a
forall (f :: * -> *) a.
(Applicative f, Contravariant f) =>
LensLike' f a a -> LensLike' f a a
cosmosOf LensLike' f a a
p
{-# INLINE cosmosOnOf #-}

-------------------------------------------------------------------------------
-- Transformation
-------------------------------------------------------------------------------

-- | Transform every element in the tree, in a bottom-up manner.
--
-- For example, replacing negative literals with literals:
--
-- @
-- negLits = 'transform' $ \\x -> case x of
--   Neg (Lit i) -> Lit ('negate' i)
--   _           -> x
-- @
transform :: Plated a => (a -> a) -> a -> a
transform :: (a -> a) -> a -> a
transform = ASetter a a a a -> (a -> a) -> a -> a
forall a b. ASetter a b a b -> (b -> b) -> a -> b
transformOf ASetter a a a a
forall a. Plated a => Traversal' a a
plate
{-# INLINE transform #-}

-- | Transform every element in the tree in a bottom-up manner over a region indicated by a 'Setter'.
--
-- @
-- 'transformOn' :: 'Plated' a => 'Traversal'' s a -> (a -> a) -> s -> s
-- 'transformOn' :: 'Plated' a => 'Setter'' s a    -> (a -> a) -> s -> s
-- @
transformOn :: Plated a => ASetter s t a a -> (a -> a) -> s -> t
transformOn :: ASetter s t a a -> (a -> a) -> s -> t
transformOn ASetter s t a a
b = ASetter s t a a -> (a -> a) -> s -> t
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter s t a a
b ((a -> a) -> s -> t) -> ((a -> a) -> a -> a) -> (a -> a) -> s -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> a -> a
forall a. Plated a => (a -> a) -> a -> a
transform
{-# INLINE transformOn #-}

-- | Transform every element by recursively applying a given 'Setter' in a bottom-up manner.
--
-- @
-- 'transformOf' :: 'Traversal'' a a -> (a -> a) -> a -> a
-- 'transformOf' :: 'Setter'' a a    -> (a -> a) -> a -> a
-- @
transformOf :: ASetter a b a b -> (b -> b) -> a -> b
transformOf :: ASetter a b a b -> (b -> b) -> a -> b
transformOf ASetter a b a b
l b -> b
f = a -> b
go where
  go :: a -> b
go = b -> b
f (b -> b) -> (a -> b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter a b a b -> (a -> b) -> a -> b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter a b a b
l a -> b
go
{-# INLINE transformOf #-}

-- | Transform every element in a region indicated by a 'Setter' by recursively applying another 'Setter'
-- in a bottom-up manner.
--
-- @
-- 'transformOnOf' :: 'Setter'' s a -> 'Traversal'' a a -> (a -> a) -> s -> s
-- 'transformOnOf' :: 'Setter'' s a -> 'Setter'' a a    -> (a -> a) -> s -> s
-- @
transformOnOf :: ASetter s t a b -> ASetter a b a b -> (b -> b) -> s -> t
transformOnOf :: ASetter s t a b -> ASetter a b a b -> (b -> b) -> s -> t
transformOnOf ASetter s t a b
b ASetter a b a b
l = ASetter s t a b -> (a -> b) -> s -> t
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter s t a b
b ((a -> b) -> s -> t) -> ((b -> b) -> a -> b) -> (b -> b) -> s -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter a b a b -> (b -> b) -> a -> b
forall a b. ASetter a b a b -> (b -> b) -> a -> b
transformOf ASetter a b a b
l
{-# INLINE transformOnOf #-}

-- | Transform every element in the tree, in a bottom-up manner, monadically.
transformM :: (Monad m, Plated a) => (a -> m a) -> a -> m a
transformM :: (a -> m a) -> a -> m a
transformM = LensLike (WrappedMonad m) a a a a -> (a -> m a) -> a -> m a
forall (m :: * -> *) a b.
Monad m =>
LensLike (WrappedMonad m) a b a b -> (b -> m b) -> a -> m b
transformMOf LensLike (WrappedMonad m) a a a a
forall a. Plated a => Traversal' a a
plate
{-# INLINE transformM #-}

-- | Transform every element in the tree in a region indicated by a supplied 'Traversal', in a bottom-up manner, monadically.
--
-- @
-- 'transformMOn' :: ('Monad' m, 'Plated' a) => 'Traversal'' s a -> (a -> m a) -> s -> m s
-- @
transformMOn :: (Monad m, Plated a) => LensLike (WrappedMonad m) s t a a -> (a -> m a) -> s -> m t
transformMOn :: LensLike (WrappedMonad m) s t a a -> (a -> m a) -> s -> m t
transformMOn LensLike (WrappedMonad m) s t a a
b = LensLike (WrappedMonad m) s t a a -> (a -> m a) -> s -> m t
forall (m :: * -> *) s t a b.
LensLike (WrappedMonad m) s t a b -> (a -> m b) -> s -> m t
mapMOf LensLike (WrappedMonad m) s t a a
b ((a -> m a) -> s -> m t)
-> ((a -> m a) -> a -> m a) -> (a -> m a) -> s -> m t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m a) -> a -> m a
forall (m :: * -> *) a.
(Monad m, Plated a) =>
(a -> m a) -> a -> m a
transformM
{-# INLINE transformMOn #-}

-- | Transform every element in a tree using a user supplied 'Traversal' in a bottom-up manner with a monadic effect.
--
-- @
-- 'transformMOf' :: 'Monad' m => 'Traversal'' a a -> (a -> m a) -> a -> m a
-- @
transformMOf :: Monad m => LensLike (WrappedMonad m) a b a b -> (b -> m b) -> a -> m b
transformMOf :: LensLike (WrappedMonad m) a b a b -> (b -> m b) -> a -> m b
transformMOf LensLike (WrappedMonad m) a b a b
l b -> m b
f = a -> m b
go where
  go :: a -> m b
go a
t = LensLike (WrappedMonad m) a b a b -> (a -> m b) -> a -> m b
forall (m :: * -> *) s t a b.
LensLike (WrappedMonad m) s t a b -> (a -> m b) -> s -> m t
mapMOf LensLike (WrappedMonad m) a b a b
l a -> m b
go a
t m b -> (b -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> m b
f
{-# INLINE transformMOf #-}

-- | Transform every element in a tree that lies in a region indicated by a supplied 'Traversal', walking with a user supplied 'Traversal' in
-- a bottom-up manner with a monadic effect.
--
-- @
-- 'transformMOnOf' :: 'Monad' m => 'Traversal'' s a -> 'Traversal'' a a -> (a -> m a) -> s -> m s
-- @
transformMOnOf :: Monad m => LensLike (WrappedMonad m) s t a b -> LensLike (WrappedMonad m) a b a b -> (b -> m b) -> s -> m t
transformMOnOf :: LensLike (WrappedMonad m) s t a b
-> LensLike (WrappedMonad m) a b a b -> (b -> m b) -> s -> m t
transformMOnOf LensLike (WrappedMonad m) s t a b
b LensLike (WrappedMonad m) a b a b
l = LensLike (WrappedMonad m) s t a b -> (a -> m b) -> s -> m t
forall (m :: * -> *) s t a b.
LensLike (WrappedMonad m) s t a b -> (a -> m b) -> s -> m t
mapMOf LensLike (WrappedMonad m) s t a b
b ((a -> m b) -> s -> m t)
-> ((b -> m b) -> a -> m b) -> (b -> m b) -> s -> m t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensLike (WrappedMonad m) a b a b -> (b -> m b) -> a -> m b
forall (m :: * -> *) a b.
Monad m =>
LensLike (WrappedMonad m) a b a b -> (b -> m b) -> a -> m b
transformMOf LensLike (WrappedMonad m) a b a b
l
{-# INLINE transformMOnOf #-}

-------------------------------------------------------------------------------
-- Holes and Contexts
-------------------------------------------------------------------------------

-- | Return a list of all of the editable contexts for every location in the structure, recursively.
--
-- @
-- propUniverse x = 'universe' x '==' 'map' 'Control.Comonad.Store.Class.pos' ('contexts' x)
-- propId x = 'all' ('==' x) ['Control.Lens.Internal.Context.extract' w | w <- 'contexts' x]
-- @
--
-- @
-- 'contexts' ≡ 'contextsOf' 'plate'
-- @
contexts :: Plated a => a -> [Context a a a]
contexts :: a -> [Context a a a]
contexts = ATraversal' a a -> a -> [Context a a a]
forall a. ATraversal' a a -> a -> [Context a a a]
contextsOf ATraversal' a a
forall a. Plated a => Traversal' a a
plate
{-# INLINE contexts #-}

-- | Return a list of all of the editable contexts for every location in the structure, recursively, using a user-specified 'Traversal' to walk each layer.
--
-- @
-- propUniverse l x = 'universeOf' l x '==' 'map' 'Control.Comonad.Store.Class.pos' ('contextsOf' l x)
-- propId l x = 'all' ('==' x) ['Control.Lens.Internal.Context.extract' w | w <- 'contextsOf' l x]
-- @
--
-- @
-- 'contextsOf' :: 'Traversal'' a a -> a -> ['Context' a a a]
-- @
contextsOf :: ATraversal' a a -> a -> [Context a a a]
contextsOf :: ATraversal' a a -> a -> [Context a a a]
contextsOf ATraversal' a a
l a
x = a -> Context a a a
forall (p :: * -> * -> *) (w :: * -> * -> * -> *) a b.
Sellable p w =>
p a (w a b b)
sell a
x Context a a a -> [Context a a a] -> [Context a a a]
forall a. a -> [a] -> [a]
: [Context a a a] -> [Context a a a]
forall t. [Context a a t] -> [Context a a t]
f ((Pretext (->) a a a -> Context a a a)
-> [Pretext (->) a a a] -> [Context a a a]
forall a b. (a -> b) -> [a] -> [b]
map Pretext (->) a a a -> Context a a a
forall (w :: * -> * -> * -> *) a b t.
IndexedComonadStore w =>
w a b t -> Context a b t
context (ATraversal' a a -> a -> [Pretext (->) a a a]
forall (p :: * -> * -> *) a s t.
Conjoined p =>
Over p (Bazaar p a a) s t a a -> s -> [Pretext p a a t]
holesOf ATraversal' a a
l a
x)) where
  f :: [Context a a t] -> [Context a a t]
f [Context a a t]
xs = do
    Context a -> t
ctx a
child <- [Context a a t]
xs
    Context a -> a
cont a
y <- ATraversal' a a -> a -> [Context a a a]
forall a. ATraversal' a a -> a -> [Context a a a]
contextsOf ATraversal' a a
l a
child
    Context a a t -> [Context a a t]
forall (m :: * -> *) a. Monad m => a -> m a
return (Context a a t -> [Context a a t])
-> Context a a t -> [Context a a t]
forall a b. (a -> b) -> a -> b
$ (a -> t) -> a -> Context a a t
forall a b t. (b -> t) -> a -> Context a b t
Context (a -> t
ctx (a -> t) -> (a -> a) -> a -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
cont) a
y
{-# INLINE contextsOf #-}

-- | Return a list of all of the editable contexts for every location in the structure in an areas indicated by a user supplied 'Traversal', recursively using 'plate'.
--
-- @
-- 'contextsOn' b ≡ 'contextsOnOf' b 'plate'
-- @
--
-- @
-- 'contextsOn' :: 'Plated' a => 'Traversal'' s a -> s -> ['Context' a a s]
-- @
contextsOn :: Plated a => ATraversal s t a a -> s -> [Context a a t]
contextsOn :: ATraversal s t a a -> s -> [Context a a t]
contextsOn ATraversal s t a a
b = ATraversal s t a a -> ATraversal' a a -> s -> [Context a a t]
forall s t a.
ATraversal s t a a -> ATraversal' a a -> s -> [Context a a t]
contextsOnOf ATraversal s t a a
b ATraversal' a a
forall a. Plated a => Traversal' a a
plate
{-# INLINE contextsOn #-}

-- | Return a list of all of the editable contexts for every location in the structure in an areas indicated by a user supplied 'Traversal', recursively using
-- another user-supplied 'Traversal' to walk each layer.
--
-- @
-- 'contextsOnOf' :: 'Traversal'' s a -> 'Traversal'' a a -> s -> ['Context' a a s]
-- @
contextsOnOf :: ATraversal s t a a -> ATraversal' a a -> s -> [Context a a t]
contextsOnOf :: ATraversal s t a a -> ATraversal' a a -> s -> [Context a a t]
contextsOnOf ATraversal s t a a
b ATraversal' a a
l = [Context a a t] -> [Context a a t]
forall t. [Context a a t] -> [Context a a t]
f ([Context a a t] -> [Context a a t])
-> (s -> [Context a a t]) -> s -> [Context a a t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pretext (->) a a t -> Context a a t)
-> [Pretext (->) a a t] -> [Context a a t]
forall a b. (a -> b) -> [a] -> [b]
map Pretext (->) a a t -> Context a a t
forall (w :: * -> * -> * -> *) a b t.
IndexedComonadStore w =>
w a b t -> Context a b t
context ([Pretext (->) a a t] -> [Context a a t])
-> (s -> [Pretext (->) a a t]) -> s -> [Context a a t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ATraversal s t a a -> s -> [Pretext (->) a a t]
forall (p :: * -> * -> *) a s t.
Conjoined p =>
Over p (Bazaar p a a) s t a a -> s -> [Pretext p a a t]
holesOf ATraversal s t a a
b where
  f :: [Context a a t] -> [Context a a t]
f [Context a a t]
xs = do
    Context a -> t
ctx a
child <- [Context a a t]
xs
    Context a -> a
cont a
y <- ATraversal' a a -> a -> [Context a a a]
forall a. ATraversal' a a -> a -> [Context a a a]
contextsOf ATraversal' a a
l a
child
    Context a a t -> [Context a a t]
forall (m :: * -> *) a. Monad m => a -> m a
return (Context a a t -> [Context a a t])
-> Context a a t -> [Context a a t]
forall a b. (a -> b) -> a -> b
$ (a -> t) -> a -> Context a a t
forall a b t. (b -> t) -> a -> Context a b t
Context (a -> t
ctx (a -> t) -> (a -> a) -> a -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
cont) a
y
{-# INLINE contextsOnOf #-}

-- | The one-level version of 'context'. This extracts a list of the immediate children as editable contexts.
--
-- Given a context you can use 'Control.Comonad.Store.Class.pos' to see the values, 'Control.Comonad.Store.Class.peek' at what the structure would be like with an edited result, or simply 'Control.Lens.Internal.Context.extract' the original structure.
--
-- @
-- propChildren x = 'children' l x '==' 'map' 'Control.Comonad.Store.Class.pos' ('holes' l x)
-- propId x = 'all' ('==' x) ['Control.Lens.Internal.Context.extract' w | w <- 'holes' l x]
-- @
--
-- @
-- 'holes' = 'holesOf' 'plate'
-- @
holes :: Plated a => a -> [Pretext (->) a a a]
holes :: a -> [Pretext (->) a a a]
holes = Over (->) (Bazaar (->) a a) a a a a -> a -> [Pretext (->) a a a]
forall (p :: * -> * -> *) a s t.
Conjoined p =>
Over p (Bazaar p a a) s t a a -> s -> [Pretext p a a t]
holesOf Over (->) (Bazaar (->) a a) a a a a
forall a. Plated a => Traversal' a a
plate
{-# INLINE holes #-}

-- | An alias for 'holesOf', provided for consistency with the other combinators.
--
-- @
-- 'holesOn' ≡ 'holesOf'
-- @
--
-- @
-- 'holesOn' :: 'Iso'' s a                -> s -> ['Pretext' (->) a a s]
-- 'holesOn' :: 'Lens'' s a               -> s -> ['Pretext' (->) a a s]
-- 'holesOn' :: 'Traversal'' s a          -> s -> ['Pretext' (->) a a s]
-- 'holesOn' :: 'IndexedLens'' i s a      -> s -> ['Pretext' ('Control.Lens.Internal.Indexed.Indexed' i) a a s]
-- 'holesOn' :: 'IndexedTraversal'' i s a -> s -> ['Pretext' ('Control.Lens.Internal.Indexed.Indexed' i) a a s]
-- @
holesOn :: Conjoined p => Over p (Bazaar p a a) s t a a -> s -> [Pretext p a a t]
holesOn :: Over p (Bazaar p a a) s t a a -> s -> [Pretext p a a t]
holesOn = Over p (Bazaar p a a) s t a a -> s -> [Pretext p a a t]
forall (p :: * -> * -> *) a s t.
Conjoined p =>
Over p (Bazaar p a a) s t a a -> s -> [Pretext p a a t]
holesOf
{-# INLINE holesOn #-}

-- | Extract one level of 'holes' from a container in a region specified by one 'Traversal', using another.
--
-- @
-- 'holesOnOf' b l ≡ 'holesOf' (b '.' l)
-- @
--
-- @
-- 'holesOnOf' :: 'Iso'' s a       -> 'Iso'' a a                -> s -> ['Pretext' (->) a a s]
-- 'holesOnOf' :: 'Lens'' s a      -> 'Lens'' a a               -> s -> ['Pretext' (->) a a s]
-- 'holesOnOf' :: 'Traversal'' s a -> 'Traversal'' a a          -> s -> ['Pretext' (->) a a s]
-- 'holesOnOf' :: 'Lens'' s a      -> 'IndexedLens'' i a a      -> s -> ['Pretext' ('Control.Lens.Internal.Indexed.Indexed' i) a a s]
-- 'holesOnOf' :: 'Traversal'' s a -> 'IndexedTraversal'' i a a -> s -> ['Pretext' ('Control.Lens.Internal.Indexed.Indexed' i) a a s]
-- @
holesOnOf :: Conjoined p
          => LensLike (Bazaar p  r r) s t a b
          -> Over p (Bazaar p r r) a b r r
          -> s -> [Pretext p r r t]
holesOnOf :: LensLike (Bazaar p r r) s t a b
-> Over p (Bazaar p r r) a b r r -> s -> [Pretext p r r t]
holesOnOf LensLike (Bazaar p r r) s t a b
b Over p (Bazaar p r r) a b r r
l = Over p (Bazaar p r r) s t r r -> s -> [Pretext p r r t]
forall (p :: * -> * -> *) a s t.
Conjoined p =>
Over p (Bazaar p a a) s t a a -> s -> [Pretext p a a t]
holesOf (LensLike (Bazaar p r r) s t a b
b LensLike (Bazaar p r r) s t a b
-> Over p (Bazaar p r r) a b r r -> Over p (Bazaar p r r) s t r r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Over p (Bazaar p r r) a b r r
l)
{-# INLINE holesOnOf #-}

-------------------------------------------------------------------------------
-- Paramorphisms
-------------------------------------------------------------------------------

-- | Perform a fold-like computation on each value, technically a paramorphism.
--
-- @
-- 'paraOf' :: 'Fold' a a -> (a -> [r] -> r) -> a -> r
-- @
paraOf :: Getting (Endo [a]) a a -> (a -> [r] -> r) -> a -> r
paraOf :: Getting (Endo [a]) a a -> (a -> [r] -> r) -> a -> r
paraOf Getting (Endo [a]) a a
l a -> [r] -> r
f = a -> r
go where
  go :: a -> r
go a
a = a -> [r] -> r
f a
a (a -> r
go (a -> r) -> [a] -> [r]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting (Endo [a]) a a -> a -> [a]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf Getting (Endo [a]) a a
l a
a)
{-# INLINE paraOf #-}

-- | Perform a fold-like computation on each value, technically a paramorphism.
--
-- @
-- 'para' ≡ 'paraOf' 'plate'
-- @
para :: Plated a => (a -> [r] -> r) -> a -> r
para :: (a -> [r] -> r) -> a -> r
para = Getting (Endo [a]) a a -> (a -> [r] -> r) -> a -> r
forall a r. Getting (Endo [a]) a a -> (a -> [r] -> r) -> a -> r
paraOf Getting (Endo [a]) a a
forall a. Plated a => Traversal' a a
plate
{-# INLINE para #-}

-------------------------------------------------------------------------------
-- Compos
-------------------------------------------------------------------------------

-- $compos
--
-- Provided for compatibility with Björn Bringert's @compos@ library.
--
-- Note: Other operations from compos that were inherited by @uniplate@ are /not/ included
-- to avoid having even more redundant names for the same operators. For comparison:
--
-- @
-- 'composOpMonoid' ≡ 'foldMapOf' 'plate'
-- 'composOpMPlus' f ≡ 'msumOf' ('plate' '.' 'to' f)
-- 'composOp' ≡ 'descend' ≡ 'over' 'plate'
-- 'composOpM' ≡ 'descendM' ≡ 'mapMOf' 'plate'
-- 'composOpM_' ≡ 'descendM_' ≡ 'mapMOf_' 'plate'
-- @

-- | Fold the immediate children of a 'Plated' container.
--
-- @
-- 'composOpFold' z c f = 'foldrOf' 'plate' (c '.' f) z
-- @
composOpFold :: Plated a => b -> (b -> b -> b) -> (a -> b) -> a -> b
composOpFold :: b -> (b -> b -> b) -> (a -> b) -> a -> b
composOpFold b
z b -> b -> b
c a -> b
f = Getting (Endo b) a a -> (a -> b -> b) -> b -> a -> b
forall r s a. Getting (Endo r) s a -> (a -> r -> r) -> r -> s -> r
foldrOf Getting (Endo b) a a
forall a. Plated a => Traversal' a a
plate (b -> b -> b
c (b -> b -> b) -> (a -> b) -> a -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f) b
z
{-# INLINE composOpFold #-}

-------------------------------------------------------------------------------
-- Parts
-------------------------------------------------------------------------------

-- | The original @uniplate@ combinator, implemented in terms of 'Plated' as a 'Lens'.
--
-- @
-- 'parts' ≡ 'partsOf' 'plate'
-- @
--
-- The resulting 'Lens' is safer to use as it ignores 'over-application' and deals gracefully with under-application,
-- but it is only a proper 'Lens' if you don't change the list 'length'!
parts :: Plated a => Lens' a [a]
parts :: Lens' a [a]
parts = Traversing (->) f a a a a -> LensLike f a a [a] [a]
forall (f :: * -> *) s t a.
Functor f =>
Traversing (->) f s t a a -> LensLike f s t [a] [a]
partsOf Traversing (->) f a a a a
forall a. Plated a => Traversal' a a
plate
{-# INLINE parts #-}

-------------------------------------------------------------------------------
-- Generics
-------------------------------------------------------------------------------

-- | Implement 'plate' operation for a type using its 'Generic' instance.
--
-- Note: the behavior may be different than with 'uniplate' in some special cases.
-- 'gplate' doesn't look through other types in a group of mutually
-- recursive types.
--
-- For example consider mutually recursive even and odd natural numbers:
--
-- >>> data Even = Z | E Odd deriving (Show, Generic, Data); data Odd = O Even deriving (Show, Generic, Data)
--
-- Then 'uniplate', which is based on `Data`, finds
-- all even numbers less or equal than four:
--
-- >>> import Data.Data.Lens (uniplate)
-- >>> universeOf uniplate (E (O (E (O Z))))
-- [E (O (E (O Z))),E (O Z),Z]
--
-- but 'gplate' doesn't see through @Odd@.
--
-- >>> universeOf gplate (E (O (E (O Z))))
-- [E (O (E (O Z)))]
--
-- If using 'Data' is not an option, you can still write the traversal manually.
-- It is sometimes useful to use helper traversals
--
-- >>> :{
-- let oddeven :: Traversal' Odd Even
--     oddeven f (O n) = O <$> f n
--     evenplate :: Traversal' Even Even
--     evenplate f Z     = pure Z
--     evenplate f (E n) = E <$> oddeven f n
-- :}
--
-- >>> universeOf evenplate (E (O (E (O Z))))
-- [E (O (E (O Z))),E (O Z),Z]
--
gplate :: (Generic a, GPlated a (Rep a)) => Traversal' a a
gplate :: Traversal' a a
gplate a -> f a
f a
x = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
GHC.Generics.to (Rep a Any -> a) -> f (Rep a Any) -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f a) -> Rep a Any -> f (Rep a Any)
forall k a (g :: k -> *) (p :: k).
GPlated a g =>
Traversal' (g p) a
gplate' a -> f a
f (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
GHC.Generics.from a
x)
{-# INLINE gplate #-}

class GPlated a g where
  gplate' :: Traversal' (g p) a

instance GPlated a f => GPlated a (M1 i c f) where
  gplate' :: (a -> f a) -> M1 i c f p -> f (M1 i c f p)
gplate' a -> f a
f (M1 f p
x) = f p -> M1 i c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 i c f p) -> f (f p) -> f (M1 i c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f a) -> f p -> f (f p)
forall k a (g :: k -> *) (p :: k).
GPlated a g =>
Traversal' (g p) a
gplate' a -> f a
f f p
x
  {-# INLINE gplate' #-}

instance (GPlated a f, GPlated a g) => GPlated a (f :+: g) where
  gplate' :: (a -> f a) -> (:+:) f g p -> f ((:+:) f g p)
gplate' a -> f a
f (L1 f p
x) = f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f p -> (:+:) f g p) -> f (f p) -> f ((:+:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f a) -> f p -> f (f p)
forall k a (g :: k -> *) (p :: k).
GPlated a g =>
Traversal' (g p) a
gplate' a -> f a
f f p
x
  gplate' a -> f a
f (R1 g p
x) = g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g p -> (:+:) f g p) -> f (g p) -> f ((:+:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f a) -> g p -> f (g p)
forall k a (g :: k -> *) (p :: k).
GPlated a g =>
Traversal' (g p) a
gplate' a -> f a
f g p
x
  {-# INLINE gplate' #-}

instance (GPlated a f, GPlated a g) => GPlated a (f :*: g) where
  gplate' :: (a -> f a) -> (:*:) f g p -> f ((:*:) f g p)
gplate' a -> f a
f (f p
x :*: g p
y) = f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (f p -> g p -> (:*:) f g p) -> f (f p) -> f (g p -> (:*:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f a) -> f p -> f (f p)
forall k a (g :: k -> *) (p :: k).
GPlated a g =>
Traversal' (g p) a
gplate' a -> f a
f f p
x f (g p -> (:*:) f g p) -> f (g p) -> f ((:*:) f g p)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> f a) -> g p -> f (g p)
forall k a (g :: k -> *) (p :: k).
GPlated a g =>
Traversal' (g p) a
gplate' a -> f a
f g p
y
  {-# INLINE gplate' #-}

instance {-# OVERLAPPING #-} GPlated a (K1 i a) where
  gplate' :: (a -> f a) -> K1 i a p -> f (K1 i a p)
gplate' a -> f a
f (K1 a
x) = a -> K1 i a p
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a p) -> f a -> f (K1 i a p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f a
f a
x
  {-# INLINE gplate' #-}

instance GPlated a (K1 i b) where
  gplate' :: (a -> f a) -> K1 i b p -> f (K1 i b p)
gplate' a -> f a
_ = K1 i b p -> f (K1 i b p)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE gplate' #-}

instance GPlated a U1 where
  gplate' :: (a -> f a) -> U1 p -> f (U1 p)
gplate' a -> f a
_ = U1 p -> f (U1 p)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE gplate' #-}

instance GPlated a V1 where
  gplate' :: (a -> f a) -> V1 p -> f (V1 p)
gplate' a -> f a
_ V1 p
v = V1 p
v V1 p -> f (V1 p) -> f (V1 p)
`seq` [Char] -> f (V1 p)
forall a. HasCallStack => [Char] -> a
error [Char]
"GPlated/V1"
  {-# INLINE gplate' #-}

instance GPlated a (URec b) where
  gplate' :: (a -> f a) -> URec b p -> f (URec b p)
gplate' a -> f a
_ = URec b p -> f (URec b p)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE gplate' #-}

-- | Implement 'plate' operation for a type using its 'Generic1' instance.
gplate1 :: (Generic1 f, GPlated1 f (Rep1 f)) => Traversal' (f a) (f a)
gplate1 :: Traversal' (f a) (f a)
gplate1 f a -> f (f a)
f f a
x = Rep1 f a -> f a
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
GHC.Generics.to1 (Rep1 f a -> f a) -> f (Rep1 f a) -> f (f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (f a -> f (f a)) -> Rep1 f a -> f (Rep1 f a)
forall k (f :: k -> *) (g :: k -> *) (a :: k).
GPlated1 f g =>
Traversal' (g a) (f a)
gplate1' f a -> f (f a)
f (f a -> Rep1 f a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
GHC.Generics.from1 f a
x)
{-# INLINE gplate1 #-}

class GPlated1 f g where
  gplate1' :: Traversal' (g a) (f a)

-- | recursive match
instance GPlated1 f g => GPlated1 f (M1 i c g) where
  gplate1' :: (f a -> f (f a)) -> M1 i c g a -> f (M1 i c g a)
gplate1' f a -> f (f a)
f (M1 g a
x) = g a -> M1 i c g a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (g a -> M1 i c g a) -> f (g a) -> f (M1 i c g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (f a -> f (f a)) -> g a -> f (g a)
forall k (f :: k -> *) (g :: k -> *) (a :: k).
GPlated1 f g =>
Traversal' (g a) (f a)
gplate1' f a -> f (f a)
f g a
x
  {-# INLINE gplate1' #-}

-- | recursive match
instance (GPlated1 f g, GPlated1 f h) => GPlated1 f (g :+: h) where
  gplate1' :: (f a -> f (f a)) -> (:+:) g h a -> f ((:+:) g h a)
gplate1' f a -> f (f a)
f (L1 g a
x) = g a -> (:+:) g h a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (g a -> (:+:) g h a) -> f (g a) -> f ((:+:) g h a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (f a -> f (f a)) -> g a -> f (g a)
forall k (f :: k -> *) (g :: k -> *) (a :: k).
GPlated1 f g =>
Traversal' (g a) (f a)
gplate1' f a -> f (f a)
f g a
x
  gplate1' f a -> f (f a)
f (R1 h a
x) = h a -> (:+:) g h a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (h a -> (:+:) g h a) -> f (h a) -> f ((:+:) g h a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (f a -> f (f a)) -> h a -> f (h a)
forall k (f :: k -> *) (g :: k -> *) (a :: k).
GPlated1 f g =>
Traversal' (g a) (f a)
gplate1' f a -> f (f a)
f h a
x
  {-# INLINE gplate1' #-}

-- | recursive match
instance (GPlated1 f g, GPlated1 f h) => GPlated1 f (g :*: h) where
  gplate1' :: (f a -> f (f a)) -> (:*:) g h a -> f ((:*:) g h a)
gplate1' f a -> f (f a)
f (g a
x :*: h a
y) = g a -> h a -> (:*:) g h a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (g a -> h a -> (:*:) g h a) -> f (g a) -> f (h a -> (:*:) g h a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (f a -> f (f a)) -> g a -> f (g a)
forall k (f :: k -> *) (g :: k -> *) (a :: k).
GPlated1 f g =>
Traversal' (g a) (f a)
gplate1' f a -> f (f a)
f g a
x f (h a -> (:*:) g h a) -> f (h a) -> f ((:*:) g h a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (f a -> f (f a)) -> h a -> f (h a)
forall k (f :: k -> *) (g :: k -> *) (a :: k).
GPlated1 f g =>
Traversal' (g a) (f a)
gplate1' f a -> f (f a)
f h a
y
  {-# INLINE gplate1' #-}

-- | ignored
instance GPlated1 f (K1 i a) where
  gplate1' :: (f a -> f (f a)) -> K1 i a a -> f (K1 i a a)
gplate1' f a -> f (f a)
_ = K1 i a a -> f (K1 i a a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE gplate1' #-}

-- | ignored
instance GPlated1 f Par1 where
  gplate1' :: (f a -> f (f a)) -> Par1 a -> f (Par1 a)
gplate1' f a -> f (f a)
_ = Par1 a -> f (Par1 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE gplate1' #-}

-- | ignored
instance GPlated1 f U1 where
  gplate1' :: (f a -> f (f a)) -> U1 a -> f (U1 a)
gplate1' f a -> f (f a)
_ = U1 a -> f (U1 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE gplate1' #-}

-- | ignored
instance GPlated1 f V1 where
  gplate1' :: (f a -> f (f a)) -> V1 a -> f (V1 a)
gplate1' f a -> f (f a)
_ = V1 a -> f (V1 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE gplate1' #-}

-- | match
instance {-# OVERLAPPING #-} GPlated1 f (Rec1 f) where
  gplate1' :: (f a -> f (f a)) -> Rec1 f a -> f (Rec1 f a)
gplate1' f a -> f (f a)
f (Rec1 f a
x) = f a -> Rec1 f a
forall k (f :: k -> *) (p :: k). f p -> Rec1 f p
Rec1 (f a -> Rec1 f a) -> f (f a) -> f (Rec1 f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a -> f (f a)
f f a
x
  {-# INLINE gplate1' #-}

-- | ignored
instance GPlated1 f (Rec1 g) where
  gplate1' :: (f a -> f (f a)) -> Rec1 g a -> f (Rec1 g a)
gplate1' f a -> f (f a)
_ = Rec1 g a -> f (Rec1 g a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE gplate1' #-}

-- | recursive match under outer 'Traversable' instance
instance (Traversable t, GPlated1 f g) => GPlated1 f (t :.: g) where
  gplate1' :: (f a -> f (f a)) -> (:.:) t g a -> f ((:.:) t g a)
gplate1' f a -> f (f a)
f (Comp1 t (g a)
x) = t (g a) -> (:.:) t g a
forall k2 k1 (f :: k2 -> *) (g :: k1 -> k2) (p :: k1).
f (g p) -> (:.:) f g p
Comp1 (t (g a) -> (:.:) t g a) -> f (t (g a)) -> f ((:.:) t g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (g a -> f (g a)) -> t (g a) -> f (t (g a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((f a -> f (f a)) -> g a -> f (g a)
forall k (f :: k -> *) (g :: k -> *) (a :: k).
GPlated1 f g =>
Traversal' (g a) (f a)
gplate1' f a -> f (f a)
f) t (g a)
x
  {-# INLINE gplate1' #-}

-- | ignored
instance GPlated1 f (URec a) where
  gplate1' :: (f a -> f (f a)) -> URec a a -> f (URec a a)
gplate1' f a -> f (f a)
_ = URec a a -> f (URec a a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE gplate1' #-}