{-# LANGUAGE PatternGuards #-}
-- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons
-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)

-- Another progressive plugin. Compose two (for now) plugins transparently
-- A sort of mini interpreter. Could do with some more thinking.
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 two plugin functions
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

------------------------------------------------------------------------
-- | Lookup the `process' method we're after, and apply it to the dummy args
--
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))

------------------------------------------------------------------------

-- | More interesting composition/evaluation
-- @@ @f x y (@g y z)
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

-- TODO: rewrite this using parsec or something
-- | Parse a command invocation that can contain parentheses
--   The Int indicates how many brackets must be closed to end the current argument, or 0
--   The Bool indicates if this is a valid location for a character constant
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     -- (@cmd arg arg)
                            = 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 -- @(cmd arg arg)
                            = 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       -- @cmd arg arg
                            = 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)


-- | Does xs start with a command prefix?
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