{-# LANGUAGE PatternGuards #-}
module Lambdabot.Plugin.Core.Compose (composePlugin) where
import Lambdabot.Command
import Lambdabot.Module
import Lambdabot.Monad
import Lambdabot.Plugin
import Control.Arrow (first)
import Control.Monad
import Control.Monad.Reader
import Data.Char
import Data.List
import Data.List.Split
type Compose = ModuleT () LB
composePlugin :: Module ()
composePlugin :: Module ()
composePlugin = forall st. Module st
newModule
{ moduleCmds :: ModuleT () LB [Command Compose]
moduleCmds = forall (m :: * -> *) a. Monad m => a -> m a
return
[ (String -> Command Identity
command String
"@")
{ aliases :: [String]
aliases = [String
"?"]
, help :: Cmd Compose ()
help = do
String
c <- forall (m :: * -> *). Monad m => Cmd m String
getCmdName
let cc :: String
cc = String
cforall a. [a] -> [a] -> [a]
++String
c
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). Monad m => String -> Cmd m ()
say
[ String
ccforall a. [a] -> [a] -> [a]
++String
" [args]."
, String
ccforall a. [a] -> [a] -> [a]
++String
" executes plugin invocations in its arguments, parentheses can be used."
, String
" The commands are right associative."
, String
" For example: "forall a. [a] -> [a] -> [a]
++String
ccforall a. [a] -> [a] -> [a]
++String
" "forall a. [a] -> [a] -> [a]
++String
cforall a. [a] -> [a] -> [a]
++String
"pl "forall a. [a] -> [a] -> [a]
++String
cforall a. [a] -> [a] -> [a]
++String
"undo code"
, String
" is the same as: "forall a. [a] -> [a] -> [a]
++String
ccforall a. [a] -> [a] -> [a]
++String
" ("forall a. [a] -> [a] -> [a]
++String
cforall a. [a] -> [a] -> [a]
++String
"pl ("forall a. [a] -> [a] -> [a]
++String
cforall a. [a] -> [a] -> [a]
++String
"undo code))"
]
, process :: String -> Cmd Compose ()
process = String -> Cmd Compose ()
evalBracket
}
, (String -> Command Identity
command String
".")
{ aliases :: [String]
aliases = [String
"compose"]
, help :: Cmd Compose ()
help = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). Monad m => String -> Cmd m ()
say
[ String
". <cmd1> <cmd2> [args]."
, String
". [or compose] is the composition of two plugins"
, String
" The following semantics are used: . f g xs == g xs >>= f"
]
, process :: String -> Cmd Compose ()
process = \String
args -> case forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
" " String
args of
(String
f:String
g:[String]
xs) -> do
String -> LB [String]
f' <- String -> Cmd Compose (String -> LB [String])
lookupP String
f
String -> LB [String]
g' <- String -> Cmd Compose (String -> LB [String])
lookupP String
g
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb ((String -> LB [String])
-> (String -> LB [String]) -> String -> LB [String]
compose String -> LB [String]
f' String -> LB [String]
g' (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse String
" " [String]
xs)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). Monad m => String -> Cmd m ()
say
[String]
_ -> forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Not enough arguments to @."
}
]
}
compose :: (String -> LB [String]) -> (String -> LB [String]) -> (String -> LB [String])
compose :: (String -> LB [String])
-> (String -> LB [String]) -> String -> LB [String]
compose String -> LB [String]
f String -> LB [String]
g String
xs = String -> LB [String]
g String
xs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> LB [String]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines
lookupP :: String -> Cmd Compose (String -> LB [String])
lookupP :: String -> Cmd Compose (String -> LB [String])
lookupP String
cmd = forall (m :: * -> *) t.
Monad m =>
(forall a. Message a => a -> Cmd m t) -> Cmd m t
withMsg forall a b. (a -> b) -> a -> b
$ \a
a -> do
Nick
b <- forall (m :: * -> *). Monad m => Cmd m Nick
getTarget
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb forall a b. (a -> b) -> a -> b
$ forall a.
String
-> LB a
-> (forall st. Command (ModuleT st LB) -> ModuleT st LB a)
-> LB a
withCommand String
cmd
(forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unknown command: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
cmd)
(\Command (ModuleT st LB)
theCmd -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (m :: * -> *). Command m -> Bool
privileged Command (ModuleT st LB)
theCmd) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Privileged commands cannot be composed"
ModuleID st
mTag <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall st. ModuleInfo st -> ModuleID st
moduleID
forall (m :: * -> *) a. Monad m => a -> m a
return (forall st a. ModuleID st -> LB a -> ModuleT st LB a -> LB a
inModuleWithID ModuleID st
mTag (forall (m :: * -> *) a. Monad m => a -> m a
return []) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(Monad m, Message a) =>
Command m -> a -> Nick -> String -> String -> m [String]
runCommand Command (ModuleT st LB)
theCmd a
a Nick
b String
cmd))
evalBracket :: String -> Cmd Compose ()
evalBracket :: String -> Cmd Compose ()
evalBracket String
args = do
[String]
cmdPrefixes <- forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
commandPrefixes
let conf :: [String]
conf = [String]
cmdPrefixes
[[String]]
xs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr -> Cmd Compose [String]
evalExpr (forall a b. (a, b) -> a
fst (Int -> Bool -> String -> [String] -> ([Expr], String)
parseBracket Int
0 Bool
True String
args [String]
conf))
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). Monad m => String -> Cmd m ()
say forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
addSpace) (forall {a}. [[[a]]] -> [[a]]
concat' [[String]]
xs)
where concat' :: [[[a]]] -> [[a]]
concat' ([[a]
x]:[[a]
y]:[[[a]]]
xs) = [[[a]]] -> [[a]]
concat' ([[a]
xforall a. [a] -> [a] -> [a]
++[a]
y]forall a. a -> [a] -> [a]
:[[[a]]]
xs)
concat' [[[a]]]
xs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[[a]]]
xs
addSpace :: String -> String
addSpace :: String -> String
addSpace (Char
' ':String
xs) = Char
' 'forall a. a -> [a] -> [a]
:String
xs
addSpace String
xs = Char
' 'forall a. a -> [a] -> [a]
:String
xs
evalExpr :: Expr -> Cmd Compose [String]
evalExpr :: Expr -> Cmd Compose [String]
evalExpr (Arg String
s) = forall (m :: * -> *) a. Monad m => a -> m a
return [String
s]
evalExpr (Cmd String
c [Expr]
args) = do
[[String]]
args' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr -> Cmd Compose [String]
evalExpr [Expr]
args
let arg :: String
arg = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> [a] -> [a]
intersperse String
" ") [[String]]
args'
String -> LB [String]
cmd <- String -> Cmd Compose (String -> LB [String])
lookupP String
c
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> LB [String]
cmd String
arg))
data Expr = Cmd String [Expr]
| Arg String
deriving Int -> Expr -> String -> String
[Expr] -> String -> String
Expr -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Expr] -> String -> String
$cshowList :: [Expr] -> String -> String
show :: Expr -> String
$cshow :: Expr -> String
showsPrec :: Int -> Expr -> String -> String
$cshowsPrec :: Int -> Expr -> String -> String
Show
parseBracket :: Int -> Bool -> String -> [String] -> ([Expr],String)
parseBracket :: Int -> Bool -> String -> [String] -> ([Expr], String)
parseBracket Int
0 Bool
_ [] [String]
_ = ([],[])
parseBracket Int
_ Bool
_ [] [String]
_ = forall a. HasCallStack => String -> a
error String
"Missing ')' in nested command"
parseBracket Int
1 Bool
_ (Char
')':String
xs) [String]
_ = ([],String
xs)
parseBracket Int
n Bool
_ (Char
')':String
xs) [String]
c | Int
n forall a. Ord a => a -> a -> Bool
> Int
0
= forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (String -> [Expr] -> [Expr]
addArg String
")") forall a b. (a -> b) -> a -> b
$ Int -> Bool -> String -> [String] -> ([Expr], String)
parseBracket (Int
nforall a. Num a => a -> a -> a
-Int
1) Bool
True String
xs [String]
c
parseBracket Int
n Bool
_ (Char
'(':String
xs) [String]
c | Just String
ys <- String -> [String] -> Maybe String
isCommand String
xs [String]
c
= Int -> String -> [String] -> ([Expr], String)
parseCommand Int
n String
ys [String]
c
parseBracket Int
n Bool
_ (Char
'(':String
xs) [String]
c | Int
n forall a. Ord a => a -> a -> Bool
> Int
0
= forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (String -> [Expr] -> [Expr]
addArg String
"(") forall a b. (a -> b) -> a -> b
$ Int -> Bool -> String -> [String] -> ([Expr], String)
parseBracket (Int
nforall a. Num a => a -> a -> a
+Int
1) Bool
True String
xs [String]
c
parseBracket Int
n Bool
_ String
xs [String]
c | Just (Char
'(':String
ys) <- String -> [String] -> Maybe String
isCommand String
xs [String]
c
= Int -> String -> [String] -> ([Expr], String)
parseCommand Int
n String
ys [String]
c
parseBracket Int
n Bool
_ String
xs [String]
c | Just String
ys <- String -> [String] -> Maybe String
isCommand String
xs [String]
c
= Int -> String -> [String] -> ([Expr], String)
parseInlineCommand Int
n String
ys [String]
c
parseBracket Int
n Bool
c (Char
x:String
xs) [String]
cfg | Char
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"\"'" Bool -> Bool -> Bool
&& (Bool
c Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
/= Char
'\'')
= let (String
str, String
ys) = Char -> String -> (String, String)
parseString Char
x String
xs
([Expr]
rest,String
zs) = Int -> Bool -> String -> [String] -> ([Expr], String)
parseBracket Int
n Bool
True String
ys [String]
cfg
in (String -> [Expr] -> [Expr]
addArg (Char
xforall a. a -> [a] -> [a]
:String
str) [Expr]
rest, String
zs)
parseBracket Int
n Bool
c (Char
x:String
xs) [String]
cfg = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (String -> [Expr] -> [Expr]
addArg [Char
x])
forall a b. (a -> b) -> a -> b
$ Int -> Bool -> String -> [String] -> ([Expr], String)
parseBracket Int
n (Bool -> Bool
not (Char -> Bool
isAlphaNum Char
x) Bool -> Bool -> Bool
&& (Bool
c Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
/= Char
'\'')) String
xs [String]
cfg
parseCommand, parseInlineCommand :: Int -> String -> [String] -> ([Expr],String)
parseCommand :: Int -> String -> [String] -> ([Expr], String)
parseCommand Int
n String
xs [String]
conf = (String -> [Expr] -> Expr
Cmd String
cmd [Expr]
argsforall a. a -> [a] -> [a]
:[Expr]
rest, String
ws)
where
(String
cmd, String
ys) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
" )") String
xs
([Expr]
args,String
zs) = Int -> Bool -> String -> [String] -> ([Expr], String)
parseBracket Int
1 Bool
True (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
==Char
' ') String
ys) [String]
conf
([Expr]
rest,String
ws) = Int -> Bool -> String -> [String] -> ([Expr], String)
parseBracket Int
n Bool
True String
zs [String]
conf
parseInlineCommand :: Int -> String -> [String] -> ([Expr], String)
parseInlineCommand Int
n String
xs [String]
conf = (String -> [Expr] -> Expr
Cmd String
cmd [Expr]
restforall a. a -> [a] -> [a]
:[], String
zs)
where
(String
cmd, String
ys) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
" )") String
xs
([Expr]
rest,String
zs) = Int -> Bool -> String -> [String] -> ([Expr], String)
parseBracket Int
n Bool
True (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
==Char
' ') String
ys) [String]
conf
parseString :: Char -> String -> (String, String)
parseString :: Char -> String -> (String, String)
parseString Char
_ [] = ([],[])
parseString Char
delim (Char
'\\':Char
x:String
xs) = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (\String
ys -> Char
'\\'forall a. a -> [a] -> [a]
:Char
xforall a. a -> [a] -> [a]
:String
ys) (Char -> String -> (String, String)
parseString Char
delim String
xs)
parseString Char
delim (Char
x:String
xs)
| Char
delim forall a. Eq a => a -> a -> Bool
== Char
x = ([Char
x],String
xs)
| Bool
otherwise = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Char
xforall a. a -> [a] -> [a]
:) (Char -> String -> (String, String)
parseString Char
delim String
xs)
isCommand :: String -> [String] -> Maybe String
isCommand :: String -> [String] -> Maybe String
isCommand String
xs = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe String
dropPrefix
where dropPrefix :: String -> Maybe String
dropPrefix String
p
| String
p forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
xs = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
p) String
xs
| Bool
otherwise = forall a. Maybe a
Nothing
addArg :: String -> [Expr] -> [Expr]
addArg :: String -> [Expr] -> [Expr]
addArg String
s (Arg String
a:[Expr]
es) = String -> Expr
Arg (String
sforall a. [a] -> [a] -> [a]
++String
a)forall a. a -> [a] -> [a]
:[Expr]
es
addArg String
s [Expr]
es = String -> Expr
Arg String
s forall a. a -> [a] -> [a]
:[Expr]
es