{-# LANGUAGE UnicodeSyntax, FlexibleContexts #-}
-- | Patterns allow monadic scrutinisation of the graph (modifications are not possible) while keeping track of matched nodes (history). A 'Pattern' is interpreted by 'runPattern' that returns a result for each position in the graph where the pattern matches. It is allowed to 'fail' inside the 'Pattern' monad, indicating that the pattern does not match, which corresponds to conditional rewriting.
module GraphRewriting.Pattern (module GraphRewriting.Pattern, PatternT, Pattern, Match, (<|>)) where

import Prelude.Unicode
import GraphRewriting.Pattern.Internal
import GraphRewriting.Graph.Read
import Control.Monad.Reader
import Control.Monad.List
import Data.Functor.Identity
import qualified Data.Set as Set (empty, insert, member)
import Control.Applicative


-- | A pattern represents a graph scrutinisation that memorises all the scrutinised nodes during matching.
type Pattern n = PatternT n Identity

instance MonadFail Identity where
	fail :: forall a. String -> Identity a
fail = forall a. HasCallStack => String -> a
error

instance Monad m ⇒ Monad (PatternT n m) where
	return :: forall a. a -> PatternT n m a
return a
x = forall n (m :: * -> *) a.
(Match -> ReaderT (Graph n) (ListT m) (Match, a)) -> PatternT n m a
PatternT forall a b. (a -> b) -> a -> b
$ \Match
h → forall (m :: * -> *) a. Monad m => a -> m a
return ([],a
x)
	PatternT n m a
p >>= :: forall a b.
PatternT n m a -> (a -> PatternT n m b) -> PatternT n m b
>>= a -> PatternT n m b
f = forall n (m :: * -> *) a.
(Match -> ReaderT (Graph n) (ListT m) (Match, a)) -> PatternT n m a
PatternT forall a b. (a -> b) -> a -> b
$ \Match
h → do
		(Match
m1,a
x) ← forall n (m :: * -> *) a.
PatternT n m a -> Match -> ReaderT (Graph n) (ListT m) (Match, a)
patternT PatternT n m a
p Match
h
		(Match
m2,b
y) ← forall n (m :: * -> *) a.
PatternT n m a -> Match -> ReaderT (Graph n) (ListT m) (Match, a)
patternT (a -> PatternT n m b
f a
x) (forall a. [a] -> [a]
reverse Match
m1 forall α. [α] -> [α] -> [α]
⧺ Match
h)
		forall (m :: * -> *) a. Monad m => a -> m a
return (Match
m1 forall α. [α] -> [α] -> [α]
⧺ Match
m2, b
y)

instance MonadFail m ⇒ MonadFail (PatternT n m) where
	fail :: forall a. String -> PatternT n m a
fail String
str = forall n (m :: * -> *) a.
(Match -> ReaderT (Graph n) (ListT m) (Match, a)) -> PatternT n m a
PatternT forall a b. (a -> b) -> a -> b
$ \Match
h → forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
str)

instance MonadTrans (PatternT n) where
	lift :: forall (m :: * -> *) a. Monad m => m a -> PatternT n m a
lift m a
m = forall n (m :: * -> *) a.
(Match -> ReaderT (Graph n) (ListT m) (Match, a)) -> PatternT n m a
PatternT forall a b. (a -> b) -> a -> b
$ \Match
h → do
		a
x ← forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
m
		forall (m :: * -> *) a. Monad m => a -> m a
return ([],a
x)

-- TODO: Change constraint to Functor m if possible
instance Monad m ⇒ Functor (PatternT n m) where fmap :: forall a b. (a -> b) -> PatternT n m a -> PatternT n m b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

-- TODO: Change constraint from Monad m if possible
instance Monad m ⇒ Applicative (PatternT n m) where
	pure :: forall a. a -> PatternT n m a
pure = forall (m :: * -> *) a. Monad m => a -> m a
return
	PatternT n m (a -> b)
f <*> :: forall a b.
PatternT n m (a -> b) -> PatternT n m a -> PatternT n m b
<*> PatternT n m a
x = do
		a -> b
f' ← PatternT n m (a -> b)
f
		a -> b
f' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PatternT n m a
x

instance MonadFail m ⇒ Alternative (PatternT n m) where
	empty :: forall a. PatternT n m a
