-- | Provides a MonadSpawn overlay that may catch specific spawn calls and handle them itself.
module System.Chatty.Spawn.Overlay where

import System.Chatty.Spawn
import Control.Monad.Trans.Class
import Control.Monad.IO.Class
import System.IO

-- | MonadSpawn overlay. Carries a map of own command implementations that are called instead of the actual ones.
newtype SpawnOverlayT m a = SpawnOverlay { runSpawnOverlayT :: [(String,[String] -> String -> m (Int,String))] -> m (a,[(String,[String] -> String -> m (Int,String))]) }

instance Monad m => Monad (SpawnOverlayT m) where
  return a = SpawnOverlay $ \o -> return (a,o)
  (SpawnOverlay o) >>= f = SpawnOverlay $ \s -> do (a,s') <- o s; runSpawnOverlayT (f a) s'

instance MonadTrans SpawnOverlayT where
  lift m = SpawnOverlay $ \s -> do a <- m; return (a,s)

instance MonadIO m => MonadIO (SpawnOverlayT m) where
  liftIO = lift . liftIO

instance Monad m => Functor (SpawnOverlayT m) where
  fmap f a = SpawnOverlay $ \s -> do (a',s') <- runSpawnOverlayT a s; return (f a',s')

instance MonadSpawn m => MonadSpawn (SpawnOverlayT m) where
  mspw pn as (Right si) = SpawnOverlay $ \s ->
    case pn `elem` (map fst s) of
      True -> let c = snd $ head $ filter ((==pn).fst) s
              in do
                (r,so) <- c as si
                return ((r,so,[]),s)
      False -> do
                r <- mspw pn as (Right si)
                return (r,s)
  mspw pn as (Left h) = lift $ mspw pn as (Left h)
  mah pn = SpawnOverlay $ \s ->
    case pn `elem` (map fst s) of
      True -> return (False,s)
      False -> do
        ah <- mah pn
        return (ah,s)