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 "instances")
{ help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say "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 "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
$
"instances-importing [<module> [<module> [<module...]]] <typeclass>. " String -> String -> String
forall a. [a] -> [a] -> [a]
++
"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
}
]
}
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
instanceP :: ClassName -> CharParser st Instance
instanceP :: String -> CharParser st String
instanceP cls :: String
cls
= String -> CharParser st String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m 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 "=" 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
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
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 "--")) 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
parseInstance :: ClassName -> String -> Maybe Instance
parseInstance :: String -> String -> Maybe String
parseInstance cls :: 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) "GHCi output"
getInstances :: String -> ClassName -> [Instance]
getInstances :: String -> String -> [String]
getInstances s :: String
s cls :: String
cls
| Bool -> Bool
not Bool
classFound
= ["Couldn't find class `"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
clsString -> String -> String
forall a. [a] -> [a] -> [a]
++"'. 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
=~ ("class.*" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cls String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".*where")
splut :: [String]
splut = String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn "instance" String
s
notOperator :: String -> Bool
notOperator = (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\c :: 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` "()" ])
unbracket :: String -> String
unbracket str :: String
str | String -> Char
forall a. [a] -> a
head String
str Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '(' Bool -> Bool -> Bool
&& String -> Char
forall a. [a] -> a
last String
str Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ')' 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
/=',') 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
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
. ("instance"String -> String -> String
forall a. [a] -> [a] -> [a]
++)
stdMdls :: [ModuleName]
stdMdls :: [String]
stdMdls = [String]
controls
where monads :: [String]
monads = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ("Monad."String -> String -> String
forall a. [a] -> [a] -> [a]
++)
[ "Cont", "Error", "Fix", "Reader", "RWS", "ST",
"State", "Trans", "Writer" ]
controls :: [String]
controls = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ("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]
++ ["Arrow"]
fetchInstances :: MonadLB m => ClassName -> m String
fetchInstances :: String -> m String
fetchInstances cls :: String
cls = String -> [String] -> m String
forall (m :: * -> *). MonadLB m => String -> [String] -> m String
fetchInstances' String
cls [String]
stdMdls
fetchInstancesImporting :: MonadLB m => String -> m String
fetchInstancesImporting :: String -> m String
fetchInstancesImporting args :: 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
fetchInstances' :: MonadLB m => String -> [ModuleName] -> m String
fetchInstances' :: String -> [String] -> m String
fetchInstances' cls :: String
cls mdls :: [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
[ [":l", String
load]
, ":m" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: "+" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
mdls
, [":i", String
cls]
]
String
ghci <- Config String -> m String
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
ghciBinary
(_, out :: String
out, err :: 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 ["-ignore-dot-ghci","-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]
is