{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- |
-- Module: Language.KURE.Pathfinder
-- 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 to find 'LocalPath's sub-nodes specified by a predicate.

module Language.KURE.Pathfinder
        (
        -- * Finding Local Paths
        -- ** Context Transformers
        -- | To find a 'LocalPath' to a node that satisfies a predicate, use @'withLocalPathT' (tt ('acceptLocalPathT' q))@,
        --   where @q@ is a transformation returning 'Bool', and @tt@ is a traversal strategy, such as 'collectT' or 'onetdT'.
        --   This will handle the tracking of the local path.
        --   See the example pathfinders below.
          WithLocalPath
        , withLocalPathT
        , exposeLocalPathT
        , acceptLocalPathT
        -- ** Example Pathfinders
        , pathsToT
        , onePathToT
        , oneNonEmptyPathToT
        , prunePathsToT
        , uniquePathToT
        , uniquePrunePathToT
) where

import Prelude

import Control.Category hiding ((.))
import Control.Arrow

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

import Language.KURE.MonadCatch
import Language.KURE.Transform
import Language.KURE.Combinators.Transform
import Language.KURE.Path
import Language.KURE.Walker
import Language.KURE.ExtendableContext

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

-- | A context transformer that adds a 'LocalPath' (from the current node) to the context.
type WithLocalPath c crumb = ExtendContext c (LocalPath crumb)

-- | Apply a transformation that stores a 'LocalPath' in the context (starting at the current node).
withLocalPathT :: Transform (WithLocalPath c crumb) m a b -> Transform c m a b
withLocalPathT :: Transform (WithLocalPath c crumb) m a b -> Transform c m a b
withLocalPathT = (c -> WithLocalPath c crumb)
-> Transform (WithLocalPath c crumb) m a b -> Transform c m a b
forall c c' (m :: * -> *) a b.
(c -> c') -> Transform c' m a b -> Transform c m a b
liftContext (LocalPath crumb -> c -> WithLocalPath c crumb
forall e c. e -> c -> ExtendContext c e
extendContext LocalPath crumb
forall a. Monoid a => a
mempty)
{-# INLINE withLocalPathT #-}

-- | Extract the current 'LocalPath' from the context.
exposeLocalPathT :: Monad m => Transform (WithLocalPath c crumb) m a (LocalPath crumb)
exposeLocalPathT :: Transform (WithLocalPath c crumb) m a (LocalPath crumb)
exposeLocalPathT = Transform (WithLocalPath c crumb) m a (WithLocalPath c crumb)
forall (m :: * -> *) c a. Monad m => Transform c m a c
contextT Transform (WithLocalPath c crumb) m a (WithLocalPath c crumb)
-> (WithLocalPath c crumb -> LocalPath crumb)
-> Transform (WithLocalPath c crumb) m a (LocalPath crumb)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ WithLocalPath c crumb -> LocalPath crumb
forall c e. ExtendContext c e -> e
extraContext
{-# INLINE exposeLocalPathT #-}

-- | Return the current 'LocalPath' if the predicate transformation succeeds.
acceptLocalPathT :: MonadFail m => Transform c m u Bool -> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
acceptLocalPathT :: Transform c m u Bool
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
acceptLocalPathT Transform c m u Bool
q = Transform (WithLocalPath c crumb) m u Bool
-> Rewrite (WithLocalPath c crumb) m u
forall (m :: * -> *) c a.
MonadFail m =>
Transform c m a Bool -> Rewrite c m a
accepterR ((WithLocalPath c crumb -> c)
-> Transform c m u Bool
-> Transform (WithLocalPath c crumb) m u Bool
forall c c' (m :: * -> *) a b.
(c -> c') -> Transform c' m a b -> Transform c m a b
liftContext WithLocalPath c crumb -> c
forall c e. ExtendContext c e -> c
baseContext Transform c m u Bool
q) Rewrite (WithLocalPath c crumb) m u
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
forall (m :: * -> *) c crumb a.
Monad m =>
Transform (WithLocalPath c crumb) m a (LocalPath crumb)
exposeLocalPathT
{-# INLINE acceptLocalPathT #-}

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

-- | Find the 'LocalPath's to every node that satisfies the predicate.
pathsToT :: (Walker (WithLocalPath c crumb) u, MonadCatch m) => Transform c m u Bool -> Transform c m u [LocalPath crumb]
pathsToT :: Transform c m u Bool -> Transform c m u [LocalPath crumb]
pathsToT Transform c m u Bool
q = Transform (WithLocalPath c crumb) m u [LocalPath crumb]
-> Transform c m u [LocalPath crumb]
forall c crumb (m :: * -> *) a b.
Transform (WithLocalPath c crumb) m a b -> Transform c m a b
withLocalPathT (Transform (WithLocalPath c crumb) m u (LocalPath crumb)
-> Transform (WithLocalPath c crumb) m u [LocalPath crumb]
forall c u (m :: * -> *) b.
(Walker c u, MonadCatch m) =>
Transform c m u b -> Transform c m u [b]
collectT (Transform (WithLocalPath c crumb) m u (LocalPath crumb)
 -> Transform (WithLocalPath c crumb) m u [LocalPath crumb])
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
-> Transform (WithLocalPath c crumb) m u [LocalPath crumb]
forall a b. (a -> b) -> a -> b
$ Transform c m u Bool
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
forall (m :: * -> *) c u crumb.
MonadFail m =>
Transform c m u Bool
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
acceptLocalPathT Transform c m u Bool
q)
{-# INLINE pathsToT #-}

-- | Find the 'LocalPath's to every node that satisfies the predicate, ignoring nodes below successes.
prunePathsToT :: (Walker (WithLocalPath c crumb) u, MonadCatch m) => Transform c m u Bool -> Transform c m u [LocalPath crumb]
prunePathsToT :: Transform c m u Bool -> Transform c m u [LocalPath crumb]
prunePathsToT Transform c m u Bool
q = Transform (WithLocalPath c crumb) m u [LocalPath crumb]
-> Transform c m u [LocalPath crumb]
forall c crumb (m :: * -> *) a b.
Transform (WithLocalPath c crumb) m a b -> Transform c m a b
withLocalPathT (Transform (WithLocalPath c crumb) m u (LocalPath crumb)
-> Transform (WithLocalPath c crumb) m u [LocalPath crumb]
forall c u (m :: * -> *) b.
(Walker c u, MonadCatch m) =>
Transform c m u b -> Transform c m u [b]
collectPruneT (Transform (WithLocalPath c crumb) m u (LocalPath crumb)
 -> Transform (WithLocalPath c crumb) m u [LocalPath crumb])
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
-> Transform (WithLocalPath c crumb) m u [LocalPath crumb]
forall a b. (a -> b) -> a -> b
$ Transform c m u Bool
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
forall (m :: * -> *) c u crumb.
MonadFail m =>
Transform c m u Bool
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
acceptLocalPathT Transform c m u Bool
q)
{-# INLINE prunePathsToT #-}

-- | Find the 'LocalPath' to the first node that satisfies the predicate (in a pre-order traversal).
onePathToT :: forall c crumb u m. (Walker (WithLocalPath c crumb) u, MonadCatch m) => Transform c m u Bool -> Transform c m u (LocalPath crumb)
onePathToT :: Transform c m u Bool -> Transform c m u (LocalPath crumb)
onePathToT Transform c m u Bool
q = String
-> Transform c m u (LocalPath crumb)
-> Transform c m u (LocalPath crumb)
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
setFailMsg String
"No matching nodes found." (Transform c m u (LocalPath crumb)
 -> Transform c m u (LocalPath crumb))
-> Transform c m u (LocalPath crumb)
-> Transform c m u (LocalPath crumb)
forall a b. (a -> b) -> a -> b
$
               Transform (WithLocalPath c crumb) m u (LocalPath crumb)
-> Transform c m u (LocalPath crumb)
forall c crumb (m :: * -> *) a b.
Transform (WithLocalPath c crumb) m a b -> Transform c m a b
withLocalPathT (Transform (WithLocalPath c crumb) m u (LocalPath crumb)
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
forall c u (m :: * -> *) b.
(Walker c u, MonadCatch m) =>
Transform c m u b -> Transform c m u b
onetdT (Transform (WithLocalPath c crumb) m u (LocalPath crumb)
 -> Transform (WithLocalPath c crumb) m u (LocalPath crumb))
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
forall a b. (a -> b) -> a -> b
$ Transform c m u Bool
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
forall (m :: * -> *) c u crumb.
MonadFail m =>
Transform c m u Bool
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
acceptLocalPathT Transform c m u Bool
q)
{-# INLINE onePathToT #-}

-- | Find the 'LocalPath' to the first descendent node that satisfies the predicate (in a pre-order traversal).
oneNonEmptyPathToT :: (Walker (WithLocalPath c crumb) u, MonadCatch m) => Transform c m u Bool -> Transform c m u (LocalPath crumb)
oneNonEmptyPathToT :: Transform c m u Bool -> Transform c m u (LocalPath crumb)
oneNonEmptyPathToT Transform c m u Bool
q = String
-> Transform c m u (LocalPath crumb)
-> Transform c m u (LocalPath crumb)
forall (m :: * -> *) a. MonadCatch m => String -> m a -> m a
setFailMsg String
"No matching nodes found." (Transform c m u (LocalPath crumb)
 -> Transform c m u (LocalPath crumb))
-> Transform c m u (LocalPath crumb)
-> Transform c m u (LocalPath crumb)
forall a b. (a -> b) -> a -> b
$
                       Transform (WithLocalPath c crumb) m u (LocalPath crumb)
-> Transform c m u (LocalPath crumb)
forall c crumb (m :: * -> *) a b.
Transform (WithLocalPath c crumb) m a b -> Transform c m a b
withLocalPathT (Transform (WithLocalPath c crumb) m u (LocalPath crumb)
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
forall c u (m :: * -> *) b.
(Walker c u, MonadCatch m) =>
Transform c m u b -> Transform c m u b
oneT (Transform (WithLocalPath c crumb) m u (LocalPath crumb)
 -> Transform (WithLocalPath c crumb) m u (LocalPath crumb))
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
forall a b. (a -> b) -> a -> b
$ Transform (WithLocalPath c crumb) m u (LocalPath crumb)
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
forall c u (m :: * -> *) b.
(Walker c u, MonadCatch m) =>
Transform c m u b -> Transform c m u b
onetdT (Transform (WithLocalPath c crumb) m u (LocalPath crumb)
 -> Transform (WithLocalPath c crumb) m u (LocalPath crumb))
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
forall a b. (a -> b) -> a -> b
$ Transform c m u Bool
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
forall (m :: * -> *) c u crumb.
MonadFail m =>
Transform c m u Bool
-> Transform (WithLocalPath c crumb) m u (LocalPath crumb)
acceptLocalPathT Transform c m u Bool
q)
{-# INLINE oneNonEmptyPathToT #-}


-- local function used by uniquePathToT and uniquePrunePathToT
requireUniquePath :: MonadFail m => Transform c m [LocalPath crumb] (LocalPath crumb)
requireUniquePath :: Transform c m [LocalPath crumb] (LocalPath crumb)
requireUniquePath = ([LocalPath crumb] -> m (LocalPath crumb))
-> Transform c m [LocalPath crumb] (LocalPath crumb)
forall k a (m :: k -> *) (b :: k) c.
(a -> m b) -> Transform c m a b
contextfreeT (([LocalPath crumb] -> m (LocalPath crumb))
 -> Transform c m [LocalPath crumb] (LocalPath crumb))
-> ([LocalPath crumb] -> m (LocalPath crumb))
-> Transform c m [LocalPath crumb] (LocalPath crumb)
forall a b. (a -> b) -> a -> b
$ \ [LocalPath crumb]
ps -> case [LocalPath crumb]
ps of
                                             []  -> String -> m (LocalPath crumb)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No matching nodes found."
                                             [LocalPath crumb
p] -> LocalPath crumb -> m (LocalPath crumb)
forall (m :: * -> *) a. Monad m => a -> m a
return LocalPath crumb
p
                                             [LocalPath crumb]
_   -> String -> m (LocalPath crumb)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m (LocalPath crumb)) -> String -> m (LocalPath crumb)
forall a b. (a -> b) -> a -> b
$ String
"Ambiguous: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([LocalPath crumb] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LocalPath crumb]
ps) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" matching nodes found."
{-# INLINE requireUniquePath #-}

-- | Find the 'LocalPath' to the node that satisfies the predicate, failing if that does not uniquely identify a node.
uniquePathToT :: (Walker (WithLocalPath c crumb) u, MonadCatch m) => Transform c m u Bool -> Transform c m u (LocalPath crumb)
uniquePathToT :: Transform c m u Bool -> Transform c m u (LocalPath crumb)
uniquePathToT Transform c m u Bool
q = Transform c m u Bool -> Transform c m u [LocalPath crumb]
forall c crumb u (m :: * -> *).
(Walker (WithLocalPath c crumb) u, MonadCatch m) =>
Transform c m u Bool -> Transform c m u [LocalPath crumb]
pathsToT Transform c m u Bool
q Transform c m u [LocalPath crumb]
-> Transform c m [LocalPath crumb] (LocalPath crumb)
-> Transform c m u (LocalPath crumb)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Transform c m [LocalPath crumb] (LocalPath crumb)
forall (m :: * -> *) c crumb.
MonadFail m =>
Transform c m [LocalPath crumb] (LocalPath crumb)
requireUniquePath
{-# INLINE uniquePathToT #-}

-- | Build a 'LocalPath' to the node that satisfies the predicate, failing if that does not uniquely identify a node (ignoring nodes below successes).
uniquePrunePathToT :: (Walker (WithLocalPath c crumb) u, MonadCatch m) => Transform c m u Bool -> Transform c m u (LocalPath crumb)
uniquePrunePathToT :: Transform c m u Bool -> Transform c m u (LocalPath crumb)
uniquePrunePathToT Transform c m u Bool
q = Transform c m u Bool -> Transform c m u [LocalPath crumb]
forall c crumb u (m :: * -> *).
(Walker (WithLocalPath c crumb) u, MonadCatch m) =>
Transform c m u Bool -> Transform c m u [LocalPath crumb]
prunePathsToT Transform c m u Bool
q Transform c m u [LocalPath crumb]
-> Transform c m [LocalPath crumb] (LocalPath crumb)
-> Transform c m u (LocalPath crumb)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Transform c m [LocalPath crumb] (LocalPath crumb)
forall (m :: * -> *) c crumb.
MonadFail m =>
Transform c m [LocalPath crumb] (LocalPath crumb)
requireUniquePath
{-# INLINE uniquePrunePathToT #-}

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