{-# 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
    , CmdArgs -> Nick
target    :: Nick
    , CmdArgs -> String
invokedAs :: String
    }

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

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

cmdNames :: Command m -> [String]
cmdNames :: Command m -> [String]
cmdNames Command m
c = Command m -> String
forall (m :: * -> *). Command m -> String
cmdName Command m
c String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Command m -> [String]
forall (m :: * -> *). Command m -> [String]
aliases Command m
c

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

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

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

getTarget :: Monad m => Cmd m Nick
getTarget :: Cmd m Nick
getTarget = ReaderT CmdArgs (WriterT [String] m) Nick -> Cmd m Nick
forall (m :: * -> *) a.
ReaderT CmdArgs (WriterT [String] m) a -> Cmd m a
Cmd ((CmdArgs -> Nick) -> ReaderT CmdArgs (WriterT [String] m) Nick
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CmdArgs -> Nick
target)

getCmdName :: Monad m => Cmd m String
getCmdName :: Cmd m String
getCmdName = ReaderT CmdArgs (WriterT [String] m) String -> Cmd m String
forall (m :: * -> *) a.
ReaderT CmdArgs (WriterT [String] m) a -> Cmd m a
Cmd ((CmdArgs -> String) -> ReaderT CmdArgs (WriterT [String] m) String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks CmdArgs -> String
invokedAs)

say :: Monad m => String -> Cmd m ()
say :: String -> Cmd m ()
say [] = () -> Cmd m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
say String
it = ReaderT CmdArgs (WriterT [String] m) () -> Cmd m ()
forall (m :: * -> *) a.
ReaderT CmdArgs (WriterT [String] m) a -> Cmd m a
Cmd ([String] -> ReaderT CmdArgs (WriterT [String] m) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
it])

withMsg :: Monad m => (forall a. Msg.Message a => a -> Cmd m t) -> Cmd m t
withMsg :: (forall a. Message a => a -> Cmd m t) -> Cmd m t
withMsg forall a. Message a => a -> Cmd m t
f = ReaderT CmdArgs (WriterT [String] m) CmdArgs -> Cmd m CmdArgs
forall (m :: * -> *) a.
ReaderT CmdArgs (WriterT [String] m) a -> Cmd m a
Cmd ReaderT CmdArgs (WriterT [String] m) CmdArgs
forall r (m :: * -> *). MonadReader r m => m r
ask Cmd m CmdArgs -> (CmdArgs -> Cmd m t) -> Cmd m t
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CmdArgs -> Cmd m t
f'
    where f' :: CmdArgs -> Cmd m t
f' (CmdArgs a
msg Nick
_ String
_) = a -> Cmd m t
forall a. Message a => a -> Cmd m t
f a
msg

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

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

getServer :: Monad m => Cmd m String
getServer :: Cmd m String
getServer = (forall a. Message a => a -> Cmd m String) -> Cmd m String
forall (m :: * -> *) t.
Monad m =>
(forall a. Message a => a -> Cmd m t) -> Cmd m t
withMsg (String -> Cmd m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Cmd m String) -> (a -> String) -> a -> Cmd m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Message a => a -> String
Msg.server)

getSender :: Monad m => Cmd m Nick
getSender :: Cmd m Nick
getSender = (forall a. Message a => a -> Cmd m Nick) -> Cmd m Nick
forall (m :: * -> *) t.
Monad m =>
(forall a. Message a => a -> Cmd m t) -> Cmd m t
withMsg (Nick -> Cmd m Nick
forall (m :: * -> *) a. Monad m => a -> m a
return (Nick -> Cmd m Nick) -> (a -> Nick) -> a -> Cmd m Nick
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Nick
forall a. Message a => a -> Nick
Msg.nick)

getLambdabotName :: Monad m => Cmd m Nick
getLambdabotName :: Cmd m Nick
getLambdabotName = (forall a. Message a => a -> Cmd m Nick) -> Cmd m Nick
forall (m :: * -> *) t.
Monad m =>
(forall a. Message a => a -> Cmd m t) -> Cmd m t
withMsg (Nick -> Cmd m Nick
forall (m :: * -> *) a. Monad m => a -> m a
return (Nick -> Cmd m Nick) -> (a -> Nick) -> a -> Cmd m Nick
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Nick
forall a. Message a => a -> Nick
Msg.lambdabotName)