{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
-- |
-- Module: Language.KURE.Walker
-- Copyright: (c) 2012--2021 The University of Kansas
-- License: BSD3
--
-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>
-- Stability: beta
-- Portability: ghc
--
-- This module provides combinators that traverse a tree.
--
-- Note that all traversals take place on the node, its children, or its descendents.
-- Deliberately, there is no mechanism for \"ascending\" the tree.

module Language.KURE.Walker
        (
        -- * Shallow Traversals

        -- ** Tree Walkers
          Walker(..)
        -- ** Child Transformations
        , childR
        , childT

        -- * Deep Traversals

        -- ** Traversals for Rewrites
        , alltdR
        , allbuR
        , allduR
        , anytdR
        , anybuR
        , anyduR
        , onetdR
        , onebuR
        , prunetdR
        , innermostR
        , allLargestR
        , anyLargestR
        , oneLargestR

        -- ** Traversals for Transformations
        , foldtdT
        , foldbuT
        , onetdT
        , onebuT
        , prunetdT
        , crushtdT
        , crushbuT
        , collectT
        , collectPruneT
        , allLargestT
        , oneLargestT

        -- * Utilitity Transformations
        , childrenT
        , summandIsTypeT

        -- * Paths
        -- ** Building Lenses from Paths
        , pathL
        , localPathL
        , exhaustPathL
        , repeatPathL
        -- ** Applying transformations at the end of Paths
        , pathR
        , pathT
        , localPathR
        , localPathT
        -- ** Testing Paths
        , testPathT
) where

import Prelude hiding (id)

import Data.Maybe (isJust)
import Data.Monoid ()
import Data.DList (singleton, toList)

import Control.Arrow
import Control.Category hiding ((.))
import Control.Monad (liftM, ap, mplus)

#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail)
import qualified Control.Monad.Fail
#endif

import Language.KURE.MonadCatch
import Language.KURE.Transform
import Language.KURE.Lens
import Language.KURE.Injection
import Language.KURE.Combinators
import Language.KURE.Path

-------------------------------------------------------------------------------

-- | 'Walker' captures the ability to walk over a tree containing nodes of type @u@,
--   using a specific context @c@.
--
--   Minimal complete definition: 'allR'.
--
--   Default definitions are provided for 'anyR', 'oneR', 'allT', 'oneT', and 'childL',
--   but they may be overridden for efficiency.

class Walker c u where
  -- | Apply a rewrite to all immediate children, succeeding if they all succeed.
  allR :: MonadCatch m => Rewrite c m u -> Rewrite c m u

  -- | Apply a transformation to all immediate children, succeeding if they all succeed.
  --   The results are combined in a 'Monoid'.
  allT :: (MonadCatch m, Monoid b) => Transform c m u b -> Transform c m u b
  allT = Rewrite c (AllT b m) u -> Transform c m u b
forall (m :: * -> *) c b u.
MonadCatch m =>
Rewrite c (AllT b m) u -> Transform c m u b
unwrapAllT (Rewrite c (AllT b m) u -> Transform c m u b)
-> (Transform c m u b -> Rewrite c (AllT b m) u)
-> Transform c m u b
-> Transform c m u b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rewrite c (AllT b m) u -> Rewrite c (AllT b m) u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
allR (Rewrite c (AllT b m) u -> Rewrite c (AllT b m) u)
-> (Transform c m u b -> Rewrite c (AllT b m) u)
-> Transform c m u b
-> Rewrite c (AllT b m) u
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transform c m u b -> Rewrite c (AllT b m) u
forall (m :: * -> *) c u b.
Monad m =>
Transform c m u b -> Rewrite c (AllT b m) u
wrapAllT
  {-# INLINE allT #-}

  -- | Apply a transformation to the first immediate child for which it can succeed.
  oneT :: MonadCatch m => Transform c m u b -> Transform c m u b
  oneT = Rewrite c (OneT b m) u -> Transform c m u b
forall (m :: * -> *) c b u.
MonadFail m =>
Rewrite c (OneT b m) u -> Transform c m u b
unwrapOneT (Rewrite c (OneT b m) u -> Transform c m u b)
-> (Transform c m u b -> Rewrite c (OneT b m) u)
-> Transform c m u b
-> Transform c m u b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rewrite c (OneT b m) u -> Rewrite c (OneT b m) u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
allR (Rewrite c (OneT b m) u -> Rewrite c (OneT b m) u)
-> (Transform c m u b -> Rewrite c (OneT b m) u)
-> Transform c m u b
-> Rewrite c (OneT b m) u
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transform c m u b -> Rewrite c (OneT b m) u
forall (m :: * -> *) c u b.
MonadCatch m =>
Transform c m u b -> Rewrite c (OneT b m) u
wrapOneT
  {-# INLINE oneT #-}

  -- | Apply a rewrite to all immediate children, suceeding if any succeed.
  anyR :: MonadCatch m => Rewrite c m u -> Rewrite c m u
  anyR = Rewrite c (AnyR m) u -> Rewrite c m u
forall (m :: * -> *) c a.
MonadFail m =>
Rewrite c (AnyR m) a -> Rewrite c m a
unwrapAnyR (Rewrite c (AnyR m) u -> Rewrite c m u)
-> (Rewrite c m u -> Rewrite c (AnyR m) u)
-> Rewrite c m u
-> Rewrite c m u
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rewrite c (AnyR m) u -> Rewrite c (AnyR m) u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
allR (Rewrite c (AnyR m) u -> Rewrite c (AnyR m) u)
-> (Rewrite c m u -> Rewrite c (AnyR m) u)
-> Rewrite c m u
-> Rewrite c (AnyR m) u
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rewrite c m u -> Rewrite c (AnyR m) u
forall (m :: * -> *) c a.
MonadCatch m =>
Rewrite c m a -> Rewrite c (AnyR m) a
wrapAnyR
  {-# INLINE anyR #-}

  -- | Apply a rewrite to the first immediate child for which it can succeed.
  oneR :: MonadCatch m => Rewrite c m u -> Rewrite c m u
  oneR = Rewrite c (OneR m) u -> Rewrite c m u
forall (m :: * -> *) c a.
MonadFail m =>
Rewrite c (OneR m) a -> Rewrite c m a
unwrapOneR (Rewrite c (OneR m) u -> Rewrite c m u)
-> (Rewrite c m u -> Rewrite c (OneR m) u)
-> Rewrite c m u
-> Rewrite c m u
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rewrite c (OneR m) u -> Rewrite c (OneR m) u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
allR (Rewrite c (OneR m) u -> Rewrite c (OneR m) u)
-> (Rewrite c m u -> Rewrite c (OneR m) u)
-> Rewrite c m u
-> Rewrite c (OneR m) u
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rewrite c m u -> Rewrite c (OneR m) u
forall (m :: * -> *) c g.
MonadCatch m =>
Rewrite c m g -> Rewrite c (OneR m) g
wrapOneR
  {-# INLINE oneR #-}

  -- | Construct a 'Lens' to the n-th child node.
  childL :: (ReadPath c crumb, Eq crumb, MonadCatch m) => crumb -> Lens c m u u
  childL = crumb -> Lens c m u u
forall c crumb (m :: * -> *) u.
(ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) =>
crumb -> Lens c m u u
childL_default
  {-# INLINE childL #-}

------------------------------------------------------------------------------------------

-- | List the children of the current node.
childrenT :: (ReadPath c crumb, Walker c u, MonadCatch m) => Transform c m u [crumb]
childrenT :: Transform c m u [crumb]
childrenT = Transform c m u [crumb] -> Transform c m u [crumb]
forall c u (m :: * -> *) b.
(Walker c u, MonadCatch m, Monoid b) =>
Transform c m u b -> Transform c m u b
allT (Transform c m u crumb
forall c crumb (m :: * -> *) a.
(ReadPath c crumb, MonadFail m) =>
Transform c m a crumb
lastCrumbT Transform c m u crumb
-> (crumb -> [crumb]) -> Transform c m u [crumb]
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ crumb -> [crumb]
forall (m :: * -> *) a. Monad m => a -> m a
return)
{-# INLINE childrenT #-}

-------------------------------------------------------------------------------

-- | Apply a transformation to a specified child.
childT :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => crumb -> Transform c m u b -> Transform c m u b
childT :: crumb -> Transform c m u b -> Transform c m u b
childT crumb
n = Lens c m u u -> Transform c m u b -> Transform c m u b
forall (m :: * -> *) c a b d.
Monad m =>
Lens c m a b -> Transform c m b d -> Transform c m a d
focusT (crumb -> Lens c m u u
forall c u crumb (m :: * -> *).
(Walker c u, ReadPath c crumb, Eq crumb, MonadCatch m) =>
crumb -> Lens c m u u
childL crumb
n)
{-# INLINE childT #-}

-- | Apply a rewrite to a specified child.
childR :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => crumb -> Rewrite c m u -> Rewrite c m u
childR :: crumb -> Rewrite c m u -> Rewrite c m u
childR crumb
n = Lens c m u u -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) c a b.
Monad m =>
Lens c m a b -> Rewrite c m b -> Rewrite c m a
focusR (crumb -> Lens c m u u
forall c u crumb (m :: * -> *).
(Walker c u, ReadPath c crumb, Eq crumb, MonadCatch m) =>
crumb -> Lens c m u u
childL crumb
n)
{-# INLINE childR #-}

-------------------------------------------------------------------------------

-- | Fold a tree in a top-down manner, using a single 'Transform' for each node.
foldtdT :: (Walker c u, MonadCatch m, Monoid b) => Transform c m u b -> Transform c m u b
foldtdT :: Transform c m u b -> Transform c m u b
foldtdT Transform c m u b
t = String -> Transform c m u b -> Transform c m u b
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
prefixFailMsg String
"foldtdT failed: " (Transform c m u b -> Transform c m u b)
-> Transform c m u b -> Transform c m u b
forall a b. (a -> b) -> a -> b
$
            let go :: Transform c m u b
go = Transform c m u b
t Transform c m u b -> Transform c m u b -> Transform c m u b
forall a. Semigroup a => a -> a -> a
<> Transform c m u b -> Transform c m u b
forall c u (m :: * -> *) b.
(Walker c u, MonadCatch m, Monoid b) =>
Transform c m u b -> Transform c m u b
allT Transform c m u b
go
             in Transform c m u b
go
{-# INLINE foldtdT #-}

-- | Fold a tree in a bottom-up manner, using a single 'Transform' for each node.
foldbuT :: (Walker c u, MonadCatch m, Monoid b) => Transform c m u b -> Transform c m u b
foldbuT :: Transform c m u b -> Transform c m u b
foldbuT Transform c m u b
t = String -> Transform c m u b -> Transform c m u b
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
prefixFailMsg String
"foldbuT failed: " (Transform c m u b -> Transform c m u b)
-> Transform c m u b -> Transform c m u b
forall a b. (a -> b) -> a -> b
$
            let go :: Transform c m u b
go = Transform c m u b -> Transform c m u b
forall c u (m :: * -> *) b.
(Walker c u, MonadCatch m, Monoid b) =>
Transform c m u b -> Transform c m u b
allT Transform c m u b
go Transform c m u b -> Transform c m u b -> Transform c m u b
forall a. Semigroup a => a -> a -> a
<> Transform c m u b
t
             in Transform c m u b
go
{-# INLINE foldbuT #-}

-- | Apply a transformation to the first node for which it can succeed, in a top-down traversal.
onetdT :: (Walker c u, MonadCatch m) => Transform c m u b -> Transform c m u b
onetdT :: Transform c m u b -> Transform c m u b
onetdT Transform c m u b
t = String -> Transform c m u b -> Transform c m u b
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
setFailMsg String
"onetdT failed" (Transform c m u b -> Transform c m u b)
-> Transform c m u b -> Transform c m u b
forall a b. (a -> b) -> a -> b
$
           let go :: Transform c m u b
go = Transform c m u b
t Transform c m u b -> Transform c m u b -> Transform c m u b
forall (m :: * -> *) a. MonadCatch m => m a -> m a -> m a
<+ Transform c m u b -> Transform c m u b
forall c u (m :: * -> *) b.
(Walker c u, MonadCatch m) =>
Transform c m u b -> Transform c m u b
oneT Transform c m u b
go
            in Transform c m u b
go
{-# INLINE onetdT #-}

-- | Apply a transformation to the first node for which it can succeed, in a bottom-up traversal.
onebuT :: (Walker c u, MonadCatch m) => Transform c m u b -> Transform c m u b
onebuT :: Transform c m u b -> Transform c m u b
onebuT Transform c m u b
t = String -> Transform c m u b -> Transform c m u b
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
setFailMsg String
"onebuT failed" (Transform c m u b -> Transform c m u b)
-> Transform c m u b -> Transform c m u b
forall a b. (a -> b) -> a -> b
$
           let go :: Transform c m u b
go = Transform c m u b -> Transform c m u b
forall c u (m :: * -> *) b.
(Walker c u, MonadCatch m) =>
Transform c m u b -> Transform c m u b
oneT Transform c m u b
go Transform c m u b -> Transform c m u b -> Transform c m u b
forall (m :: * -> *) a. MonadCatch m => m a -> m a -> m a
<+ Transform c m u b
t
            in Transform c m u b
go
{-# INLINE onebuT #-}

-- | Attempt to apply a 'Transform' in a top-down manner, pruning at successes.
prunetdT :: (Walker c u, MonadCatch m, Monoid b) => Transform c m u b -> Transform c m u b
prunetdT :: Transform c m u b -> Transform c m u b
prunetdT Transform c m u b
t = String -> Transform c m u b -> Transform c m u b
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
setFailMsg String
"prunetdT failed" (Transform c m u b -> Transform c m u b)
-> Transform c m u b -> Transform c m u b
forall a b. (a -> b) -> a -> b
$
             let go :: Transform c m u b
go = Transform c m u b
t Transform c m u b -> Transform c m u b -> Transform c m u b
forall (m :: * -> *) a. MonadCatch m => m a -> m a -> m a
<+ Transform c m u b -> Transform c m u b
forall c u (m :: * -> *) b.
(Walker c u, MonadCatch m, Monoid b) =>
Transform c m u b -> Transform c m u b
allT Transform c m u b
go
              in Transform c m u b
go
{-# INLINE prunetdT #-}

-- | An always successful top-down fold, replacing failures with 'mempty'.
crushtdT :: (Walker c u, MonadCatch m, Monoid b) => Transform c m u b -> Transform c m u b
crushtdT :: Transform c m u b -> Transform c m u b
crushtdT Transform c m u b
t = Transform c m u b -> Transform c m u b
forall c u (m :: * -> *) b.
(Walker c u, MonadCatch m, Monoid b) =>
Transform c m u b -> Transform c m u b
foldtdT (Transform c m u b -> Transform c m u b
forall (m :: * -> *) a. (MonadCatch m, Monoid a) => m a -> m a
mtryM Transform c m u b
t)
{-# INLINE crushtdT #-}

-- | An always successful bottom-up fold, replacing failures with 'mempty'.
crushbuT :: (Walker c u, MonadCatch m, Monoid b) => Transform c m u b -> Transform c m u b
crushbuT :: Transform c m u b -> Transform c m u b
crushbuT Transform c m u b
t = Transform c m u b -> Transform c m u b
forall c u (m :: * -> *) b.
(Walker c u, MonadCatch m, Monoid b) =>
Transform c m u b -> Transform c m u b
foldbuT (Transform c m u b -> Transform c m u b
forall (m :: * -> *) a. (MonadCatch m, Monoid a) => m a -> m a
mtryM Transform c m u b
t)
{-# INLINE crushbuT #-}

-- | An always successful traversal that collects the results of all successful applications of a 'Transform' in a list.
collectT :: (Walker c u, MonadCatch m) => Transform c m u b -> Transform c m u [b]
collectT :: Transform c m u b -> Transform c m u [b]
collectT Transform c m u b
t = Transform c m u (DList b) -> Transform c m u (DList b)
forall c u (m :: * -> *) b.
(Walker c u, MonadCatch m, Monoid b) =>
Transform c m u b -> Transform c m u b
crushtdT (Transform c m u b
t Transform c m u b -> (b -> DList b) -> Transform c m u (DList b)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ b -> DList b
forall a. a -> DList a
singleton) Transform c m u (DList b)
-> (DList b -> [b]) -> Transform c m u [b]
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ DList b -> [b]
forall a. DList a -> [a]
toList
{-# INLINE collectT #-}

-- | Like 'collectT', but does not traverse below successes.
collectPruneT :: (Walker c u, MonadCatch m) => Transform c m u b -> Transform c m u [b]
collectPruneT :: Transform c m u b -> Transform c m u [b]
collectPruneT Transform c m u b
t = Transform c m u (DList b) -> Transform c m u (DList b)
forall c u (m :: * -> *) b.
(Walker c u, MonadCatch m, Monoid b) =>
Transform c m u b -> Transform c m u b
prunetdT (Transform c m u b
t Transform c m u b -> (b -> DList b) -> Transform c m u (DList b)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ b -> DList b
forall a. a -> DList a
singleton) Transform c m u (DList b)
-> (DList b -> [b]) -> Transform c m u [b]
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ DList b -> [b]
forall a. DList a -> [a]
toList
{-# INLINE collectPruneT #-}

-------------------------------------------------------------------------------

-- | Apply a rewrite in a top-down manner, succeeding if they all succeed.
alltdR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
alltdR :: Rewrite c m u -> Rewrite c m u
alltdR Rewrite c m u
r = String -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
prefixFailMsg String
"alltdR failed: " (Rewrite c m u -> Rewrite c m u) -> Rewrite c m u -> Rewrite c m u
forall a b. (a -> b) -> a -> b
$
           let go :: Rewrite c m u
go = Rewrite c m u
r Rewrite c m u -> Rewrite c m u -> Rewrite c m u
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Rewrite c m u -> Rewrite c m u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
allR Rewrite c m u
go
            in Rewrite c m u
go
{-# INLINE alltdR #-}

-- | Apply a rewrite in a bottom-up manner, succeeding if they all succeed.
allbuR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
allbuR :: Rewrite c m u -> Rewrite c m u
allbuR Rewrite c m u
r = String -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
prefixFailMsg String
"allbuR failed: " (Rewrite c m u -> Rewrite c m u) -> Rewrite c m u -> Rewrite c m u
forall a b. (a -> b) -> a -> b
$
           let go :: Rewrite c m u
go = Rewrite c m u -> Rewrite c m u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
allR Rewrite c m u
go Rewrite c m u -> Rewrite c m u -> Rewrite c m u
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Rewrite c m u
r
            in Rewrite c m u
go
{-# INLINE allbuR #-}

-- | Apply a rewrite twice, in a top-down and bottom-up way, using one single tree traversal,
--   succeeding if they all succeed.
allduR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
allduR :: Rewrite c m u -> Rewrite c m u
allduR Rewrite c m u
r = String -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
prefixFailMsg String
"allduR failed: " (Rewrite c m u -> Rewrite c m u) -> Rewrite c m u -> Rewrite c m u
forall a b. (a -> b) -> a -> b
$
           let go :: Rewrite c m u
go = Rewrite c m u
r Rewrite c m u -> Rewrite c m u -> Rewrite c m u
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Rewrite c m u -> Rewrite c m u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
allR Rewrite c m u
go Rewrite c m u -> Rewrite c m u -> Rewrite c m u
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Rewrite c m u
r
            in Rewrite c m u
go
{-# INLINE allduR #-}

-- | Apply a rewrite in a top-down manner, succeeding if any succeed.
anytdR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
anytdR :: Rewrite c m u -> Rewrite c m u
anytdR Rewrite c m u
r = String -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
setFailMsg String
"anytdR failed" (Rewrite c m u -> Rewrite c m u) -> Rewrite c m u -> Rewrite c m u
forall a b. (a -> b) -> a -> b
$
           let go :: Rewrite c m u
go = Rewrite c m u
r Rewrite c m u -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) c a.
MonadCatch m =>
Rewrite c m a -> Rewrite c m a -> Rewrite c m a
>+> Rewrite c m u -> Rewrite c m u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
anyR Rewrite c m u
go
            in Rewrite c m u
go
{-# INLINE anytdR #-}

-- | Apply a rewrite in a bottom-up manner, succeeding if any succeed.
anybuR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
anybuR :: Rewrite c m u -> Rewrite c m u
anybuR Rewrite c m u
r = String -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
setFailMsg String
"anybuR failed" (Rewrite c m u -> Rewrite c m u) -> Rewrite c m u -> Rewrite c m u
forall a b. (a -> b) -> a -> b
$
           let go :: Rewrite c m u
go = Rewrite c m u -> Rewrite c m u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
anyR Rewrite c m u
go Rewrite c m u -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) c a.
MonadCatch m =>
Rewrite c m a -> Rewrite c m a -> Rewrite c m a
>+> Rewrite c m u
r
            in Rewrite c m u
go
{-# INLINE anybuR #-}

-- | Apply a rewrite twice, in a top-down and bottom-up way, using one single tree traversal,
--   succeeding if any succeed.
anyduR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
anyduR :: Rewrite c m u -> Rewrite c m u
anyduR Rewrite c m u
r = String -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
setFailMsg String
"anyduR failed" (Rewrite c m u -> Rewrite c m u) -> Rewrite c m u -> Rewrite c m u
forall a b. (a -> b) -> a -> b
$
           let go :: Rewrite c m u
go = Rewrite c m u
r Rewrite c m u -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) c a.
MonadCatch m =>
Rewrite c m a -> Rewrite c m a -> Rewrite c m a
>+> Rewrite c m u -> Rewrite c m u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
anyR Rewrite c m u
go Rewrite c m u -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) c a.
MonadCatch m =>
Rewrite c m a -> Rewrite c m a -> Rewrite c m a
>+> Rewrite c m u
r
            in Rewrite c m u
go
{-# INLINE anyduR #-}

-- | Apply a rewrite to the first node for which it can succeed, in a top-down traversal.
onetdR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
onetdR :: Rewrite c m u -> Rewrite c m u
onetdR Rewrite c m u
r = String -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
setFailMsg String
"onetdR failed" (Rewrite c m u -> Rewrite c m u) -> Rewrite c m u -> Rewrite c m u
forall a b. (a -> b) -> a -> b
$
           let go :: Rewrite c m u
go = Rewrite c m u
r Rewrite c m u -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. MonadCatch m => m a -> m a -> m a
<+ Rewrite c m u -> Rewrite c m u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
oneR Rewrite c m u
go
            in Rewrite c m u
go
{-# INLINE onetdR #-}

-- | Apply a rewrite to the first node for which it can succeed, in a bottom-up traversal.
onebuR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
onebuR :: Rewrite c m u -> Rewrite c m u
onebuR Rewrite c m u
r = String -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
setFailMsg String
"onebuR failed" (Rewrite c m u -> Rewrite c m u) -> Rewrite c m u -> Rewrite c m u
forall a b. (a -> b) -> a -> b
$
           let go :: Rewrite c m u
go = Rewrite c m u -> Rewrite c m u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
oneR Rewrite c m u
go Rewrite c m u -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. MonadCatch m => m a -> m a -> m a
<+ Rewrite c m u
r
            in Rewrite c m u
go
{-# INLINE onebuR #-}

-- | Attempt to apply a 'Rewrite' in a top-down manner, pruning at successful rewrites.
prunetdR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
prunetdR :: Rewrite c m u -> Rewrite c m u
prunetdR Rewrite c m u
r = String -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
setFailMsg String
"prunetdR failed" (Rewrite c m u -> Rewrite c m u) -> Rewrite c m u -> Rewrite c m u
forall a b. (a -> b) -> a -> b
$
             let go :: Rewrite c m u
go = Rewrite c m u
r Rewrite c m u -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. MonadCatch m => m a -> m a -> m a
<+ Rewrite c m u -> Rewrite c m u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
anyR Rewrite c m u
go
              in Rewrite c m u
go
{-# INLINE prunetdR #-}

-- | A fixed-point traveral, starting with the innermost term.
innermostR :: (Walker c u, MonadCatch m) => Rewrite c m u -> Rewrite c m u
innermostR :: Rewrite c m u -> Rewrite c m u
innermostR Rewrite c m u
r = String -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
setFailMsg String
"innermostR failed" (Rewrite c m u -> Rewrite c m u) -> Rewrite c m u -> Rewrite c m u
forall a b. (a -> b) -> a -> b
$
               let go :: Rewrite c m u
go = Rewrite c m u -> Rewrite c m u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
anybuR (Rewrite c m u
r Rewrite c m u -> Rewrite c m u -> Rewrite c m u
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) c a.
MonadCatch m =>
Rewrite c m a -> Rewrite c m a
tryR Rewrite c m u
go)
                in Rewrite c m u
go
{-# INLINE innermostR #-}

-------------------------------------------------------------------------------

tryL :: MonadCatch m => Lens c m u u -> Lens c m u u
tryL :: Lens c m u u -> Lens c m u u
tryL Lens c m u u
l = Lens c m u u
l Lens c m u u -> (String -> Lens c m u u) -> Lens c m u u
forall (m :: * -> *) c a b.
MonadCatch m =>
Lens c m a b -> (String -> Lens c m a b) -> Lens c m a b
`catchL` (\ String
_ -> Lens c m u u
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id)
{-# INLINE tryL #-}

-- | Construct a 'Lens' by following a 'Path'.
pathL :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => Path crumb -> Lens c m u u
pathL :: Path crumb -> Lens c m u u
pathL = [Lens c m u u] -> Lens c m u u
forall (f :: * -> *) (bi :: * -> * -> *) a.
(Foldable f, Category bi) =>
f (bi a a) -> bi a a
serialise ([Lens c m u u] -> Lens c m u u)
-> (Path crumb -> [Lens c m u u]) -> Path crumb -> Lens c m u u
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (crumb -> Lens c m u u) -> Path crumb -> [Lens c m u u]
forall a b. (a -> b) -> [a] -> [b]
map crumb -> Lens c m u u
forall c u crumb (m :: * -> *).
(Walker c u, ReadPath c crumb, Eq crumb, MonadCatch m) =>
crumb -> Lens c m u u
childL
{-# INLINE pathL #-}

-- | Build a 'Lens' from the root to a point specified by a 'LocalPath'.
localPathL :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => LocalPath crumb -> Lens c m u u
localPathL :: LocalPath crumb -> Lens c m u u
localPathL = Path crumb -> Lens c m u u
forall c crumb u (m :: * -> *).
(ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) =>
Path crumb -> Lens c m u u
pathL (Path crumb -> Lens c m u u)
-> (LocalPath crumb -> Path crumb)
-> LocalPath crumb
-> Lens c m u u
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalPath crumb -> Path crumb
forall crumb. SnocPath crumb -> Path crumb
snocPathToPath
{-# INLINE localPathL #-}

-- | Construct a 'Lens' that points to the last node at which the 'Path' can be followed.
exhaustPathL :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => Path crumb -> Lens c m u u
exhaustPathL :: Path crumb -> Lens c m u u
exhaustPathL = (crumb -> Lens c m u u -> Lens c m u u)
-> Lens c m u u -> Path crumb -> Lens c m u u
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ crumb
n Lens c m u u
l -> Lens c m u u -> Lens c m u u
forall (m :: * -> *) c u.
MonadCatch m =>
Lens c m u u -> Lens c m u u
tryL (crumb -> Lens c m u u
forall c u crumb (m :: * -> *).
(Walker c u, ReadPath c crumb, Eq crumb, MonadCatch m) =>
crumb -> Lens c m u u
childL crumb
n Lens c m u u -> Lens c m u u -> Lens c m u u
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Lens c m u u
l)) Lens c m u u
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
{-# INLINE exhaustPathL #-}

-- | Repeat as many iterations of the 'Path' as possible.
repeatPathL :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => Path crumb -> Lens c m u u
repeatPathL :: Path crumb -> Lens c m u u
repeatPathL Path crumb
p = let go :: Lens c m u u
go = Lens c m u u -> Lens c m u u
forall (m :: * -> *) c u.
MonadCatch m =>
Lens c m u u -> Lens c m u u
tryL (Path crumb -> Lens c m u u
forall c crumb u (m :: * -> *).
(ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) =>
Path crumb -> Lens c m u u
pathL Path crumb
p Lens c m u u -> Lens c m u u -> Lens c m u u
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Lens c m u u
go)
                 in Lens c m u u
go
{-# INLINE repeatPathL #-}

-------------------------------------------------------------------------------

-- | Apply a rewrite at a point specified by a 'Path'.
pathR :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => Path crumb -> Rewrite c m u -> Rewrite c m u
pathR :: Path crumb -> Rewrite c m u -> Rewrite c m u
pathR = Lens c m u u -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) c a b.
Monad m =>
Lens c m a b -> Rewrite c m b -> Rewrite c m a
focusR (Lens c m u u -> Rewrite c m u -> Rewrite c m u)
-> (Path crumb -> Lens c m u u)
-> Path crumb
-> Rewrite c m u
-> Rewrite c m u
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path crumb -> Lens c m u u
forall c crumb u (m :: * -> *).
(ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) =>
Path crumb -> Lens c m u u
pathL
{-# INLINE pathR #-}

-- | Apply a transformation at a point specified by a 'Path'.
pathT :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => Path crumb -> Transform c m u b -> Transform c m u b
pathT :: Path crumb -> Transform c m u b -> Transform c m u b
pathT = Lens c m u u -> Transform c m u b -> Transform c m u b
forall (m :: * -> *) c a b d.
Monad m =>
Lens c m a b -> Transform c m b d -> Transform c m a d
focusT (Lens c m u u -> Transform c m u b -> Transform c m u b)
-> (Path crumb -> Lens c m u u)
-> Path crumb
-> Transform c m u b
-> Transform c m u b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path crumb -> Lens c m u u
forall c crumb u (m :: * -> *).
(ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) =>
Path crumb -> Lens c m u u
pathL
{-# INLINE pathT #-}

-- | Apply a rewrite at a point specified by a 'LocalPath'.
localPathR :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => LocalPath crumb -> Rewrite c m u -> Rewrite c m u
localPathR :: LocalPath crumb -> Rewrite c m u -> Rewrite c m u
localPathR = Lens c m u u -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) c a b.
Monad m =>
Lens c m a b -> Rewrite c m b -> Rewrite c m a
focusR (Lens c m u u -> Rewrite c m u -> Rewrite c m u)
-> (LocalPath crumb -> Lens c m u u)
-> LocalPath crumb
-> Rewrite c m u
-> Rewrite c m u
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalPath crumb -> Lens c m u u
forall c crumb u (m :: * -> *).
(ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) =>
LocalPath crumb -> Lens c m u u
localPathL
{-# INLINE localPathR #-}

-- | Apply a transformation at a point specified by a 'LocalPath'.
localPathT :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => LocalPath crumb -> Transform c m u b -> Transform c m u b
localPathT :: LocalPath crumb -> Transform c m u b -> Transform c m u b
localPathT = Lens c m u u -> Transform c m u b -> Transform c m u b
forall (m :: * -> *) c a b d.
Monad m =>
Lens c m a b -> Transform c m b d -> Transform c m a d
focusT (Lens c m u u -> Transform c m u b -> Transform c m u b)
-> (LocalPath crumb -> Lens c m u u)
-> LocalPath crumb
-> Transform c m u b
-> Transform c m u b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalPath crumb -> Lens c m u u
forall c crumb u (m :: * -> *).
(ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) =>
LocalPath crumb -> Lens c m u u
localPathL
{-# INLINE localPathT #-}

-------------------------------------------------------------------------------

-- | Check if it is possible to construct a 'Lens' along this path from the current node.
testPathT :: (ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) => Path crumb -> Transform c m u Bool
testPathT :: Path crumb -> Transform c m u Bool
testPathT = Lens c m u u -> Transform c m u Bool
forall (m :: * -> *) c a b.
MonadCatch m =>
Lens c m a b -> Transform c m a Bool
testLensT (Lens c m u u -> Transform c m u Bool)
-> (Path crumb -> Lens c m u u)
-> Path crumb
-> Transform c m u Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path crumb -> Lens c m u u
forall c crumb u (m :: * -> *).
(ReadPath c crumb, Eq crumb, Walker c u, MonadCatch m) =>
Path crumb -> Lens c m u u
pathL
{-# INLINE testPathT #-}

-------------------------------------------------------------------------------

-- | Apply a rewrite to the largest node(s) that satisfy the predicate, requiring all to succeed.
allLargestR :: (Walker c u, MonadCatch m) => Transform c m u Bool -> Rewrite c m u -> Rewrite c m u
allLargestR :: Transform c m u Bool -> Rewrite c m u -> Rewrite c m u
allLargestR Transform c m u Bool
p Rewrite c m u
r = String -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
prefixFailMsg String
"allLargestR failed: " (Rewrite c m u -> Rewrite c m u) -> Rewrite c m u -> Rewrite c m u
forall a b. (a -> b) -> a -> b
$
                  let go :: Rewrite c m u
go = Transform c m u Bool
-> Rewrite c m u -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM Transform c m u Bool
p Rewrite c m u
r (Rewrite c m u -> Rewrite c m u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
allR Rewrite c m u
go)
                   in Rewrite c m u
go
{-# INLINE allLargestR #-}

-- | Apply a rewrite to the largest node(s) that satisfy the predicate, succeeding if any succeed.
anyLargestR :: (Walker c u, MonadCatch m) => Transform c m u Bool -> Rewrite c m u -> Rewrite c m u
anyLargestR :: Transform c m u Bool -> Rewrite c m u -> Rewrite c m u
anyLargestR Transform c m u Bool
p Rewrite c m u
r = String -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
setFailMsg String
"anyLargestR failed" (Rewrite c m u -> Rewrite c m u) -> Rewrite c m u -> Rewrite c m u
forall a b. (a -> b) -> a -> b
$
                  let go :: Rewrite c m u
go = Transform c m u Bool
-> Rewrite c m u -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM Transform c m u Bool
p Rewrite c m u
r (Rewrite c m u -> Rewrite c m u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
anyR Rewrite c m u
go)
                   in Rewrite c m u
go
{-# INLINE anyLargestR #-}

-- | Apply a rewrite to the first node for which it can succeed among the largest node(s) that satisfy the predicate.
oneLargestR :: (Walker c u, MonadCatch m) => Transform c m u Bool -> Rewrite c m u -> Rewrite c m u
oneLargestR :: Transform c m u Bool -> Rewrite c m u -> Rewrite c m u
oneLargestR Transform c m u Bool
p Rewrite c m u
r = String -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
setFailMsg String
"oneLargestR failed" (Rewrite c m u -> Rewrite c m u) -> Rewrite c m u -> Rewrite c m u
forall a b. (a -> b) -> a -> b
$
                  let go :: Rewrite c m u
go = Transform c m u Bool
-> Rewrite c m u -> Rewrite c m u -> Rewrite c m u
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM Transform c m u Bool
p Rewrite c m u
r (Rewrite c m u -> Rewrite c m u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
oneR Rewrite c m u
go)
                   in Rewrite c m u
go
{-# INLINE oneLargestR #-}

-- | Apply a transformation to the largest node(s) that satisfy the predicate, combining the results in a monoid.
allLargestT :: (Walker c u, MonadCatch m, Monoid b) => Transform c m u Bool -> Transform c m u b -> Transform c m u b
allLargestT :: Transform c m u Bool -> Transform c m u b -> Transform c m u b
allLargestT Transform c m u Bool
p Transform c m u b
t = String -> Transform c m u b -> Transform c m u b
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
prefixFailMsg String
"allLargestT failed: " (Transform c m u b -> Transform c m u b)
-> Transform c m u b -> Transform c m u b
forall a b. (a -> b) -> a -> b
$
                  let go :: Transform c m u b
go = Transform c m u Bool
-> Transform c m u b -> Transform c m u b -> Transform c m u b
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM Transform c m u Bool
p Transform c m u b
t (Transform c m u b -> Transform c m u b
forall c u (m :: * -> *) b.
(Walker c u, MonadCatch m, Monoid b) =>
Transform c m u b -> Transform c m u b
allT Transform c m u b
go)
                   in Transform c m u b
go
{-# INLINE allLargestT #-}

-- | Apply a transformation to the first node for which it can succeed among the largest node(s) that satisfy the predicate.
oneLargestT :: (Walker c u, MonadCatch m) => Transform c m u Bool -> Transform c m u b -> Transform c m u b
oneLargestT :: Transform c m u Bool -> Transform c m u b -> Transform c m u b
oneLargestT Transform c m u Bool
p Transform c m u b
t = String -> Transform c m u b -> Transform c m u b
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
setFailMsg String
"oneLargestT failed" (Transform c m u b -> Transform c m u b)
-> Transform c m u b -> Transform c m u b
forall a b. (a -> b) -> a -> b
$
                  let go :: Transform c m u b
go = Transform c m u Bool
-> Transform c m u b -> Transform c m u b -> Transform c m u b
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM Transform c m u Bool
p Transform c m u b
t (Transform c m u b -> Transform c m u b
forall c u (m :: * -> *) b.
(Walker c u, MonadCatch m) =>
Transform c m u b -> Transform c m u b
oneT Transform c m u b
go)
                   in Transform c m u b
go
{-# INLINE oneLargestT #-}

-- | Test if the type of the current node summand matches the type of the argument.
--   Note that the argument /value/ is never inspected, it is merely a proxy for a type argument.
summandIsTypeT :: forall c m a u. (MonadCatch m, Injection a u) => a -> Transform c m u Bool
summandIsTypeT :: a -> Transform c m u Bool
summandIsTypeT a
_ = (u -> Bool) -> Transform c m u Bool
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Maybe a -> Bool) -> (u -> Maybe a) -> u -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (u -> Maybe a
forall a u. Injection a u => u -> Maybe a
project :: (u -> Maybe a)))
{-# INLINE summandIsTypeT #-}

-------------------------------------------------------------------------------

data P a b = P a b

pSnd :: P a b -> b
pSnd :: P a b -> b
pSnd (P a
_ b
b) = b
b
{-# INLINE pSnd #-}

checkSuccessPMaybe :: MonadFail m => String -> m (Maybe a) -> m a
checkSuccessPMaybe :: String -> m (Maybe a) -> m a
checkSuccessPMaybe String
msg m (Maybe a)
ma = m (Maybe a)
ma m (Maybe a) -> (Maybe a -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe a -> m a
forall (m :: * -> *) a u.
(MonadFail m, Injection a u) =>
String -> u -> m a
projectWithFailMsgM String
msg
{-# INLINE checkSuccessPMaybe #-}

-------------------------------------------------------------------------------

-- These are used for defining 'allT' in terms of 'allR'.
-- However, they are unlikely to be of use to the KURE user.

newtype AllT w m a = AllT (m (P a w))

unAllT :: AllT w m a -> m (P a w)
unAllT :: AllT w m a -> m (P a w)
unAllT (AllT m (P a w)
mw) = m (P a w)
mw
{-# INLINE unAllT #-}

instance (Monoid w, Monad m) => Functor (AllT w m) where
   fmap :: (a -> b) -> AllT w m a -> AllT w m b
   fmap :: (a -> b) -> AllT w m a -> AllT w m b
fmap = (a -> b) -> AllT w m a -> AllT w m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
   {-# INLINE fmap #-}

instance (Monoid w, Monad m) => Applicative (AllT w m) where
   pure :: a -> AllT w m a
   pure :: a -> AllT w m a
pure = a -> AllT w m a
forall (m :: * -> *) a. Monad m => a -> m a
return
   {-# INLINE pure #-}

   (<*>) :: AllT w m (a -> b) -> AllT w m a -> AllT w m b
   <*> :: AllT w m (a -> b) -> AllT w m a -> AllT w m b
(<*>) = AllT w m (a -> b) -> AllT w m a -> AllT w m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
   {-# INLINE (<*>) #-}

instance (Monoid w, Monad m) => Monad (AllT w m) where
   return :: a -> AllT w m a
   return :: a -> AllT w m a
return a
a = m (P a w) -> AllT w m a
forall w (m :: * -> *) a. m (P a w) -> AllT w m a
AllT (m (P a w) -> AllT w m a) -> m (P a w) -> AllT w m a
forall a b. (a -> b) -> a -> b
$ P a w -> m (P a w)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> w -> P a w
forall a b. a -> b -> P a b
P a
a w
forall a. Monoid a => a
mempty)
   {-# INLINE return #-}

   (>>=) :: AllT w m a -> (a -> AllT w m d) -> AllT w m d
   AllT w m a
ma >>= :: AllT w m a -> (a -> AllT w m d) -> AllT w m d
>>= a -> AllT w m d
f = m (P d w) -> AllT w m d
forall w (m :: * -> *) a. m (P a w) -> AllT w m a
AllT (m (P d w) -> AllT w m d) -> m (P d w) -> AllT w m d
forall a b. (a -> b) -> a -> b
$ do P a
a w
w1 <- AllT w m a -> m (P a w)
forall w (m :: * -> *) a. AllT w m a -> m (P a w)
unAllT AllT w m a
ma
                        P d
d w
w2 <- AllT w m d -> m (P d w)
forall w (m :: * -> *) a. AllT w m a -> m (P a w)
unAllT (a -> AllT w m d
f a
a)
                        P d w -> m (P d w)
forall (m :: * -> *) a. Monad m => a -> m a
return (d -> w -> P d w
forall a b. a -> b -> P a b
P d
d (w
w1 w -> w -> w
forall a. Semigroup a => a -> a -> a
<> w
w2))
   {-# INLINE (>>=) #-}

#if !MIN_VERSION_base(4,13,0)
   fail :: String -> AllT w m a
   fail = AllT . fail
   {-# INLINE fail #-}
#endif

instance (Monoid w, MonadFail m) => MonadFail (AllT w m) where
   fail :: String -> AllT w m a
   fail :: String -> AllT w m a
fail = m (P a w) -> AllT w m a
forall w (m :: * -> *) a. m (P a w) -> AllT w m a
AllT (m (P a w) -> AllT w m a)
-> (String -> m (P a w)) -> String -> AllT w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m (P a w)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
   {-# INLINE fail #-}

instance (Monoid w, MonadCatch m) => MonadCatch (AllT w m) where
   catchM :: AllT w m a -> (String -> AllT w m a) -> AllT w m a
   catchM :: AllT w m a -> (String -> AllT w m a) -> AllT w m a
catchM (AllT m (P a w)
ma) String -> AllT w m a
f = m (P a w) -> AllT w m a
forall w (m :: * -> *) a. m (P a w) -> AllT w m a
AllT (m (P a w) -> AllT w m a) -> m (P a w) -> AllT w m a
forall a b. (a -> b) -> a -> b
$ m (P a w)
ma m (P a w) -> (String -> m (P a w)) -> m (P a w)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (String -> m a) -> m a
`catchM` (AllT w m a -> m (P a w)
forall w (m :: * -> *) a. AllT w m a -> m (P a w)
unAllT (AllT w m a -> m (P a w))
-> (String -> AllT w m a) -> String -> m (P a w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AllT w m a
f)
   {-# INLINE catchM #-}


-- | Wrap a 'Transform' using the 'AllT' monad transformer.
wrapAllT :: Monad m => Transform c m u b -> Rewrite c (AllT b m) u
wrapAllT :: Transform c m u b -> Rewrite c (AllT b m) u
wrapAllT Transform c m u b
t = (u -> Rewrite c (AllT b m) u) -> Rewrite c (AllT b m) u
forall a c (m :: * -> *) b.
(a -> Transform c m a b) -> Transform c m a b
readerT ((u -> Rewrite c (AllT b m) u) -> Rewrite c (AllT b m) u)
-> (u -> Rewrite c (AllT b m) u) -> Rewrite c (AllT b m) u
forall a b. (a -> b) -> a -> b
$ \ u
a -> (m b -> AllT b m u) -> Transform c m u b -> Rewrite c (AllT b m) u
forall (m :: * -> *) b (n :: * -> *) d c a.
(m b -> n d) -> Transform c m a b -> Transform c n a d
resultT (m (P u b) -> AllT b m u
forall w (m :: * -> *) a. m (P a w) -> AllT w m a
AllT (m (P u b) -> AllT b m u)
-> (m b -> m (P u b)) -> m b -> AllT b m u
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> P u b) -> m b -> m (P u b)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (u -> b -> P u b
forall a b. a -> b -> P a b
P u
a)) Transform c m u b
t
{-# INLINE wrapAllT #-}

-- | Unwrap a 'Transform' from the 'AllT' monad transformer.
unwrapAllT :: MonadCatch m => Rewrite c (AllT b m) u -> Transform c m u b
unwrapAllT :: Rewrite c (AllT b m) u -> Transform c m u b
unwrapAllT = String -> Transform c m u b -> Transform c m u b
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
prefixFailMsg String
"allT failed:" (Transform c m u b -> Transform c m u b)
-> (Rewrite c (AllT b m) u -> Transform c m u b)
-> Rewrite c (AllT b m) u
-> Transform c m u b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AllT b m u -> m b) -> Rewrite c (AllT b m) u -> Transform c m u b
forall (m :: * -> *) b (n :: * -> *) d c a.
(m b -> n d) -> Transform c m a b -> Transform c n a d
resultT ((P u b -> b) -> m (P u b) -> m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM P u b -> b
forall a b. P a b -> b
pSnd (m (P u b) -> m b)
-> (AllT b m u -> m (P u b)) -> AllT b m u -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllT b m u -> m (P u b)
forall w (m :: * -> *) a. AllT w m a -> m (P a w)
unAllT)
{-# INLINE unwrapAllT #-}

-------------------------------------------------------------------------------

-- We could probably build this on top of OneR or AllT

-- These are used for defining 'oneT' in terms of 'allR'.
-- However, they are unlikely to be of use to the KURE user.

newtype OneT w m a = OneT (Maybe w -> m (P a (Maybe w)))

unOneT :: OneT w m a -> Maybe w -> m (P a (Maybe w))
unOneT :: OneT w m a -> Maybe w -> m (P a (Maybe w))
unOneT (OneT Maybe w -> m (P a (Maybe w))
f) = Maybe w -> m (P a (Maybe w))
f
{-# INLINE unOneT #-}

instance Monad m => Functor (OneT w m) where
   fmap :: (a -> b) -> OneT w m a -> OneT w m b
   fmap :: (a -> b) -> OneT w m a -> OneT w m b
fmap = (a -> b) -> OneT w m a -> OneT w m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
   {-# INLINE fmap #-}

instance Monad m => Applicative (OneT w m) where
   pure :: a -> OneT w m a
   pure :: a -> OneT w m a
pure = a -> OneT w m a
forall (m :: * -> *) a. Monad m => a -> m a
return
   {-# INLINE pure #-}

   (<*>) :: OneT w m (a -> b) -> OneT w m a -> OneT w m b
   <*> :: OneT w m (a -> b) -> OneT w m a -> OneT w m b
(<*>) = OneT w m (a -> b) -> OneT w m a -> OneT w m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
   {-# INLINE (<*>) #-}

instance Monad m => Monad (OneT w m) where
   return :: a -> OneT w m a
   return :: a -> OneT w m a
return a
a = (Maybe w -> m (P a (Maybe w))) -> OneT w m a
forall w (m :: * -> *) a.
(Maybe w -> m (P a (Maybe w))) -> OneT w m a
OneT ((Maybe w -> m (P a (Maybe w))) -> OneT w m a)
-> (Maybe w -> m (P a (Maybe w))) -> OneT w m a
forall a b. (a -> b) -> a -> b
$ \ Maybe w
mw -> P a (Maybe w) -> m (P a (Maybe w))
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe w -> P a (Maybe w)
forall a b. a -> b -> P a b
P a
a Maybe w
mw)
   {-# INLINE return #-}

   (>>=) :: OneT w m a -> (a -> OneT w m d) -> OneT w m d
   OneT w m a
ma >>= :: OneT w m a -> (a -> OneT w m d) -> OneT w m d
>>= a -> OneT w m d
f = (Maybe w -> m (P d (Maybe w))) -> OneT w m d
forall w (m :: * -> *) a.
(Maybe w -> m (P a (Maybe w))) -> OneT w m a
OneT ((Maybe w -> m (P d (Maybe w))) -> OneT w m d)
-> (Maybe w -> m (P d (Maybe w))) -> OneT w m d
forall a b. (a -> b) -> a -> b
$ do \ Maybe w
mw1 -> do P a
a Maybe w
mw2 <- OneT w m a -> Maybe w -> m (P a (Maybe w))
forall w (m :: * -> *) a.
OneT w m a -> Maybe w -> m (P a (Maybe w))
unOneT OneT w m a
ma Maybe w
mw1
                                    OneT w m d -> Maybe w -> m (P d (Maybe w))
forall w (m :: * -> *) a.
OneT w m a -> Maybe w -> m (P a (Maybe w))
unOneT (a -> OneT w m d
f a
a) Maybe w
mw2
   {-# INLINE (>>=) #-}

#if !MIN_VERSION_base(4,13,0)
   fail :: String -> OneT w m a
   fail msg = OneT (\ _ -> fail msg)
   {-# INLINE fail #-}
#endif

instance MonadFail m => MonadFail (OneT w m) where
   fail :: String -> OneT w m a
   fail :: String -> OneT w m a
fail String
msg = (Maybe w -> m (P a (Maybe w))) -> OneT w m a
forall w (m :: * -> *) a.
(Maybe w -> m (P a (Maybe w))) -> OneT w m a
OneT (\ Maybe w
_ -> String -> m (P a (Maybe w))
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg)
   {-# INLINE fail #-}

instance MonadCatch m => MonadCatch (OneT w m) where
   catchM :: OneT w m a -> (String -> OneT w m a) -> OneT w m a
   catchM :: OneT w m a -> (String -> OneT w m a) -> OneT w m a
catchM (OneT Maybe w -> m (P a (Maybe w))
g) String -> OneT w m a
f = (Maybe w -> m (P a (Maybe w))) -> OneT w m a
forall w (m :: * -> *) a.
(Maybe w -> m (P a (Maybe w))) -> OneT w m a
OneT ((Maybe w -> m (P a (Maybe w))) -> OneT w m a)
-> (Maybe w -> m (P a (Maybe w))) -> OneT w m a
forall a b. (a -> b) -> a -> b
$ \ Maybe w
mw -> Maybe w -> m (P a (Maybe w))
g Maybe w
mw m (P a (Maybe w))
-> (String -> m (P a (Maybe w))) -> m (P a (Maybe w))
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (String -> m a) -> m a
`catchM` (((Maybe w -> m (P a (Maybe w))) -> Maybe w -> m (P a (Maybe w))
forall a b. (a -> b) -> a -> b
$ Maybe w
mw) ((Maybe w -> m (P a (Maybe w))) -> m (P a (Maybe w)))
-> (String -> Maybe w -> m (P a (Maybe w)))
-> String
-> m (P a (Maybe w))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneT w m a -> Maybe w -> m (P a (Maybe w))
forall w (m :: * -> *) a.
OneT w m a -> Maybe w -> m (P a (Maybe w))
unOneT (OneT w m a -> Maybe w -> m (P a (Maybe w)))
-> (String -> OneT w m a) -> String -> Maybe w -> m (P a (Maybe w))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> OneT w m a
f)
   {-# INLINE catchM #-}


-- | Wrap a 'Transform' using the 'OneT' monad transformer.
wrapOneT :: MonadCatch m => Transform c m u b -> Rewrite c (OneT b m) u
wrapOneT :: Transform c m u b -> Rewrite c (OneT b m) u
wrapOneT Transform c m u b
t = (c -> u -> OneT b m u) -> Rewrite c (OneT b m) u
forall c a (m :: * -> *). (c -> a -> m a) -> Rewrite c m a
rewrite ((c -> u -> OneT b m u) -> Rewrite c (OneT b m) u)
-> (c -> u -> OneT b m u) -> Rewrite c (OneT b m) u
forall a b. (a -> b) -> a -> b
$ \ c
c u
a -> (Maybe b -> m (P u (Maybe b))) -> OneT b m u
forall w (m :: * -> *) a.
(Maybe w -> m (P a (Maybe w))) -> OneT w m a
OneT ((Maybe b -> m (P u (Maybe b))) -> OneT b m u)
-> (Maybe b -> m (P u (Maybe b))) -> OneT b m u
forall a b. (a -> b) -> a -> b
$ \ Maybe b
mw -> case Maybe b
mw of
                                                 Just b
w  -> P u (Maybe b) -> m (P u (Maybe b))
forall (m :: * -> *) a. Monad m => a -> m a
return (u -> Maybe b -> P u (Maybe b)
forall a b. a -> b -> P a b
P u
a (b -> Maybe b
forall a. a -> Maybe a
Just b
w))
                                                 Maybe b
Nothing -> ((u -> Maybe b -> P u (Maybe b)
forall a b. a -> b -> P a b
P u
a (Maybe b -> P u (Maybe b)) -> (b -> Maybe b) -> b -> P u (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe b
forall a. a -> Maybe a
Just) (b -> P u (Maybe b)) -> m b -> m (P u (Maybe b))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Transform c m u b -> c -> u -> m b
forall c k (m :: k -> *) a (b :: k).
Transform c m a b -> c -> a -> m b
applyT Transform c m u b
t c
c u
a) m (P u (Maybe b)) -> m (P u (Maybe b)) -> m (P u (Maybe b))
forall (m :: * -> *) a. MonadCatch m => m a -> m a -> m a
<+ P u (Maybe b) -> m (P u (Maybe b))
forall (m :: * -> *) a. Monad m => a -> m a
return (u -> Maybe b -> P u (Maybe b)
forall a b. a -> b -> P a b
P u
a Maybe b
mw)
{-# INLINE wrapOneT #-}

-- | Unwrap a 'Transform' from the 'OneT' monad transformer.
unwrapOneT :: MonadFail m => Rewrite c (OneT b m) u -> Transform c m u b
unwrapOneT :: Rewrite c (OneT b m) u -> Transform c m u b
unwrapOneT = (OneT b m u -> m b) -> Rewrite c (OneT b m) u -> Transform c m u b
forall (m :: * -> *) b (n :: * -> *) d c a.
(m b -> n d) -> Transform c m a b -> Transform c n a d
resultT (String -> m (Maybe b) -> m b
forall (m :: * -> *) a. MonadFail m => String -> m (Maybe a) -> m a
checkSuccessPMaybe String
"oneT failed" (m (Maybe b) -> m b)
-> (OneT b m u -> m (Maybe b)) -> OneT b m u -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (P u (Maybe b) -> Maybe b) -> m (P u (Maybe b)) -> m (Maybe b)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM P u (Maybe b) -> Maybe b
forall a b. P a b -> b
pSnd (m (P u (Maybe b)) -> m (Maybe b))
-> (OneT b m u -> m (P u (Maybe b))) -> OneT b m u -> m (Maybe b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe b -> m (P u (Maybe b))) -> Maybe b -> m (P u (Maybe b))
forall a b. (a -> b) -> a -> b
$ Maybe b
forall a. Maybe a
Nothing) ((Maybe b -> m (P u (Maybe b))) -> m (P u (Maybe b)))
-> (OneT b m u -> Maybe b -> m (P u (Maybe b)))
-> OneT b m u
-> m (P u (Maybe b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneT b m u -> Maybe b -> m (P u (Maybe b))
forall w (m :: * -> *) a.
OneT w m a -> Maybe w -> m (P a (Maybe w))
unOneT)
{-# INLINE unwrapOneT #-}

-------------------------------------------------------------------------------

-- If allR just used Monad (rather than MonadCatch), this (and other things) would be simpler.
-- And currently, the only use of MonadCatch is that it allows the error message to be modified.

-- Failure should not occur, so it doesn't really matter where the KureM monad sits in the GetChild stack.
-- I've arbitrarily made it a local failure.

data GetChild c u a = GetChild (KureM a) (Maybe (c,u))

getChildSecond :: (Maybe (c,u) -> Maybe (c,u)) -> GetChild c u a -> GetChild c u a
getChildSecond :: (Maybe (c, u) -> Maybe (c, u)) -> GetChild c u a -> GetChild c u a
getChildSecond Maybe (c, u) -> Maybe (c, u)
f (GetChild KureM a
ka Maybe (c, u)
mcu) = KureM a -> Maybe (c, u) -> GetChild c u a
forall c u a. KureM a -> Maybe (c, u) -> GetChild c u a
GetChild KureM a
ka (Maybe (c, u) -> Maybe (c, u)
f Maybe (c, u)
mcu)
{-# INLINE getChildSecond #-}

instance Functor (GetChild c u) where
   fmap :: (a -> b) -> GetChild c u a -> GetChild c u b
   fmap :: (a -> b) -> GetChild c u a -> GetChild c u b
fmap = (a -> b) -> GetChild c u a -> GetChild c u b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
   {-# INLINE fmap #-}

instance Applicative (GetChild c u) where
   pure :: a -> GetChild c u a
   pure :: a -> GetChild c u a
pure = a -> GetChild c u a
forall (m :: * -> *) a. Monad m => a -> m a
return
   {-# INLINE pure #-}

   (<*>) :: GetChild c u (a -> b) -> GetChild c u a -> GetChild c u b
   <*> :: GetChild c u (a -> b) -> GetChild c u a -> GetChild c u b
(<*>) = GetChild c u (a -> b) -> GetChild c u a -> GetChild c u b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
   {-# INLINE (<*>) #-}

instance Monad (GetChild c u) where
   return :: a -> GetChild c u a
   return :: a -> GetChild c u a
return a
a = KureM a -> Maybe (c, u) -> GetChild c u a
forall c u a. KureM a -> Maybe (c, u) -> GetChild c u a
GetChild (a -> KureM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a) Maybe (c, u)
forall a. Maybe a
Nothing
   {-# INLINE return #-}

   (>>=) :: GetChild c u a -> (a -> GetChild c u b) -> GetChild c u b
   (GetChild KureM a
kma Maybe (c, u)
mcu) >>= :: GetChild c u a -> (a -> GetChild c u b) -> GetChild c u b
>>= a -> GetChild c u b
k = (a -> GetChild c u b)
-> (String -> GetChild c u b) -> KureM a -> GetChild c u b
forall a b. (a -> b) -> (String -> b) -> KureM a -> b
runKureM (\ a
a   -> (Maybe (c, u) -> Maybe (c, u)) -> GetChild c u b -> GetChild c u b
forall c u a.
(Maybe (c, u) -> Maybe (c, u)) -> GetChild c u a -> GetChild c u a
getChildSecond (Maybe (c, u) -> Maybe (c, u) -> Maybe (c, u)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus Maybe (c, u)
mcu) (a -> GetChild c u b
k a
a))
                                       (\ String
msg -> KureM b -> Maybe (c, u) -> GetChild c u b
forall c u a. KureM a -> Maybe (c, u) -> GetChild c u a
GetChild (String -> KureM b
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg) Maybe (c, u)
mcu)
                                       KureM a
kma
   {-# INLINE (>>=) #-}

#if !MIN_VERSION_base(4,13,0)
   fail :: String -> GetChild c u a
   fail msg = GetChild (fail msg) Nothing
   {-# INLINE fail #-}
#endif

instance MonadFail (GetChild c u) where
   fail :: String -> GetChild c u a
   fail :: String -> GetChild c u a
fail String
msg = KureM a -> Maybe (c, u) -> GetChild c u a
forall c u a. KureM a -> Maybe (c, u) -> GetChild c u a
GetChild (String -> KureM a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg) Maybe (c, u)
forall a. Maybe a
Nothing
   {-# INLINE fail #-}

instance MonadCatch (GetChild c u) where
   catchM :: GetChild c u a -> (String -> GetChild c u a) -> GetChild c u a
   uc :: GetChild c u a
uc@(GetChild KureM a
kma Maybe (c, u)
mcu) catchM :: GetChild c u a -> (String -> GetChild c u a) -> GetChild c u a
`catchM` String -> GetChild c u a
k = (a -> GetChild c u a)
-> (String -> GetChild c u a) -> KureM a -> GetChild c u a
forall a b. (a -> b) -> (String -> b) -> KureM a -> b
runKureM (\ a
_   -> GetChild c u a
uc)
                                               (\ String
msg -> (Maybe (c, u) -> Maybe (c, u)) -> GetChild c u a -> GetChild c u a
forall c u a.
(Maybe (c, u) -> Maybe (c, u)) -> GetChild c u a -> GetChild c u a
getChildSecond (Maybe (c, u) -> Maybe (c, u) -> Maybe (c, u)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus Maybe (c, u)
mcu) (String -> GetChild c u a
k String
msg))
                                               KureM a
kma
   {-# INLINE catchM #-}


wrapGetChild :: (ReadPath c crumb, Eq crumb) => crumb -> Rewrite c (GetChild c g) g
wrapGetChild :: crumb -> Rewrite c (GetChild c g) g
wrapGetChild crumb
cr = do crumb
cr' <- Transform c (GetChild c g) g crumb
forall c crumb (m :: * -> *) a.
(ReadPath c crumb, MonadFail m) =>
Transform c m a crumb
lastCrumbT
                     (c -> g -> GetChild c g g) -> Rewrite c (GetChild c g) g
forall c a (m :: * -> *). (c -> a -> m a) -> Rewrite c m a
rewrite ((c -> g -> GetChild c g g) -> Rewrite c (GetChild c g) g)
-> (c -> g -> GetChild c g g) -> Rewrite c (GetChild c g) g
forall a b. (a -> b) -> a -> b
$ \ c
c g
a -> KureM g -> Maybe (c, g) -> GetChild c g g
forall c u a. KureM a -> Maybe (c, u) -> GetChild c u a
GetChild (g -> KureM g
forall (m :: * -> *) a. Monad m => a -> m a
return g
a) (if crumb
cr crumb -> crumb -> Bool
forall a. Eq a => a -> a -> Bool
== crumb
cr' then (c, g) -> Maybe (c, g)
forall a. a -> Maybe a
Just (c
c, g
a) else Maybe (c, g)
forall a. Maybe a
Nothing)
{-# INLINE wrapGetChild #-}

unwrapGetChild :: Rewrite c (GetChild c u) u -> Transform c Maybe u (c,u)
unwrapGetChild :: Rewrite c (GetChild c u) u -> Transform c Maybe u (c, u)
unwrapGetChild = (GetChild c u u -> Maybe (c, u))
-> Rewrite c (GetChild c u) u -> Transform c Maybe u (c, u)
forall (m :: * -> *) b (n :: * -> *) d c a.
(m b -> n d) -> Transform c m a b -> Transform c n a d
resultT (\ (GetChild KureM u
_ Maybe (c, u)
mcu) -> Maybe (c, u)
mcu)
{-# INLINE unwrapGetChild #-}

getChild :: (ReadPath c crumb, Eq crumb, Walker c u) => crumb -> Transform c Maybe u (c, u)
getChild :: crumb -> Transform c Maybe u (c, u)
getChild = Rewrite c (GetChild c u) u -> Transform c Maybe u (c, u)
forall c u.
Rewrite c (GetChild c u) u -> Transform c Maybe u (c, u)
unwrapGetChild (Rewrite c (GetChild c u) u -> Transform c Maybe u (c, u))
-> (crumb -> Rewrite c (GetChild c u) u)
-> crumb
-> Transform c Maybe u (c, u)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rewrite c (GetChild c u) u -> Rewrite c (GetChild c u) u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
allR (Rewrite c (GetChild c u) u -> Rewrite c (GetChild c u) u)
-> (crumb -> Rewrite c (GetChild c u) u)
-> crumb
-> Rewrite c (GetChild c u) u
forall b c a. (b -> c) -> (a -> b) -> a -> c
. crumb -> Rewrite c (GetChild c u) u
forall c crumb g.
(ReadPath c crumb, Eq crumb) =>
crumb -> Rewrite c (GetChild c g) g
wrapGetChild
{-# INLINE getChild #-}

-------------------------------------------------------------------------------

type SetChild = KureM

wrapSetChild :: (ReadPath c crumb, Eq crumb) => crumb -> u -> Rewrite c SetChild u
wrapSetChild :: crumb -> u -> Rewrite c SetChild u
wrapSetChild crumb
cr u
u = do crumb
cr' <- Transform c SetChild u crumb
forall c crumb (m :: * -> *) a.
(ReadPath c crumb, MonadFail m) =>
Transform c m a crumb
lastCrumbT
                       if crumb
cr crumb -> crumb -> Bool
forall a. Eq a => a -> a -> Bool
== crumb
cr' then u -> Rewrite c SetChild u
forall (m :: * -> *) a. Monad m => a -> m a
return u
u else Rewrite c SetChild u
forall (m :: * -> *) c a. Monad m => Rewrite c m a
idR
{-# INLINE wrapSetChild #-}

unwrapSetChild :: MonadFail m => Rewrite c SetChild u -> Rewrite c m u
unwrapSetChild :: Rewrite c SetChild u -> Rewrite c m u
unwrapSetChild = (KureM u -> m u) -> Rewrite c SetChild u -> Rewrite c m u
forall (m :: * -> *) b (n :: * -> *) d c a.
(m b -> n d) -> Transform c m a b -> Transform c n a d
resultT KureM u -> m u
forall (m :: * -> *) a. MonadFail m => KureM a -> m a
liftKureM
{-# INLINE unwrapSetChild #-}

setChild :: (ReadPath c crumb, Eq crumb, Walker c u, MonadFail m) => crumb -> u -> Rewrite c m u
setChild :: crumb -> u -> Rewrite c m u
setChild crumb
cr = Rewrite c SetChild u -> Rewrite c m u
forall (m :: * -> *) c u.
MonadFail m =>
Rewrite c SetChild u -> Rewrite c m u
unwrapSetChild (Rewrite c SetChild u -> Rewrite c m u)
-> (u -> Rewrite c SetChild u) -> u -> Rewrite c m u
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rewrite c SetChild u -> Rewrite c SetChild u
forall c u (m :: * -> *).
(Walker c u, MonadCatch m) =>
Rewrite c m u -> Rewrite c m u
allR (Rewrite c SetChild u -> Rewrite c SetChild u)
-> (u -> Rewrite c SetChild u) -> u -> Rewrite c SetChild u
forall b c a. (b -> c) -> (a -> b) -> a -> c
. crumb -> u -> Rewrite c SetChild u
forall c crumb u.
(ReadPath c crumb, Eq crumb) =>
crumb -> u -> Rewrite c SetChild u
wrapSetChild crumb
cr
{-# INLINE setChild #-}

-------------------------------------------------------------------------------

childL_default :: forall c crumb m u. (ReadPath c crumb, Eq crumb) => (Walker c u, MonadCatch m) => crumb -> Lens c m u u
childL_default :: crumb -> Lens c m u u
childL_default crumb
cr = Transform c m u ((c, u), u -> m u) -> Lens c m u u
forall c (m :: * -> *) a b.
Transform c m a ((c, b), b -> m a) -> Lens c m a b
lens (Transform c m u ((c, u), u -> m u) -> Lens c m u u)
-> Transform c m u ((c, u), u -> m u) -> Lens c m u u
forall a b. (a -> b) -> a -> b
$ String
-> Transform c m u ((c, u), u -> m u)
-> Transform c m u ((c, u), u -> m u)
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
prefixFailMsg String
"childL failed: " (Transform c m u ((c, u), u -> m u)
 -> Transform c m u ((c, u), u -> m u))
-> Transform c m u ((c, u), u -> m u)
-> Transform c m u ((c, u), u -> m u)
forall a b. (a -> b) -> a -> b
$
                           do (c, u)
cu <- Transform c m u (c, u)
getter
                              u -> m u
k  <- Transform c m u (u -> m u)
setter
                              ((c, u), u -> m u) -> Transform c m u ((c, u), u -> m u)
forall (m :: * -> *) a. Monad m => a -> m a
return ((c, u)
cu, u -> m u
k)
  where
    getter :: Transform c m u (c,u)
    getter :: Transform c m u (c, u)
getter = (Maybe (c, u) -> m (c, u))
-> Transform c Maybe u (c, u) -> Transform c m u (c, u)
forall (m :: * -> *) b (n :: * -> *) d c a.
(m b -> n d) -> Transform c m a b -> Transform c n a d
resultT (String -> Maybe (c, u) -> m (c, u)
forall (m :: * -> *) a u.
(MonadFail m, Injection a u) =>
String -> u -> m a
projectWithFailMsgM String
"there is no child matching the crumb.") (crumb -> Transform c Maybe u (c, u)
forall c crumb u.
(ReadPath c crumb, Eq crumb, Walker c u) =>
crumb -> Transform c Maybe u (c, u)
getChild crumb
cr)
    {-# INLINE getter #-}

    setter :: Transform c m u (u -> m u)
    setter :: Transform c m u (u -> m u)
setter = (c -> u -> m (u -> m u)) -> Transform c m u (u -> m u)
forall k c a (m :: k -> *) (b :: k).
(c -> a -> m b) -> Transform c m a b
transform ((c -> u -> m (u -> m u)) -> Transform c m u (u -> m u))
-> (c -> u -> m (u -> m u)) -> Transform c m u (u -> m u)
forall a b. (a -> b) -> a -> b
$ \ c
c u
a -> (u -> m u) -> m (u -> m u)
forall (m :: * -> *) a. Monad m => a -> m a
return (\ u
b -> Rewrite c m u -> c -> u -> m u
forall c (m :: * -> *) a. Rewrite c m a -> c -> a -> m a
applyR (crumb -> u -> Rewrite c m u
forall c crumb u (m :: * -> *).
(ReadPath c crumb, Eq crumb, Walker c u, MonadFail m) =>
crumb -> u -> Rewrite c m u
setChild crumb
cr u
b) c
c u
a)
    {-# INLINE setter #-}
{-# INLINE childL_default #-}

-------------------------------------------------------------------------------