    {-# 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 = Module ()
    forall st. Module st
    newModule
        { moduleCmds = return
            [ (command "@")
                { aliases = ["?"]
                , help = do
                    c <- getCmdName
                    let cc = String
    cString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    c
                    mapM_ say
                        [ cc++" [args]."
                        , cc++" executes plugin invocations in its arguments, parentheses can be used."
                        , " The commands are right associative."
                        , " For example:    "++cc++" "++c++"pl "++c++"undo code"
                        , " is the same as: "++cc++" ("++c++"pl ("++c++"undo code))"
                        ]
                , process = evalBracket
                }
            , (command ".")
                { aliases = ["compose"]
                , help = mapM_ say
                    [ ". <cmd1> <cmd2> [args]."
                    , ". [or compose] is the composition of two plugins"
                    , " The following semantics are used: . f g xs == g xs >>= f"
                    ]
                , process = \String
    args -> case String -> String -> [String]
    forall a. Eq a => [a] -> [a] -> [[a]]
    splitOn String
    " " String
    args of
                    (String
    f:String
    g:[String]
    xs) -> do
                        f' <- String -> Cmd Compose (String -> LB [String])
    lookupP String
    f
                        g' <- lookupP g
                        lb (compose f' g' (concat $ intersperse " " xs)) >>= mapM_ say
                    [String]
    _ -> String -> Cmd Compose ()
    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 LB [String] -> ([String] -> LB [String]) -> LB [String]
    forall a b. LB a -> (a -> LB b) -> LB b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= String -> LB [String]
    f (String -> LB [String])
    -> ([String] -> String) -> [String] -> LB [String]
    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 a. Message a => a -> Cmd Compose (String -> LB [String]))
    -> Cmd Compose (String -> LB [String])
    forall (m :: * -> *) t.
    Monad m =>
    (forall a. Message a => a -> Cmd m t) -> Cmd m t
    withMsg ((forall a. Message a => a -> Cmd Compose (String -> LB [String]))
     -> Cmd Compose (String -> LB [String]))
    -> (forall a.
        Message a =>
        a -> Cmd Compose (String -> LB [String]))
    -> Cmd Compose (String -> LB [String])
    forall a b. (a -> b) -> a -> b
    $ \a
    a -> do
        b <- Cmd Compose Nick
    forall (m :: * -> *). Monad m => Cmd m Nick
    getTarget
        lb $ withCommand cmd
            (fail $ "Unknown command: " ++ show cmd)
            (\Command (ModuleT st LB)
    theCmd -> do
                Bool -> ModuleT st LB () -> ModuleT st LB ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Command (ModuleT st LB) -> Bool
    forall (m :: * -> *). Command m -> Bool
    privileged Command (ModuleT st LB)
    theCmd) (ModuleT st LB () -> ModuleT st LB ())
    -> ModuleT st LB () -> ModuleT st LB ()
    forall a b. (a -> b) -> a -> b
    $ String -> ModuleT st LB ()
    forall a. String -> ModuleT st LB a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Privileged commands cannot be composed"
                mTag <- (ModuleInfo st -> ModuleID st) -> ModuleT st LB (ModuleID st)
    forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
    asks ModuleInfo st -> ModuleID st
    forall st. ModuleInfo st -> ModuleID st
    moduleID
                return (inModuleWithID mTag (return []) . runCommand theCmd a b cmd))

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

    -- | More interesting composition/evaluation
    -- @@ @f x y (@g y z)
    evalBracket :: String -> Cmd Compose ()
    evalBracket :: String -> Cmd Compose ()
    evalBracket String
    args = do
        cmdPrefixes <- Config [String] -> Cmd Compose [String]
    forall a. Config a -> Cmd Compose a
    forall (m :: * -> *) a. MonadConfig m => Config a -> m a
    getConfig Config [String]
    commandPrefixes

        let conf = [String]
    cmdPrefixes
        xs <- mapM evalExpr (fst (parseBracket 0 True args conf))
        mapM_ (say . addSpace) (concat' xs)
     where concat' :: [[[a]]] -> [[a]]
    concat' ([[a]
    x]:[[a]
    y]:[[[a]]]
    xs) = [[[a]]] -> [[a]]
    concat' ([[a]
    x[a] -> [a] -> [a]
    forall a. [a] -> [a] -> [a]
    ++[a]
    y][[a]] -> [[[a]]] -> [[[a]]]
    forall a. a -> [a] -> [a]
    :[[[a]]]
    xs)
           concat' [[[a]]]
    xs           = [[[a]]] -> [[a]]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[[a]]]
    xs

           addSpace :: String -> String
           addSpace :: String -> String
    addSpace (Char
    ' ':String
    xs) = Char
    ' 'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String
    xs
           addSpace String
    xs       = Char
    ' 'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String
    xs

    evalExpr :: Expr -> Cmd Compose [String]
    evalExpr :: Expr -> Cmd Compose [String]
    evalExpr (Arg String
    s) = [String] -> Cmd Compose [String]
    forall a. a -> Cmd Compose a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [String
    s]
    evalExpr (Cmd String
    c [Expr]
    args) = do
         args' <- (Expr -> Cmd Compose [String]) -> [Expr] -> Cmd Compose [[String]]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM Expr -> Cmd Compose [String]
    evalExpr [Expr]
    args
         let arg = [String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $ [[String]] -> [String]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([[String]] -> [String]) -> [[String]] -> [String]
    forall a b. (a -> b) -> a -> b
    $ ([String] -> [String]) -> [[String]] -> [[String]]
    forall a b. (a -> b) -> [a] -> [b]
    map (String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    intersperse String
    " ") [[String]]
    args'
         cmd <- lookupP c
         lift (lift (cmd arg))

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

    data Expr = Cmd String [Expr]
              | Arg String
        deriving Int -> Expr -> String -> String
    [Expr] -> String -> String
    Expr -> String
    (Int -> Expr -> String -> String)
    -> (Expr -> String) -> ([Expr] -> String -> String) -> Show Expr
    forall a.
    (Int -> a -> String -> String)
    -> (a -> String) -> ([a] -> String -> String) -> Show a
    $cshowsPrec :: Int -> Expr -> String -> String
    showsPrec :: Int -> Expr -> String -> String
    $cshow :: Expr -> String
    show :: Expr -> String
    $cshowList :: [Expr] -> String -> String
    showList :: [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]
    _       = String -> ([Expr], 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 Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0
                                = ([Expr] -> [Expr]) -> ([Expr], String) -> ([Expr], String)
    forall b c d. (b -> c) -> (b, d) -> (c, d)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (b, d) (c, d)
    first (String -> [Expr] -> [Expr]
    addArg String
    ")") (([Expr], String) -> ([Expr], String))
    -> ([Expr], String) -> ([Expr], String)
    forall a b. (a -> b) -> a -> b
    $ Int -> Bool -> String -> [String] -> ([Expr], String)
    parseBracket (Int
    nInt -> Int -> Int
    forall 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 Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0
                                = ([Expr] -> [Expr]) -> ([Expr], String) -> ([Expr], String)
    forall b c d. (b -> c) -> (b, d) -> (c, d)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (b, d) (c, d)
    first (String -> [Expr] -> [Expr]
    addArg String
    "(") (([Expr], String) -> ([Expr], String))
    -> ([Expr], String) -> ([Expr], String)
    forall a b. (a -> b) -> a -> b
    $ Int -> Bool -> String -> [String] -> ([Expr], String)
    parseBracket (Int
    nInt -> Int -> Int
    forall 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 Char -> String -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` String
    "\"'" Bool -> Bool -> Bool
    && (Bool
    c Bool -> Bool -> Bool
    || Char
    x Char -> Char -> Bool
    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
    xChar -> String -> String
    forall a. a -> [a] -> [a]
    :String
    str) [Expr]
    rest, String
    zs)
    parseBracket Int
    n Bool
    c (Char
    x:String
    xs) [String]
    cfg = ([Expr] -> [Expr]) -> ([Expr], String) -> ([Expr], String)
    forall b c d. (b -> c) -> (b, d) -> (c, d)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (b, d) (c, d)
    first (String -> [Expr] -> [Expr]
    addArg [Char
    x])
                                (([Expr], String) -> ([Expr], String))
    -> ([Expr], String) -> ([Expr], String)
    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 Char -> Char -> Bool
    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]
    argsExpr -> [Expr] -> [Expr]
    forall a. a -> [a] -> [a]
    :[Expr]
    rest, String
    ws)
        where
            (String
    cmd, String
    ys) = (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break (Char -> String -> Bool
    forall a. Eq a => a -> [a] -> Bool
    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 ((Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile (Char -> Char -> Bool
    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]
    restExpr -> [Expr] -> [Expr]
    forall a. a -> [a] -> [a]
    :[], String
    zs)
      where
        (String
    cmd, String
    ys) = (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    break (Char -> String -> Bool
    forall a. Eq a => a -> [a] -> Bool
    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 ((Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile (Char -> Char -> Bool
    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) = (String -> String) -> (String, String) -> (String, String)
    forall b c d. (b -> c) -> (b, d) -> (c, d)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (b, d) (c, d)
    first (\String
    ys -> Char
    '\\'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    xChar -> String -> String
    forall a. a -> [a] -> [a]
    :String
    ys) (Char -> String -> (String, String)
    parseString Char
    delim String
    xs)
    parseString Char
    delim (Char
    x:String
    xs)
      | Char
    delim Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    x                = ([Char
    x],String
    xs)
      | Bool
    otherwise                 = (String -> String) -> (String, String) -> (String, String)
    forall b c d. (b -> c) -> (b, d) -> (c, d)
    forall (a :: * -> * -> *) b c d.
    Arrow a =>
    a b c -> a (b, d) (c, d)
    first (Char
    xChar -> String -> String
    forall 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 = [Maybe String] -> Maybe String
    forall (t :: * -> *) (m :: * -> *) a.
    (Foldable t, MonadPlus m) =>
    t (m a) -> m a
    msum ([Maybe String] -> Maybe String)
    -> ([String] -> [Maybe String]) -> [String] -> Maybe String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> Maybe String) -> [String] -> [Maybe String]
    forall a b. (a -> b) -> [a] -> [b]
    map String -> Maybe String
    dropPrefix
     where dropPrefix :: String -> Maybe String
    dropPrefix String
    p
              | String
    p String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf` String
    xs = String -> Maybe String
    forall a. a -> Maybe a
    Just (String -> Maybe String) -> String -> Maybe String
    forall a b. (a -> b) -> a -> b
    $ Int -> String -> String
    forall a. Int -> [a] -> [a]
    drop (String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    p) String
    xs
              | Bool
    otherwise         = Maybe String
    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
    sString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    a)Expr -> [Expr] -> [Expr]
    forall a. a -> [a] -> [a]
    :[Expr]
    es
    addArg String
    s [Expr]
    es         = String -> Expr
    Arg String
    s     Expr -> [Expr] -> [Expr]
    forall a. a -> [a] -> [a]
    :[Expr]
    es