{- | 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 :: ModuleT () LB [Command (ModuleT () LB)]
moduleCmds = [Command (ModuleT () LB)]
-> ModuleT () LB [Command (ModuleT () LB)]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
"instances")
            { help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"instances <typeclass>. Fetch the instances of a typeclass."
            , process :: String -> Cmd (ModuleT () LB) ()
process = String -> Cmd (ModuleT () LB) String
forall (m :: * -> *). MonadLB m => String -> m String
fetchInstances (String -> Cmd (ModuleT () LB) String)
-> (String -> Cmd (ModuleT () LB) ())
-> String
-> Cmd (ModuleT () LB) ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say
            }
        , (String -> Command Identity
command String
"instances-importing")
            { help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say (String -> Cmd (ModuleT () LB) ())
-> String -> Cmd (ModuleT () LB) ()
forall a b. (a -> b) -> a -> b
$
                String
"instances-importing [<module> [<module> [<module...]]] <typeclass>. " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String
"Fetch the instances of a typeclass, importing specified modules first."
            , process :: String -> Cmd (ModuleT () LB) ()
process = String -> Cmd (ModuleT () LB) String
forall (m :: * -> *). MonadLB m => String -> m String
fetchInstancesImporting (String -> Cmd (ModuleT () LB) String)
-> (String -> Cmd (ModuleT () LB) ())
-> String
-> Cmd (ModuleT () LB) ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
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 :: 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 :: String -> CharParser st String
instanceP String
cls
    =  String -> CharParser st String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"instance " CharParser st String
-> CharParser st String -> CharParser st String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (CharParser st String -> CharParser st String
forall tok st a. GenParser tok st a -> GenParser tok st a
try CharParser st String
forall u. ParsecT String u Identity String
constrained CharParser st String
-> CharParser st String -> CharParser st String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> CharParser st String
forall u. ParsecT String u Identity String
unconstrained) CharParser st String
-> ParsecT String st Identity () -> ParsecT String st Identity ()
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 ()
-> CharParser st String -> CharParser st String
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 () -> CharParser st 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 (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. [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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"()" ])
          unbracket :: String -> String
unbracket String
str | String -> Char
forall a. [a] -> a
head String
str Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
&& String -> Char
forall a. [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. [a] -> [a]
init (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
tail String
str
                        | Bool
otherwise = String
str
          doParse :: String -> Maybe String
doParse = (String -> String) -> Maybe String -> Maybe String
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 :: 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 :: 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. [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. [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' :: String -> [String] -> m String
fetchInstances' String
cls [String]
mdls = do
    String
load <- m String
forall (m :: * -> *). MonadLB m => m String
findL_hs
    let s :: String
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]
            ]

    String
ghci <- Config String -> m String
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
ghciBinary
    (ExitCode
_, String
out, String
err) <- IO (ExitCode, String, String) -> m (ExitCode, String, String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (ExitCode, String, String) -> m (ExitCode, String, String))
-> IO (ExitCode, String, String) -> m (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
ghci [String
"-ignore-dot-ghci",String
"-fglasgow-exts"] String
s
    let is :: [String]
is = String -> String -> [String]
getInstances String
out String
cls
    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
is
               then String
err
               else String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
is