{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableSuperClasses #-}
module Control.MultiWalk (
MultiTag (..),
MultiSub (..),
query,
walk,
walkM,
Walk,
Query,
walkSub,
querySub,
buildMultiW,
buildMultiQ,
(.>),
(?>),
ToSpec,
ToSpecSel,
Spec (..),
SelSpec (..),
Trav,
MatchWith,
Under,
MultiWalk,
FList (..),
QList (..),
BuildF (..),
BuildQ (..),
)
where
import Control.Monad ((>=>))
import Control.MultiWalk.Contains
import Data.Functor.Identity (Identity (Identity, runIdentity))
import Data.Kind (Type)
class
( BuildF (MultiWalk' tag) (MultiTypes tag)
, BuildQ (MultiWalk' tag) (MultiTypes tag)
) =>
MultiTag tag
where
type MultiTypes tag :: [Type]
class MultiSub tag t where
type SubTypes tag t :: Spec
type HasSubTag tag t :: Type
type HasSubTag tag t = GSubTag
type MultiWalk tag t =
( AllMods (TContains (MultiTypes tag)) (SubTypes tag t)
, QContains (MultiTypes tag) t
, FContains (MultiTypes tag) t
, HasSub (HasSubTag tag t) (SubTypes tag t) t
)
class (MultiWalk tag t) => MultiWalk' tag t
instance (MultiWalk tag t) => MultiWalk' tag t
querySub :: forall tag t m. (Monoid m, MultiWalk tag t) => QList m (MultiTypes tag) -> t -> m
querySub :: forall tag t m.
(Monoid m, MultiWalk tag t) =>
QList m (MultiTypes tag) -> t -> m
querySub = forall tag (ls :: Spec) t (fs :: [*]) m.
(HasSub tag ls t, Monoid m, AllMods (TContains fs) ls) =>
QList m fs -> t -> m
getSubWithQList @(HasSubTag tag t) @(SubTypes tag t)
walkSub :: forall tag t m. (Applicative m, MultiWalk tag t) => FList m (MultiTypes tag) -> t -> m t
walkSub :: forall tag t (m :: * -> *).
(Applicative m, MultiWalk tag t) =>
FList m (MultiTypes tag) -> t -> m t
walkSub = forall tag (ls :: Spec) t (fs :: [*]) (m :: * -> *).
(HasSub tag ls t, Applicative m, AllMods (TContains fs) ls) =>
FList m fs -> t -> m t
modSubWithFList @(HasSubTag tag t) @(SubTypes tag t)
query ::
forall tag m t a.
( MultiTag tag
, MultiWalk tag a
, MultiWalk tag t
, Monoid m
) =>
(t -> m) ->
a ->
m
query :: forall tag m t a.
(MultiTag tag, MultiWalk tag a, MultiWalk tag t, Monoid m) =>
(t -> m) -> a -> m
query t -> m
f =
forall tag m.
(MultiTag tag, Monoid m) =>
(Query tag m
-> QList m (MultiTypes tag) -> QList m (MultiTypes tag))
-> Query tag m
buildMultiQ @tag forall a b. (a -> b) -> a -> b
$ \Query tag m
go QList m (MultiTypes tag)
l ->
QList m (MultiTypes tag)
l forall (ls :: [*]) t m.
QContains ls t =>
QList m ls -> (t -> m) -> QList m ls
?> \t
x -> t -> m
f t
x forall a. Semigroup a => a -> a -> a
<> Query tag m
go t
x
walk ::
forall tag t c.
(MultiTag tag, MultiWalk tag c, MultiWalk tag t) =>
(t -> t) ->
c ->
c
walk :: forall tag t c.
(MultiTag tag, MultiWalk tag c, MultiWalk tag t) =>
(t -> t) -> c -> c
walk t -> t
f = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tag t a (m :: * -> *).
(Monad m, MultiTag tag, MultiWalk tag a, MultiWalk tag t) =>
(t -> m t) -> a -> m a
walkM @tag (forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> t
f)
walkM ::
forall tag t a m.
( Monad m
, MultiTag tag
, MultiWalk tag a
, MultiWalk tag t
) =>
(t -> m t) ->
a ->
m a
walkM :: forall tag t a (m :: * -> *).
(Monad m, MultiTag tag, MultiWalk tag a, MultiWalk tag t) =>
(t -> m t) -> a -> m a
walkM t -> m t
f =
forall tag (m :: * -> *).
(MultiTag tag, Applicative m) =>
(Walk tag m
-> FList m (MultiTypes tag) -> FList m (MultiTypes tag))
-> Walk tag m
buildMultiW @tag forall a b. (a -> b) -> a -> b
$ \Walk tag m
go FList m (MultiTypes tag)
l ->
FList m (MultiTypes tag)
l forall (ls :: [*]) t (m :: * -> *).
FContains ls t =>
FList m ls -> (t -> m t) -> FList m ls
.> (t -> m t
f forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Walk tag m
go)
type Query tag m = forall t. MultiWalk tag t => t -> m
buildMultiQ ::
forall tag m.
(MultiTag tag, Monoid m) =>
( Query tag m ->
QList m (MultiTypes tag) ->
QList m (MultiTypes tag)
) ->
Query tag m
buildMultiQ :: forall tag m.
(MultiTag tag, Monoid m) =>
(Query tag m
-> QList m (MultiTypes tag) -> QList m (MultiTypes tag))
-> Query tag m
buildMultiQ Query tag m -> QList m (MultiTypes tag) -> QList m (MultiTypes tag)
f = forall (l :: [*]) t m. QContains l t => QList m l -> t -> m
qGet QList m (MultiTypes tag)
qlist
where
qlist :: QList m (MultiTypes tag)
qlist :: QList m (MultiTypes tag)
qlist = Query tag m -> QList m (MultiTypes tag) -> QList m (MultiTypes tag)
f Query tag m
go forall a b. (a -> b) -> a -> b
$ forall (c :: * -> Constraint) (ls :: [*]) m.
BuildQ c ls =>
(forall t. c t => t -> m) -> QList m ls
buildQ @(MultiWalk' tag) Query tag m
go
go :: forall s. MultiWalk tag s => s -> m
go :: Query tag m
go = forall tag t m.
(Monoid m, MultiWalk tag t) =>
QList m (MultiTypes tag) -> t -> m
querySub @tag QList m (MultiTypes tag)
qlist
type Walk tag m = forall t. MultiWalk tag t => t -> m t
buildMultiW ::
forall tag m.
(MultiTag tag, Applicative m) =>
( Walk tag m ->
FList m (MultiTypes tag) ->
FList m (MultiTypes tag)
) ->
Walk tag m
buildMultiW :: forall tag (m :: * -> *).
(MultiTag tag, Applicative m) =>
(Walk tag m
-> FList m (MultiTypes tag) -> FList m (MultiTypes tag))
-> Walk tag m
buildMultiW Walk tag m -> FList m (MultiTypes tag) -> FList m (MultiTypes tag)
f = forall (l :: [*]) t (m :: * -> *).
FContains l t =>
FList m l -> t -> m t
fGet FList m (MultiTypes tag)
flist
where
flist :: FList m (MultiTypes tag)
flist :: FList m (MultiTypes tag)
flist = Walk tag m -> FList m (MultiTypes tag) -> FList m (MultiTypes tag)
f Walk tag m
go forall a b. (a -> b) -> a -> b
$ forall (c :: * -> Constraint) (ls :: [*]) (m :: * -> *).
BuildF c ls =>
(forall t. c t => t -> m t) -> FList m ls
buildF @(MultiWalk' tag) Walk tag m
go
go :: forall s. MultiWalk tag s => s -> m s
go :: Walk tag m
go = forall tag t (m :: * -> *).
(Applicative m, MultiWalk tag t) =>
FList m (MultiTypes tag) -> t -> m t
walkSub @tag FList m (MultiTypes tag)
flist
class All c ls => BuildQ c ls where
buildQ :: (forall t. c t => t -> m) -> QList m ls
instance BuildQ c '[] where
buildQ :: forall m. (forall t. c t => t -> m) -> QList m '[]
buildQ forall t. c t => t -> m
_ = forall m. QList m '[]
QNil
instance (BuildQ c ls, c l) => BuildQ c (l : ls) where
buildQ :: forall m. (forall t. c t => t -> m) -> QList m (l : ls)
buildQ forall t. c t => t -> m
f = forall t. c t => t -> m
f forall x m (xs :: [*]). (x -> m) -> QList m xs -> QList m (x : xs)
:?: forall (c :: * -> Constraint) (ls :: [*]) m.
BuildQ c ls =>
(forall t. c t => t -> m) -> QList m ls
buildQ @c @ls forall t. c t => t -> m
f
class All c ls => BuildF c ls where
buildF :: (forall t. c t => t -> m t) -> FList m ls
instance BuildF c '[] where
buildF :: forall (m :: * -> *). (forall t. c t => t -> m t) -> FList m '[]
buildF forall t. c t => t -> m t
_ = forall (m :: * -> *). FList m '[]
FNil
instance (BuildF c ls, c l) => BuildF c (l : ls) where
buildF :: forall (m :: * -> *).
(forall t. c t => t -> m t) -> FList m (l : ls)
buildF forall t. c t => t -> m t
f = forall t. c t => t -> m t
f forall x (m :: * -> *) (xs :: [*]).
(x -> m x) -> FList m xs -> FList m (x : xs)
:.: forall (c :: * -> Constraint) (ls :: [*]) (m :: * -> *).
BuildF c ls =>
(forall t. c t => t -> m t) -> FList m ls
buildF @c @ls forall t. c t => t -> m t
f
(?>) :: QContains ls t => QList m ls -> (t -> m) -> QList m ls
?> :: forall (ls :: [*]) t m.
QContains ls t =>
QList m ls -> (t -> m) -> QList m ls
(?>) = forall (l :: [*]) t m.
QContains l t =>
QList m l -> (t -> m) -> QList m l
qSet
(.>) :: FContains ls t => FList m ls -> (t -> m t) -> FList m ls
.> :: forall (ls :: [*]) t (m :: * -> *).
FContains ls t =>
FList m ls -> (t -> m t) -> FList m ls
(.>) = forall (l :: [*]) t (m :: * -> *).
FContains l t =>
FList m l -> (t -> m t) -> FList m l
fSet