empty = forall (m :: * -> *) a. MonadPlus m => m a
mzero
	<|> :: forall a. PatternT n m a -> PatternT n m a -> PatternT n m a
(<|>) = forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance MonadFail m ⇒ Semigroup (PatternT n m a) where
	<> :: PatternT n m a -> PatternT n m a -> PatternT n m a
(<>) = forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance MonadFail m ⇒ Monoid (PatternT n m a) where
	mempty :: PatternT n m a
mempty = forall (m :: * -> *) a. MonadPlus m => m a
mzero
	mappend :: PatternT n m a -> PatternT n m a -> PatternT n m a
mappend = forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance MonadFail m ⇒ MonadPlus (PatternT n m) where
	mzero :: forall a. PatternT n m a
mzero = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty result list"
	mplus :: forall a. PatternT n m a -> PatternT n m a -> PatternT n m a
mplus PatternT n m a
p PatternT n m a
q = forall n (m :: * -> *) a.
(Match -> ReaderT (Graph n) (ListT m) (Match, a)) -> PatternT n m a
PatternT forall a b. (a -> b) -> a -> b
$ \Match
h → do -- TODO: this implements choice. Is mplus the right function for that?
		Graph n
g ← forall r (m :: * -> *). MonadReader r m => m r
ask
		forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall n (m :: * -> *) a.
PatternT n m a -> Match -> ReaderT (Graph n) (ListT m) (Match, a)
patternT PatternT n m a
p Match
h) Graph n
g forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall n (m :: * -> *) a.
PatternT n m a -> Match -> ReaderT (Graph n) (ListT m) (Match, a)
patternT PatternT n m a
q Match
h) Graph n
g

runPatternT ∷ PatternT n m a → Graph n → m [(Match,a)]
runPatternT :: forall n (m :: * -> *) a.
PatternT n m a -> Graph n -> m [(Match, a)]
runPatternT = forall n (m :: * -> *) a.
Match -> PatternT n m a -> Graph n -> m [(Match, a)]
runPatternT' []

-- | Apply a pattern on a graph returning a result for each matching position in the graph together with the matched nodes.
runPattern ∷ Pattern n a → Graph n → [(Match,a)]
runPattern :: forall n a. Pattern n a -> Graph n -> [(Match, a)]
runPattern Pattern n a
p = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n (m :: * -> *) a.
PatternT n m a -> Graph n -> m [(Match, a)]
runPatternT Pattern n a
p

evalPattern ∷ Pattern n a → Graph n → [a]
evalPattern :: forall n a. Pattern n a -> Graph n -> [a]
evalPattern Pattern n a
p = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n a. Pattern n a -> Graph n -> [(Match, a)]
runPattern Pattern n a
p

execPattern ∷ Pattern n a → Graph n → [Match]
execPattern :: forall n a. Pattern n a -> Graph n -> [Match]
execPattern Pattern n a
p = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n a. Pattern n a -> Graph n -> [(Match, a)]
runPattern Pattern n a
p

-- combinators ---------------------------------------------------------------

-- | Something like an implicit monadic map
branch ∷ Monad m ⇒ [a] → PatternT n m a -- TODO: express this using Alternative?
branch :: forall (m :: * -> *) a n. Monad m => [a] -> PatternT n m a
branch [a]
xs = forall n (m :: * -> *) a.
(Match -> ReaderT (Graph n) (ListT m) (Match, a)) -> PatternT n m a
PatternT forall a b. (a -> b) -> a -> b
$ \Match
h → forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. m [a] -> ListT m a
ListT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return [([],a
x) | a
x ← [a]
xs]

-- | 'branch' on each node, add it to the history, and return it
branchNodes ∷ MonadFail m ⇒ [Node] → PatternT n m Node
branchNodes :: forall (m :: * -> *) n. MonadFail m => Match -> PatternT n m Node
branchNodes Match
ns = do -- TODO: express this using Alternative?
	Node
n ← forall (m :: * -> *) a n. Monad m => [a] -> PatternT n m a
branch Match
ns
	forall (m :: * -> *) n. MonadFail m => Node -> PatternT n m ()
visit Node
n
	forall (m :: * -> *) a. Monad m => a -> m a
return Node
n

