module Language.Fiddle.Ast.Internal.Instances.Walk (Walk (..), GWalk (..), walk_, WalkContinuation (..)) where

import Data.Typeable
import GHC.Generics

-- | Like walk, but assumes no local state and always continue
walk_ ::
  (Monad m, Traversable f, Typeable f, Typeable a, Walk t) =>
  (forall t'. (Walk t', Typeable t', Typeable f, Typeable a) => t' f a -> m ()) ->
  t f a ->
  m ()
walk_ fn t = walk (\t _ -> fn t >> return (Continue ())) t ()

data WalkContinuation s where
  Continue :: s -> WalkContinuation s
  Stop :: WalkContinuation s

class (Typeable t) => Walk t where
  walk ::
    (Monad m, Traversable f, Typeable f, Typeable a) =>
    (forall t'. (Walk t', Typeable t', Typeable f, Typeable a) => t' f a -> s -> m (WalkContinuation s)) ->
    t f a ->
    s ->
    m ()
  default walk ::
    (GWalk (Rep (t f a)) f a, Generic (t f a), Monad m, Traversable f, Typeable f, Typeable a) =>
    (forall t'. (Walk t', Typeable t', Typeable f, Typeable a) => t' f a -> s -> m (WalkContinuation s)) ->
    t f a ->
    s ->
    m ()
  walk fn = gwalk fn . from

class GWalk r f a where
  gwalk ::
    (Monad m, Typeable f, Typeable a, Traversable f) =>
    (forall t'. (Walk t', Typeable t') => t' f a -> s -> m (WalkContinuation s)) ->
    r x ->
    s ->
    m ()

instance (Traversable f, GWalk t f a) => (GWalk (M1 i c t) f a) where
  gwalk fn (M1 a) = gwalk fn a

instance
  ( Traversable f,
    GWalk l f a,
    GWalk r f a
  ) =>
  (GWalk (l :+: r) f a)
  where
  gwalk fn (L1 l) = gwalk fn l
  gwalk fn (R1 l) = gwalk fn l

instance
  ( Traversable f,
    GWalk l f a,
    GWalk r f a
  ) =>
  (GWalk (l :*: r) f a)
  where
  gwalk fn (l :*: r) s = gwalk fn l s >> gwalk fn r s

instance
  ( Traversable f,
    Walk t
  ) =>
  GWalk (Rec0 (t f a)) f a
  where
  gwalk fn (K1 k) s = do
    ( \case
        Continue s' -> walk fn k s'
        _ -> return ()
      )
      =<< fn k s

instance
  ( Traversable f,
    Traversable func,
    Walk t
  ) =>
  GWalk (Rec0 (func (t f a))) f a
  where
  gwalk fn (K1 fk) s = do
    mapM_
      ( \tfa -> do
          ( \case
              Continue s' -> walk fn tfa s'
              _ -> return ()
            )
            =<< fn tfa s
      )
      fk

instance GWalk (Rec0 q) f a where
  gwalk _ _ _ = return ()