Command.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Lambdabot.Command 
    ( Command(..)
    , cmdNames
    , command
    , runCommand
    , Cmd
    , execCmd
    , getCmdName
    , withMsg
    , readNick
    , showNick
    , getServer
    , getSender
    , getTarget
    , getLambdabotName
    , say
    ) where

import Lambdabot.Config
import Lambdabot.Logging
import qualified Lambdabot.Message as Msg
import Lambdabot.Nick

import Control.Applicative
import Control.Monad.Fail (MonadFail)
import qualified Control.Monad.Fail
import Control.Monad.Base
import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Control.Monad.Writer

data CmdArgs = forall a. Msg.Message a => CmdArgs
    { _message  :: a
    , target    :: Nick
    , invokedAs :: String
    }

newtype Cmd m a = Cmd { unCmd :: ReaderT CmdArgs (WriterT [String] m) a }
instance Functor f => Functor (Cmd f) where
    fmap f (Cmd x) = Cmd (fmap f x)
instance Applicative f => Applicative (Cmd f) where
    pure = Cmd . pure
    Cmd f <*> Cmd x = Cmd (f <*> x)
instance Monad m => Monad (Cmd m) where
    return = Cmd . return
    Cmd x >>= f = Cmd (x >>= (unCmd . f))
instance MonadFail m => MonadFail (Cmd m) where
    fail = lift . fail
instance MonadIO m => MonadIO (Cmd m) where
    liftIO = lift . liftIO
instance MonadBase b m => MonadBase b (Cmd m) where
    liftBase = lift . liftBase
instance MonadTrans Cmd where
    lift = Cmd . lift . lift
instance MonadTransControl Cmd where
    type StT Cmd a = (a, [String])
    liftWith f = do
        r <- Cmd ask
        lift $ f $ \t -> runWriterT (runReaderT (unCmd t) r)
    restoreT = Cmd . lift . WriterT
    {-# INLINE liftWith #-}
    {-# INLINE restoreT #-}
instance MonadBaseControl b m => MonadBaseControl b (Cmd m) where
    type StM (Cmd m) a = ComposeSt Cmd m a
    liftBaseWith = defaultLiftBaseWith
    restoreM     = defaultRestoreM
    {-# INLINE liftBaseWith #-}
    {-# INLINE restoreM #-}
instance MonadConfig m => MonadConfig (Cmd m) where
    getConfig = lift . getConfig
instance MonadLogging m => MonadLogging (Cmd m) where
    getCurrentLogger = do
        parent <- lift getCurrentLogger
        self   <- getCmdName
        return (parent ++ ["Command", self])
    logM a b c = lift (logM a b c)

data Command m = Command
    { cmdName       :: String
    , aliases       :: [String]
    , privileged    :: Bool
    , help          :: Cmd m ()
    , process       :: String -> Cmd m ()
    }

cmdNames :: Command m -> [String]
cmdNames c = cmdName c : aliases c

command :: String -> Command Identity
command name = Command
    { cmdName       = name
    , aliases       = []
    , privileged    = False
    , help          = bug "they haven't created any help text!"
    , process       = const (bug "they haven't implemented this command!")
    } where
        bug reason = say $ unwords [ "You should bug the author of the", show name, "command, because", reason]

runCommand :: (Monad m, Msg.Message a) => Command m -> a -> Nick -> String -> String -> m [String]
runCommand cmd msg tgt arg0 args = execCmd (process cmd args) msg tgt arg0

execCmd ::  (Monad m, Msg.Message a) => Cmd m t -> a -> Nick -> String -> m [String]
execCmd cmd msg tgt arg0 = execWriterT (runReaderT (unCmd cmd) (CmdArgs msg tgt arg0))

getTarget :: Monad m => Cmd m Nick
getTarget = Cmd (asks target)

getCmdName :: Monad m => Cmd m String
getCmdName = Cmd (asks invokedAs)

say :: Monad m => String -> Cmd m ()
say [] = return ()
say it = Cmd (tell [it])

withMsg :: Monad m => (forall a. Msg.Message a => a -> Cmd m t) -> Cmd m t
withMsg f = Cmd ask >>= f'
    where f' (CmdArgs msg _ _) = f msg

readNick :: Monad m => String -> Cmd m Nick
readNick nick = withMsg (\msg -> return (parseNick (Msg.server msg) nick))

showNick :: Monad m => Nick -> Cmd m String
showNick nick = withMsg (\msg -> return (fmtNick (Msg.server msg) nick))

getServer :: Monad m => Cmd m String
getServer = withMsg (return . Msg.server)

getSender :: Monad m => Cmd m Nick
getSender = withMsg (return . Msg.nick)

getLambdabotName :: Monad m => Cmd m Nick
getLambdabotName = withMsg (return . Msg.lambdabotName)