-- | Probe whether a pattern matches somewhere on the graph. You might want to combine this with 'amnesia'.
probe ∷ Monad m ⇒ PatternT n m a → PatternT n m Bool
probe :: forall (m :: * -> *) n a.
Monad m =>
PatternT n m a -> PatternT n m Bool
probe PatternT n m a
p = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) n a.
Monad m =>
PatternT n m a -> PatternT n m [Match]
matches PatternT n m a
p

-- | probe a pattern returning the matches it has on the graph. You might want to combine this with 'amnesia'.
matches ∷ Monad m ⇒ PatternT n m a → PatternT n m [Match]
matches :: forall (m :: * -> *) n a.
Monad m =>
PatternT n m a -> PatternT n m [Match]
matches PatternT n m a
p = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) n a.
Monad m =>
PatternT n m a -> PatternT n m [(Match, a)]
match PatternT n m a
p

-- TODO: isn't this essentially same as runPatternT?
-- | probe a pattern returning the matches it has on the graph. You might want to combine this with 'amnesia'.
match ∷ Monad m ⇒ PatternT n m a → PatternT n m [(Match, a)]
match :: forall (m :: * -> *) n a.
Monad m =>
PatternT n m a -> PatternT n m [(Match, a)]
match PatternT n m a
p = forall n (m :: * -> *) a.
(Match -> ReaderT (Graph n) (ListT m) (Match, a)) -> PatternT n m a
PatternT forall a b. (a -> b) -> a -> b
$ \Match
h → do
	ListT m (Match, a)
matches ← forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT forall a b. (a -> b) -> a -> b
$ forall n (m :: * -> *) a.
PatternT n m a -> Match -> ReaderT (Graph n) (ListT m) (Match, a)
patternT PatternT n m a
p Match
h) forall r (m :: * -> *). MonadReader r m => m r
ask -- list of all possible matches
	let roundup :: m [(Match, [(Match, a)])]
roundup = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\[(Match, a)]
xs → [(forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> a
fst [(Match, a)]
xs, [(Match, a)]
xs)]) (forall (m :: * -> *) a. ListT m a -> m [a]
runListT ListT m (Match, a)
matches) -- concatenation into one big match
	forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. m [a] -> ListT m a
ListT m [(Match, [(Match, a)])]
roundup

-- | choice over a list of patterns
anyOf ∷ Alternative f ⇒ [f a] → f a
anyOf :: forall (f :: * -> *) a. Alternative f => [f a] -> f a
anyOf = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) forall (f :: * -> *) a. Alternative f => f a
empty

-- | conditional rewriting: 'fail' when predicate is not met
require ∷ MonadFail m ⇒ Bool → m ()
require :: forall (m :: * -> *). MonadFail m => Bool -> m ()
require Bool
p = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"requirement not met"

-- | 'fail' if given pattern succeeds, succeed if it fails.
requireFailure ∷ MonadFail m ⇒ PatternT n m a → PatternT n m ()
requireFailure :: forall (m :: * -> *) n a.
MonadFail m =>
PatternT n m a -> PatternT n m ()
requireFailure PatternT n m a
p = forall (m :: * -> *). MonadFail m => Bool -> m ()
require forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) n a.
Monad m =>
PatternT n m a -> PatternT n m Bool
probe PatternT n m a
p

-- | 'fail' when monadic predicate is not met
requireM ∷ MonadFail m ⇒ m Bool → m ()
requireM :: forall (m :: * -> *). MonadFail m => m Bool -> m ()
requireM m Bool
p = m Bool
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadFail m => Bool -> m ()
require

-- some base patterns --------------------------------------------------------

-- | Lift a scrutinisation from 'Reader' to 'Pattern' leaving the history unchanged.
liftReader ∷ Monad m ⇒ Reader (Graph n) a → PatternT n m a
liftReader :: forall (m :: * -> *) n a.
Monad m =>
Reader (Graph n) a -> PatternT n m a
liftReader Reader (Graph n) a
r = forall n (m :: * -> *) a.
(Match -> ReaderT (Graph n) (ListT m) (Match, a)) -> PatternT n m a
PatternT forall a b. (a -> b) -> a -> b
$ \Match
h → do
	a
x ← forall r a. Reader r a -> r -> a
runReader Reader (Graph n) a
r forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall r (m :: * -> *). MonadReader r m => m r
ask
	forall (m :: * -> *) a. Monad m => a -> m a
