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
[ ([Char] -> Command Identity
command [Char]
"instances")
{ help :: Cmd (ModuleT () LB) ()
help = [Char] -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => [Char] -> Cmd m ()
say [Char]
"instances <typeclass>. Fetch the instances of a typeclass."
, process :: [Char] -> Cmd (ModuleT () LB) ()
process = [Char] -> Cmd (ModuleT () LB) [Char]
forall (m :: * -> *). MonadLB m => [Char] -> m [Char]
fetchInstances ([Char] -> Cmd (ModuleT () LB) [Char])
-> ([Char] -> Cmd (ModuleT () LB) ())
-> [Char]
-> Cmd (ModuleT () LB) ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [Char] -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => [Char] -> Cmd m ()
say
}
, ([Char] -> Command Identity
command [Char]
"instances-importing")
{ help :: Cmd (ModuleT () LB) ()
help = [Char] -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => [Char] -> Cmd m ()
say ([Char] -> Cmd (ModuleT () LB) ())
-> [Char] -> Cmd (ModuleT () LB) ()
forall a b. (a -> b) -> a -> b
$
[Char]
"instances-importing [<module> [<module> [<module...]]] <typeclass>. " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
[Char]
"Fetch the instances of a typeclass, importing specified modules first."
, process :: [Char] -> Cmd (ModuleT () LB) ()
process = [Char] -> Cmd (ModuleT () LB) [Char]
forall (m :: * -> *). MonadLB m => [Char] -> m [Char]
fetchInstancesImporting ([Char] -> Cmd (ModuleT () LB) [Char])
-> ([Char] -> Cmd (ModuleT () LB) ())
-> [Char]
-> Cmd (ModuleT () LB) ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [Char] -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => [Char] -> Cmd m ()
say
}
]
}
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
instanceP :: ClassName -> CharParser st Instance
instanceP :: forall st. [Char] -> CharParser st [Char]
instanceP [Char]
cls
= [Char] -> ParsecT [Char] st Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"instance " ParsecT [Char] st Identity [Char]
-> ParsecT [Char] st Identity [Char]
-> ParsecT [Char] st Identity [Char]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ParsecT [Char] st Identity [Char]
-> ParsecT [Char] st Identity [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try ParsecT [Char] st Identity [Char]
forall {u}. ParsecT [Char] u Identity [Char]
constrained ParsecT [Char] st Identity [Char]
-> ParsecT [Char] st Identity [Char]
-> ParsecT [Char] st Identity [Char]
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT [Char] st Identity [Char]
forall {u}. ParsecT [Char] u Identity [Char]
unconstrained) ParsecT [Char] st Identity [Char]
-> ParsecT [Char] st Identity () -> ParsecT [Char] st Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT [Char] st Identity Char -> ParsecT [Char] st Identity ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany ParsecT [Char] st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space
ParsecT [Char] st Identity ()
-> ParsecT [Char] st Identity [Char]
-> ParsecT [Char] st Identity [Char]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT [Char] st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
anyChar ParsecT [Char] st Identity Char
-> ParsecT [Char] st Identity ()
-> ParsecT [Char] st Identity [Char]
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 [Char] st Identity ()
forall {u}. ParsecT [Char] u Identity ()
end
where constrained :: ParsecT [Char] u Identity [Char]
constrained = [Char] -> ParsecT [Char] u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m Char
noneOf [Char]
"=" ParsecT [Char] u Identity Char
-> ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
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` [Char] -> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string ([Char]
"=> " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cls)
unconstrained :: ParsecT [Char] u Identity [Char]
unconstrained = [Char] -> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
cls
end :: ParsecT [Char] u Identity ()
end = ParsecT [Char] u Identity [Char] -> ParsecT [Char] u Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT [Char] u Identity [Char]
-> ParsecT [Char] u Identity [Char]
forall tok st a. GenParser tok st a -> GenParser tok st a
try ([Char] -> ParsecT [Char] u Identity [Char]
forall s (m :: * -> *) u.
Stream s m Char =>
[Char] -> ParsecT s u m [Char]
string [Char]
"--")) ParsecT [Char] u Identity ()
-> ParsecT [Char] u Identity () -> ParsecT [Char] u Identity ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ParsecT [Char] u Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
parseInstance :: ClassName -> String -> Maybe Instance
parseInstance :: [Char] -> [Char] -> Maybe [Char]
parseInstance [Char]
cls = ([Char] -> [Char]) -> Maybe [Char] -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
strip Char -> Bool
isSpace) (Maybe [Char] -> Maybe [Char])
-> ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ParseError [Char] -> Maybe [Char]
forall a b. Either a b -> Maybe b
eitherToMaybe
(Either ParseError [Char] -> Maybe [Char])
-> ([Char] -> Either ParseError [Char]) -> [Char] -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec [Char] () [Char]
-> [Char] -> [Char] -> Either ParseError [Char]
forall s t a.
Stream s Identity t =>
Parsec s () a -> [Char] -> s -> Either ParseError a
parse ([Char] -> Parsec [Char] () [Char]
forall st. [Char] -> CharParser st [Char]
instanceP [Char]
cls) [Char]
"GHCi output"
getInstances :: String -> ClassName -> [Instance]
getInstances :: [Char] -> [Char] -> [[Char]]
getInstances [Char]
s [Char]
cls
| Bool -> Bool
not Bool
classFound
= [[Char]
"Couldn't find class `"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
cls[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"'. Try @instances-importing"]
| Bool
otherwise = [[Char]] -> [[Char]]
forall a. Ord a => [a] -> [a]
sort ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Maybe [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Char] -> Maybe [Char]
doParse ([[Char]] -> [[Char]]
forall a. [a] -> [a]
tail [[Char]]
splut)
where classFound :: Bool
classFound = [Char]
s [Char] -> [Char] -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
=~ ([Char]
"class.*" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cls [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".*where")
splut :: [[Char]]
splut = [Char] -> [Char] -> [[Char]]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn [Char]
"instance" [Char]
s
notOperator :: [Char] -> Bool
notOperator = (Char -> Bool) -> [Char] -> 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 -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
"()" ])
unbracket :: [Char] -> [Char]
unbracket [Char]
str | [Char] -> Char
forall a. [a] -> a
head [Char]
str Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'(' Bool -> Bool -> Bool
&& [Char] -> Char
forall a. [a] -> a
last [Char]
str Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
')' Bool -> Bool -> Bool
&&
(Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
',') [Char]
str Bool -> Bool -> Bool
&& [Char] -> Bool
notOperator [Char]
str Bool -> Bool -> Bool
&& [Char]
str [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
"()" =
[Char] -> [Char]
forall a. [a] -> [a]
init ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
forall a. [a] -> [a]
tail [Char]
str
| Bool
otherwise = [Char]
str
doParse :: [Char] -> Maybe [Char]
doParse = ([Char] -> [Char]) -> Maybe [Char] -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> [Char]
unbracket (Maybe [Char] -> Maybe [Char])
-> ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> Maybe [Char]
parseInstance [Char]
cls ([Char] -> Maybe [Char])
-> ([Char] -> [Char]) -> [Char] -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"instance"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
stdMdls :: [ModuleName]
stdMdls :: [[Char]]
stdMdls = [[Char]]
controls
where monads :: [[Char]]
monads = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"Monad."[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
[ [Char]
"Cont", [Char]
"Error", [Char]
"Fix", [Char]
"Reader", [Char]
"RWS", [Char]
"ST",
[Char]
"State", [Char]
"Trans", [Char]
"Writer" ]
controls :: [[Char]]
controls = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"Control." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]]
monads [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"Arrow"]
fetchInstances :: MonadLB m => ClassName -> m String
fetchInstances :: forall (m :: * -> *). MonadLB m => [Char] -> m [Char]
fetchInstances [Char]
cls = [Char] -> [[Char]] -> m [Char]
forall (m :: * -> *). MonadLB m => [Char] -> [[Char]] -> m [Char]
fetchInstances' [Char]
cls [[Char]]
stdMdls
fetchInstancesImporting :: MonadLB m => String -> m String
fetchInstancesImporting :: forall (m :: * -> *). MonadLB m => [Char] -> m [Char]
fetchInstancesImporting [Char]
args = [Char] -> [[Char]] -> m [Char]
forall (m :: * -> *). MonadLB m => [Char] -> [[Char]] -> m [Char]
fetchInstances' [Char]
cls [[Char]]
mdls
where args' :: [[Char]]
args' = [Char] -> [[Char]]
words [Char]
args
cls :: [Char]
cls = [[Char]] -> [Char]
forall a. [a] -> a
last [[Char]]
args'
mdls :: [[Char]]
mdls = [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
forall a. [a] -> [a]
init [[Char]]
args' [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
stdMdls
fetchInstances' :: MonadLB m => String -> [ModuleName] -> m String
fetchInstances' :: forall (m :: * -> *). MonadLB m => [Char] -> [[Char]] -> m [Char]
fetchInstances' [Char]
cls [[Char]]
mdls = do
[Char]
load <- m [Char]
forall (m :: * -> *). MonadLB m => m [Char]
findL_hs
let s :: [Char]
s = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ ([[Char]] -> [Char]) -> [[[Char]]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [[Char]] -> [Char]
unwords
[ [[Char]
":l", [Char]
load]
, [Char]
":m" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [Char]
"+" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
mdls
, [[Char]
":i", [Char]
cls]
]
[Char]
ghci <- Config [Char] -> m [Char]
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [Char]
ghciBinary
(ExitCode
_, [Char]
out, [Char]
err) <- IO (ExitCode, [Char], [Char]) -> m (ExitCode, [Char], [Char])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (ExitCode, [Char], [Char]) -> m (ExitCode, [Char], [Char]))
-> IO (ExitCode, [Char], [Char]) -> m (ExitCode, [Char], [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char] -> IO (ExitCode, [Char], [Char])
readProcessWithExitCode [Char]
ghci [[Char]
"-ignore-dot-ghci",[Char]
"-fglasgow-exts"] [Char]
s
let is :: [[Char]]
is = [Char] -> [Char] -> [[Char]]
getInstances [Char]
out [Char]
cls
[Char] -> m [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> m [Char]) -> [Char] -> m [Char]
forall a b. (a -> b) -> a -> b
$ if [[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
is
then [Char]
err
else [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " [[Char]]
is