{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableSuperClasses #-}

{- | This module provides functionality for recursively traversing and querying
   along multiple types.
-}
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)

{- | You should instantiate 'MultiTag' to a tag associated to the structure you
   are working with. The tag is mostly there to prevent orphan instances, since
   people are often working with structures from other packages (Pandoc AST,
   HTML, etc.)
-}
class
  ( BuildF (MultiWalk' tag) (MultiTypes tag)
  , BuildQ (MultiWalk' tag) (MultiTypes tag)
  ) =>
  MultiTag tag
  where
  -- | The types that will be used in the walks and queries; every type listed here
  --    should have a 'MultiSub' instance. (The compiler will complain about this.)
  type MultiTypes tag :: [Type]

class MultiSub tag t where
  -- | A list of substructure specifications for types that are substructures to
  -- this type; all types listed here should also be listed in the corresponding
  -- 'MultiTypes', but you can omit types from there that should not be regarded
  -- as subtypes.
  --
  -- Substructure specifications are special datakinds that you can generate
  -- using 'ToSpec' and 'ToSpecSel', and the combinators (eg. 'Under',
  -- 'MatchWith' and 'Trav').
  type SubTypes tag t :: Spec

  -- | If you want to write HasSub instances by hand (not that easy), you can
  -- put the associated HasSub tag here. Defaults to 'GSubTag' (which derives
  -- 'Generic' instances).
  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

-- | Query (only) substructures by applying functions from 'QList'.
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)

-- | Modify (only) substructures by applying functions from 'FList'.
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 a structure with a single query function (just like Pandoc.Walk).
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

-- | Modify a structure by walking with a single function (just like Pandoc.Walk).
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)

-- | Modify a structure by walking with a single function (just like Pandoc.Walk).
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

{- | Most general way to create a query. Create a query with multiple functions,
   targeting multiple types.

   First argument is a function that takes a query, an empty list of queries and
   should return a list of queries populated with the multiple query functions.

   By "tying a knot", the first argument you are supplied with is almost the
   result of 'buildMultiQ' itself, the only difference being that it only
   queries /substructures/ of the type. It's a responsability of each function
   in the 'QList' to apply this function to its argument in any desired way, as
   to continue recursing down the "type tree".

   You can add functions to the empty 'QList' via '?>'.

   > multi :: Block -> [Text]
   > multi = buildMultiQ @PTag $ \sub list ->
   >     list ?> blks sub
   >          ?> inls sub
   >   where
   >     blks _ (CodeBlock _ c) = [c]
   >     blks f x = f x
   >     inls _ (Code _ c) = [c]
   >     inls f x = f x
-}
buildMultiQ ::
  forall tag m.
  (MultiTag tag, Monoid m) =>
  ( Query tag m ->
    QList m (MultiTypes tag) ->
    -- \^ Empty query that you should modify.
    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

{- | Most general way to create a walk. Create a walk with multiple functions,
   targeting multiple types.

   First argument is a function that takes a walk, an empty list of functions and
   should return a list of functions populated with the multiple walk functions.

   By "tying a knot", the first argument you are supplied with is almost the
   result of 'buildMultiW' itself, the only difference being that it only walks
   /substructures/ of the type. It's a responsability of each function in the
   'FList' to apply this function to its argument in any desired way, as to
   continue recursing down the "type tree".

   You can add functions to the empty 'FList' via '.>'.

   > multi :: Applicative m => Block -> m Block
   > multi = buildMultiW @PTag $ \sub list ->
   >     list .> blks sub
   >          .> inls sub
   >   where
   >     blks _ (CodeBlock _ c) = Para [Str c]
   >     blks f x = f x
   >     inls _ (Code _ c) = Str c
   >     inls f x = f x
-}
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

-- | Add a function to a 'QList'.
(?>) :: 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

-- | Add a function to a 'FList'.
(.>) :: 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