return ([],a
x)

-- | any node anywhere in the graph
node ∷ (MonadFail m, View v n) ⇒ PatternT n m v
node :: forall (m :: * -> *) v n. (MonadFail m, View v n) => PatternT n m v
node = forall (m :: * -> *) n a.
Monad m =>
Reader (Graph n) a -> PatternT n m a
liftReader forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v n (m :: * -> *).
(View v n, MonadReader (Graph n) m, MonadFail m) =>
Node -> m v
inspectNode forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) n. MonadFail m => Match -> PatternT n m Node
branchNodes forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) n a.
Monad m =>
Reader (Graph n) a -> PatternT n m a
liftReader forall n (m :: * -> *). MonadReader (Graph n) m => m Match
readNodeList

-- | A specific node
nodeAt ∷ (Monad m, View v n) ⇒ Node → PatternT n m v
nodeAt :: forall (m :: * -> *) v n.
(Monad m, View v n) =>
Node -> PatternT n m v
nodeAt Node
ref = do
	v
n ← forall (m :: * -> *) n a.
Monad m =>
Reader (Graph n) a -> PatternT n m a
liftReader forall a b. (a -> b) -> a -> b
$ forall v n (m :: * -> *).
(View v n, MonadReader (Graph n) m, MonadFail m) =>
Node -> m v
inspectNode Node
ref
	forall n (m :: * -> *) a.
(Match -> ReaderT (Graph n) (ListT m) (Match, a)) -> PatternT n m a
PatternT forall a b. (a -> b) -> a -> b
$ \Match
h → forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ([Node
ref],v
n)

-- | any edge anywhere in the graph
edge ∷ Monad m ⇒ PatternT n m Edge
edge :: forall (m :: * -> *) n. Monad m => PatternT n m Edge
edge = forall (m :: * -> *) a n. Monad m => [a] -> PatternT n m a
branch forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) n a.
Monad m =>
Reader (Graph n) a -> PatternT n m a
liftReader forall n (m :: * -> *). MonadReader (Graph n) m => m [Edge]
readEdgeList

-- | node that is connected to given edge
nodeWith ∷ (MonadFail m, View v n) ⇒ Edge → PatternT n m v
nodeWith :: forall (m :: * -> *) v n.
(MonadFail m, View v n) =>
Edge -> PatternT n m v
nodeWith Edge
e = forall (m :: * -> *) n a.
Monad m =>
Reader (Graph n) a -> PatternT n m a
liftReader forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v n (m :: * -> *).
(View v n, MonadReader (Graph n) m, MonadFail m) =>
Node -> m v
inspectNode forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) n. MonadFail m => Match -> PatternT n m Node
branchNodes forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) n a.
Monad m =>
Reader (Graph n) a -> PatternT n m a
liftReader (forall n (m :: * -> *).
(MonadReader (Graph n) m, MonadFail m) =>
Edge -> m Match
attachedNodes Edge
e)

-- | edge that is attached to given node
edgeOf ∷ (Monad m, View [Port] n) ⇒ Node → PatternT n m Edge
edgeOf :: forall (m :: * -> *) n.
(Monad m, View [Edge] n) =>
Node -> PatternT n m Edge
edgeOf Node
n = forall (m :: * -> *) a n. Monad m => [a] -> PatternT n m a
branch forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) n a.
Monad m =>
Reader (Graph n) a -> PatternT n m a
liftReader (forall n (m :: * -> *).
(View [Edge] n, MonadReader (Graph n) m, MonadFail m) =>
Node -> m [Edge]
attachedEdges Node
n)

-- | node that is connected to the given node, but not that node itself
neighbour ∷ (MonadFail m) => (View [Port] n, View v n) ⇒ Node → PatternT n m v
neighbour :: forall (m :: * -> *) n v.
(MonadFail m, View [Edge] n, View v n) =>
Node -> PatternT n m v
neighbour Node
n = forall (m :: * -> *) n a.
Monad m =>
Reader (Graph n) a -> PatternT n m a
liftReader forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v n (m :: * -> *).
(View v n, MonadReader (Graph n) m, MonadFail m) =>
Node -> m v
inspectNode forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) n. MonadFail m => Match -> PatternT n m Node
branchNodes forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) n a.
Monad m =>
Reader (Graph n) a -> PatternT n m a
liftReader (forall n (m :: * -> *).
(View [Edge] n, MonadReader (Graph n) m, MonadFail m) =>
Node -> m Match
neighbours Node
n)

