    {- | A module to output the instances of a typeclass.
         Some sample input\/output:

    > lambdabot> @instances Monad
    > [], ArrowMonad a, WriterT w m, Writer w, ReaderT r m, Reader r,
    > StateT s m, State s, RWST r w s m, RWS r w s, ErrorT e m, Either e,
    > ContT r m, Cont r, Maybe, ST s, IO
    >
    > lambdabot> @instances Show
    > Float, Double, Integer, ST s a, [a], (a, b, c, d), (a, b, c), (a, b),
    > (), Ordering, Maybe a, Int, Either a b, Char, Bool
    >
    > lambdabot> @instances-importing Text.Html Data.Tree Show
    > Float, Double, Tree a, HtmlTable, HtmlAttr, Html, HotLink, Integer,
    > ST s a, [a], (a, b, c, d), (a, b, c), (a, b), (), Ordering, Maybe a,
    > Int
    -}

    module Lambdabot.Plugin.Haskell.Instances (instancesPlugin) where

    import Text.ParserCombinators.Parsec

    import Lambdabot.Config.Haskell
    import Lambdabot.Plugin
    import Lambdabot.Util
    import Lambdabot.Plugin.Haskell.Eval (findL_hs)

    import Control.Applicative ((*>))
    import Control.Monad
    import Data.Char
    import Data.List
    import Data.List.Split
    import Data.Maybe
    import System.FilePath
    import System.Process
    import Text.Regex.TDFA

    type Instance   = String
    type ClassName  = String
    type ModuleName = String

    instancesPlugin :: Module ()
    instancesPlugin :: Module ()
    instancesPlugin = Module ()
    forall st. Module st
    newModule
        { moduleCmds = return
            [ (command "instances")
                { help = say "instances <typeclass>. Fetch the instances of a typeclass."
                , process = fetchInstances >=> say
                }
            , (command "instances-importing")
                { help = say $
                    "instances-importing [<module> [<module> [<module...]]] <typeclass>. " ++
                    "Fetch the instances of a typeclass, importing specified modules first."
                , process = fetchInstancesImporting >=> say
                }
            ]
        }

    -- | Nice little combinator used to throw away error messages from an Either
    --   and just keep a Maybe indicating the success of the computation.
    eitherToMaybe :: Either a b -> Maybe b
    eitherToMaybe :: forall a b. Either a b -> Maybe b
    eitherToMaybe = (a -> Maybe b) -> (b -> Maybe b) -> Either a b -> Maybe b
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either (Maybe b -> a -> Maybe b
    forall a b. a -> b -> a
    const Maybe b
    forall a. Maybe a
    Nothing) b -> Maybe b
    forall a. a -> Maybe a
    Just

    -- * Parsing
    --

    -- | Parse an instance declaration. Sample inputs:
    --
    -- > instance Monad []
    -- > instance (Monoid w) => Monad (Writer w)
    -- > instance (State s)
    --
    instanceP :: ClassName -> CharParser st Instance
    instanceP :: forall st. String -> CharParser st String
    instanceP String
    cls
        =  String -> ParsecT String st Identity String
    forall s (m :: * -> *) u.
    Stream s m Char =>
    String -> ParsecT s u m String
    string String
    "instance " ParsecT String st Identity String
    -> ParsecT String st Identity String
    -> ParsecT String st Identity String
    forall a b.
    ParsecT String st Identity a
    -> ParsecT String st Identity b -> ParsecT String st Identity b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> (ParsecT String st Identity String
    -> ParsecT String st Identity String
    forall tok st a. GenParser tok st a -> GenParser tok st a
    try ParsecT String st Identity String
    forall {u}. ParsecT String u Identity String
    constrained ParsecT String st Identity String
    -> ParsecT String st Identity String
    -> ParsecT String st Identity String
    forall s u (m :: * -> *) a.
    ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
    <|> ParsecT String st Identity String
    forall {u}. ParsecT String u Identity String
    unconstrained) ParsecT String st Identity String
    -> ParsecT String st Identity () -> ParsecT String st Identity ()
    forall a b.
    ParsecT String st Identity a
    -> ParsecT String st Identity b -> ParsecT String st Identity b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> ParsecT String st Identity Char -> ParsecT String st Identity ()
    forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
    skipMany ParsecT String st Identity Char
    forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
    space
        ParsecT String st Identity ()
    -> ParsecT String st Identity String
    -> ParsecT String st Identity String
    forall a b.
    ParsecT String st Identity a
    -> ParsecT String st Identity b -> ParsecT String st Identity b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> ParsecT String st Identity Char
    forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
    anyChar ParsecT String st Identity Char
    -> ParsecT String st Identity ()
    -> ParsecT String st Identity String
    forall s (m :: * -> *) t u a end.
    Stream s m t =>
    ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
    `manyTill` ParsecT String st Identity ()
    forall {u}. ParsecT String u Identity ()
    end
        where constrained :: ParsecT String u Identity String
    constrained   = String -> ParsecT String u Identity Char
    forall s (m :: * -> *) u.
    Stream s m Char =>
    String -> ParsecT s u m Char
    noneOf String
    "=" ParsecT String u Identity Char
    -> ParsecT String u Identity String
    -> ParsecT String u Identity String
    forall s (m :: * -> *) t u a end.
    Stream s m t =>
    ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
    `manyTill` String -> ParsecT String u Identity String
    forall s (m :: * -> *) u.
    Stream s m Char =>
    String -> ParsecT s u m String
    string (String
    "=> " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    cls)
              unconstrained :: ParsecT String u Identity String
    unconstrained = String -> ParsecT String u Identity String
    forall s (m :: * -> *) u.
    Stream s m Char =>
    String -> ParsecT s u m String
    string String
    cls

              -- break on the "imported from" comment or a newline.
              end :: ParsecT String u Identity ()
    end           = ParsecT String u Identity String -> ParsecT String u Identity ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (ParsecT String u Identity String
    -> ParsecT String u Identity String
    forall tok st a. GenParser tok st a -> GenParser tok st a
    try (String -> ParsecT String u Identity String
    forall s (m :: * -> *) u.
    Stream s m Char =>
    String -> ParsecT s u m String
    string String
    "--")) ParsecT String u Identity ()
    -> ParsecT String u Identity () -> ParsecT String u Identity ()
    forall s u (m :: * -> *) a.
    ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
    <|> ParsecT String u Identity ()
    forall s (m :: * -> *) t u.
    (Stream s m t, Show t) =>
    ParsecT s u m ()
    eof

    -- | Wrapper for the instance parser.
    parseInstance :: ClassName -> String -> Maybe Instance
    parseInstance :: String -> String -> Maybe String
    parseInstance String
    cls = (String -> String) -> Maybe String -> Maybe String
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((Char -> Bool) -> String -> String
    forall a. (a -> Bool) -> [a] -> [a]
    strip Char -> Bool
    isSpace) (Maybe String -> Maybe String)
    -> (String -> Maybe String) -> String -> Maybe String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Either ParseError String -> Maybe String
    forall a b. Either a b -> Maybe b
    eitherToMaybe
                        (Either ParseError String -> Maybe String)
    -> (String -> Either ParseError String) -> String -> Maybe String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Parsec String () String
    -> String -> String -> Either ParseError String
    forall s t a.
    Stream s Identity t =>
    Parsec s () a -> String -> s -> Either ParseError a
    parse (String -> Parsec String () String
    forall st. String -> CharParser st String
    instanceP String
    cls) String
    "GHCi output"

    -- | Split the input into a list of the instances, then run each instance
    --   through the parser. Collect successes.
    getInstances :: String -> ClassName -> [Instance]
    getInstances :: String -> String -> [String]
    getInstances String
    s String
    cls
        | Bool -> Bool
    not Bool
    classFound -- can't trust those dodgy folk in #haskell
        = [String
    "Couldn't find class `"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    clsString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    "'. Try @instances-importing"]

       | Bool
    otherwise = [String] -> [String]
    forall a. Ord a => [a] -> [a]
    sort ([String] -> [String]) -> [String] -> [String]
    forall a b. (a -> b) -> a -> b
    $ (String -> Maybe String) -> [String] -> [String]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe String -> Maybe String
    doParse ([String] -> [String]
    forall a. HasCallStack => [a] -> [a]
    tail [String]
    splut)

        where classFound :: Bool
    classFound   = String
    s String -> String -> Bool
    forall source source1 target.
    (RegexMaker Regex CompOption ExecOption source,
     RegexContext Regex source1 target) =>
    source1 -> source -> target
    =~ (String
    "class.*" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    cls String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ".*where")
              splut :: [String]
    splut        = String -> String -> [String]
    forall a. Eq a => [a] -> [a] -> [[a]]
    splitOn String
    "instance" String
    s -- splut being the past participle
                                                -- of 'to split', obviously. :)
              notOperator :: String -> Bool
    notOperator  = (Char -> Bool) -> String -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (\Char
    c -> [Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    or
                                   [ Char -> Bool
    isAlpha Char
    c,
                                     Char -> Bool
    isSpace Char
    c,
                                     Char
    c Char -> String -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` String
    "()" ])
              unbracket :: String -> String
    unbracket String
    str | String -> Char
    forall a. HasCallStack => [a] -> a
    head String
    str Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '(' Bool -> Bool -> Bool
    && String -> Char
    forall a. HasCallStack => [a] -> a
    last String
    str Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    ')' Bool -> Bool -> Bool
    &&
                              (Char -> Bool) -> String -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /=Char
    ',') String
    str Bool -> Bool -> Bool
    && String -> Bool
    notOperator String
    str Bool -> Bool -> Bool
    && String
    str String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    /= String
    "()" =
                              String -> String
    forall a. HasCallStack => [a] -> [a]
    init (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ String -> String
    forall a. HasCallStack => [a] -> [a]
    tail String
    str
                            | Bool
    otherwise = String
    str
              doParse :: String -> Maybe String
    doParse = (String -> String) -> Maybe String -> Maybe String
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap String -> String
    unbracket (Maybe String -> Maybe String)
    -> (String -> Maybe String) -> String -> Maybe String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> Maybe String
    parseInstance String
    cls (String -> Maybe String)
    -> (String -> String) -> String -> Maybe String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String
    "instance"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++)

    -- * Delegation; interface with GHCi
    --

    -- | The standard modules we ask GHCi to load.
    stdMdls :: [ModuleName]
    stdMdls :: [String]
    stdMdls = [String]
    controls
        where monads :: [String]
    monads   = (String -> String) -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (String
    "Monad."String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++)
                           [ String
    "Cont", String
    "Error", String
    "Fix", String
    "Reader", String
    "RWS", String
    "ST",
                             String
    "State", String
    "Trans", String
    "Writer" ]
              controls :: [String]
    controls = (String -> String) -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (String
    "Control." String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++) ([String] -> [String]) -> [String] -> [String]
    forall a b. (a -> b) -> a -> b
    $ [String]
    monads [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ [String
    "Arrow"]

    -- | Main processing function for \@instances. Takes a class name and
    --   return a list of lines to output (which will actually only be one).
    fetchInstances :: MonadLB m => ClassName -> m String
    fetchInstances :: forall (m :: * -> *). MonadLB m => String -> m String
    fetchInstances String
    cls = String -> [String] -> m String
    forall (m :: * -> *). MonadLB m => String -> [String] -> m String
    fetchInstances' String
    cls [String]
    stdMdls

    -- | Main processing function for \@instances-importing. Takes the args, which
    --   are words'd. The all but the last argument are taken to be the modules to
    --   import, and the last is the typeclass whose instances we want to print.
    fetchInstancesImporting :: MonadLB m => String -> m String
    fetchInstancesImporting :: forall (m :: * -> *). MonadLB m => String -> m String
    fetchInstancesImporting String
    args = String -> [String] -> m String
    forall (m :: * -> *). MonadLB m => String -> [String] -> m String
    fetchInstances' String
    cls [String]
    mdls
        where args' :: [String]
    args' = String -> [String]
    words String
    args
              cls :: String
    cls   = [String] -> String
    forall a. HasCallStack => [a] -> a
    last [String]
    args'
              mdls :: [String]
    mdls  = [String] -> [String]
    forall a. Eq a => [a] -> [a]
    nub ([String] -> [String]) -> [String] -> [String]
    forall a b. (a -> b) -> a -> b
    $ [String] -> [String]
    forall a. HasCallStack => [a] -> [a]
    init [String]
    args' [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ [String]
    stdMdls

    -- | Interface with GHCi to get the input for the parser, then send it through
    --   the parser.
    fetchInstances' :: MonadLB m => String -> [ModuleName] -> m String
    fetchInstances' :: forall (m :: * -> *). MonadLB m => String -> [String] -> m String
    fetchInstances' String
    cls [String]
    mdls = do
        load <- m String
    forall (m :: * -> *). MonadLB m => m String
    findL_hs
        let s = [String] -> String
    unlines ([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
    unwords
                [ [String
    ":l", String
    load]
                ,  String
    ":m" String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : String
    "+" String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : [String]
    mdls
                , [String
    ":i", String
    cls]
                ]

        ghci <- getConfig ghciBinary
        (_, out, err) <- io $ readProcessWithExitCode ghci ["-ignore-dot-ghci","-fglasgow-exts"] s
        let is = String -> String -> [String]
    getInstances String
    out String
    cls
        return $ if null is
                   then err
                   else intercalate ", " is