-- | node that is connected to the given node, permitting the node itself
relative ∷ (MonadFail m, View [Port] n, View v n) ⇒ Node → PatternT n m v
relative :: forall (m :: * -> *) n v.
(MonadFail m, View [Edge] n, View v n) =>
Node -> PatternT n m v
relative Node
n = forall (m :: * -> *) n a.
Monad m =>
Reader (Graph n) a -> PatternT n m a
liftReader forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v n (m :: * -> *).
(View v n, MonadReader (Graph n) m, MonadFail m) =>
Node -> m v
inspectNode forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) n. MonadFail m => Match -> PatternT n m Node
branchNodes forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) n a.
Monad m =>
Reader (Graph n) a -> PatternT n m a
liftReader (forall n (m :: * -> *).
(View [Edge] n, MonadReader (Graph n) m, MonadFail m) =>
Node -> m Match
relatives Node
n)

-- | nodes connected to given port of the specified node, not including the node itself.
-- Consider as an alternative 'linear' combined with 'nodeWith'.
adverse ∷ (MonadFail m, View [Port] n, View v n) ⇒ Port → Node → PatternT n m v
adverse :: forall (m :: * -> *) n v.
(MonadFail m, View [Edge] n, View v n) =>
Edge -> Node -> PatternT n m v
adverse Edge
p Node
n = forall (m :: * -> *) n a.
Monad m =>
Reader (Graph n) a -> PatternT n m a
liftReader forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v n (m :: * -> *).
(View v n, MonadReader (Graph n) m, MonadFail m) =>
Node -> m v
inspectNode forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) n. MonadFail m => Match -> PatternT n m Node
branchNodes forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) n a.
Monad m =>
Reader (Graph n) a -> PatternT n m a
liftReader (forall n (m :: * -> *).
(MonadReader (Graph n) m, MonadFail m) =>
Node -> Edge -> m Match
adverseNodes Node
n Edge
p)

-- controlling history and future --------------------------------------------

-- | A specific node
visit ∷ MonadFail m ⇒ Node → PatternT n m ()
visit :: forall (m :: * -> *) n. MonadFail m => Node -> PatternT n m ()
visit Node
n = do
	Bool
exists ← forall (m :: * -> *) n a.
Monad m =>
Reader (Graph n) a -> PatternT n m a
liftReader forall a b. (a -> b) -> a -> b
$ forall n (m :: * -> *). MonadReader (Graph n) m => Node -> m Bool
existNode Node
n
	if Bool
exists
		then forall n (m :: * -> *) a.
(Match -> ReaderT (Graph n) (ListT m) (Match, a)) -> PatternT n m a
PatternT forall a b. (a -> b) -> a -> b
$ \Match
h → forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ([Node
n],())
		else forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"visit: node with ID " forall α. [α] -> [α] -> [α]
⧺ forall a. Show a => a -> String
show Node
n forall α. [α] -> [α] -> [α]
⧺ String
" does not exist"

-- | Do not remember any of the nodes matched by the supplied pattern
amnesia ∷ Monad m ⇒ PatternT n m a → PatternT n m a
amnesia :: forall (m :: * -> *) n a.
Monad m =>
PatternT n m a -> PatternT n m a
amnesia PatternT n m a
p = forall n (m :: * -> *) a.
(Match -> ReaderT (Graph n) (ListT m) (Match, a)) -> PatternT n m a
PatternT forall a b. (a -> b) -> a -> b
$ \Match
h → do
	(Match
h',a
x) ← forall n (m :: * -> *) a.
PatternT n m a -> Match -> ReaderT (Graph n) (ListT m) (Match, a)
patternT PatternT n m a
p Match
h
	forall (m :: * -> *) a. Monad m => a -> m a
return ([],a
x)

-- | list of nodes matched until now with the most recent node in head position
history ∷ Monad m ⇒ PatternT n m Match
history :: forall (m :: * -> *) n. Monad m => PatternT n m Match
history = forall n (m :: * -> *) a.
(Match -> ReaderT (Graph n) (ListT m) (Match, a)) -> PatternT n m a
PatternT forall a b. (a -> b) -> a -> b
$ \Match
h → forall (m :: * -> *) a. Monad m => a -> m a
return ([],Match
h)

-- | a reference to the lastly matched node
previous ∷ Monad m ⇒ PatternT n m Node
previous :: forall (m :: * -> *) n. Monad m => PatternT n m Node
previous = forall a. [a] -> a
head forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) n. Monad m => PatternT n m Match
history

-- | only match nodes in the next pattern that have not been matched before
nextFresh ∷ Monad m ⇒ PatternT n m a → PatternT n m a
nextFresh :: forall (m :: * -> *) n a.
Monad m =>
PatternT n m a -> PatternT n m a
nextFresh = forall (m :: * -> *) n a.
Monad m =>
(Match -> Match -> Bool) -> PatternT n m a -> PatternT n m a
restrictOverlap forall a b. (a -> b) -> a -> b
$ \Match
past Match
future → forall (t :: * -> *) a. Foldable t => t a -> Bool
null Match
future Bool -> Bool -> Bool
∨ Bool -> Bool
not (forall a. [a] -> a
head Match
future forall α. Eq α => α -> [α] -> Bool
∈ Match
past)

-- | only accept the given node in the next match
nextIs ∷ Monad m ⇒ Node → PatternT n m a → PatternT n m a
nextIs :: forall (m :: * -> *) n a.
Monad m =>
Node -> PatternT n m a -> PatternT n m a
nextIs Node
next = forall (m :: * -> *) n a.
Monad m =>
(Match -> Match -> Bool) -> PatternT n m a -> PatternT n m a
restrictOverlap forall a b. (a -> b) -> a -> b
$ \Match
past Match
future → Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Match
future) Bool -> Bool -> Bool
∧ forall a. [a] -> a
head Match
future forall α. Eq α => α -> α -> Bool
≡ Node
next

-- | Restrict a pattern based on the which of nodes have been matched previously and which nodes will be matched in the future. The first parameter of the supplied function is the history with the most recently matched node in head position. The second parameter is the future with the next matched node in head position.
restrictOverlap ∷ Monad m ⇒ (Match → Match → Bool) → PatternT n m a → PatternT n m a
restrictOverlap :: forall (m :: * -> *) n a.
Monad m =>
(Match -> Match -> Bool) -> PatternT n m a -> PatternT n m a
restrictOverlap Match -> Match -> Bool
c PatternT n m a
p = forall n (m :: * -> *) a.
(Match -> ReaderT (Graph n) (ListT m) (Match, a)) -> PatternT n m a
PatternT forall a b. (a -> b) -> a -> b
$ \Match
h → do
	(Match
h',a
x) ← forall n (m :: * -> *) a.
PatternT n m a -> Match -> ReaderT (Graph n) (ListT m) (Match, a)
patternT PatternT n m a
p Match
h
	forall (m :: * -> *). MonadFail m => Bool -> m ()
require forall a b. (a -> b) -> a -> b
$ Match -> Match -> Bool
c Match
h Match
h'
	forall (m :: * -> *) a. Monad m => a -> m a
return (Match
h',a
x)
-- TODO: the check is only done after the whole pattern has matched (maybe do the check more often inbetween?)

-- | Nodes in the future may not be matched more than once.
linear ∷ Monad m ⇒ PatternT n m a → PatternT n m a
linear :: forall (m :: * -> *) n a.
Monad m =>
PatternT n m a -> PatternT n m a
linear = forall (m :: * -> *) n a.
Monad m =>
(Match -> Match -> Bool) -> PatternT n m a -> PatternT n m a
restrictOverlap forall a b. (a -> b) -> a -> b
$ \Match
hist Match
future → forall {a}. Ord a => Set a -> [a] -> Bool
isLinear forall a. Set a
Set.empty Match
future where
	isLinear :: Set a -> [a] -> Bool
isLinear Set a
left [] = Bool
True
	isLinear Set a
left (a
r:[a]
rs) = Bool -> Bool
not (a
r forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
left) Bool -> Bool -> Bool
∧ Set a -> [a] -> Bool
isLinear (a
r forall a. Ord a => a -> Set a -> Set a
`Set.insert` Set a
left) [a]
rs