{-# LANGUAGE PatternGuards #-}
module Lambdabot.Plugin.Haskell.Type (typePlugin, query_ghci) where
import Lambdabot.Config.Haskell
import Lambdabot.Plugin
import Lambdabot.Util
import Lambdabot.Plugin.Haskell.Eval (findL_hs)
import Codec.Binary.UTF8.String
import Data.Char
import Data.Maybe
import System.Process
import Text.Regex.TDFA
typePlugin :: Module ()
typePlugin :: Module ()
typePlugin = forall st. Module st
newModule
{ moduleCmds :: ModuleT () LB [Command (ModuleT () LB)]
moduleCmds = forall (m :: * -> *) a. Monad m => a -> m a
return
[ (String -> Command Identity
command String
"type")
{ help :: Cmd (ModuleT () LB) ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"type <expr>. Return the type of a value"
, process :: String -> Cmd (ModuleT () LB) ()
process = forall (m :: * -> *). MonadLB m => String -> String -> Cmd m ()
runit String
":t"
}
, (String -> Command Identity
command String
"kind")
{ help :: Cmd (ModuleT () LB) ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"kind <type>. Return the kind of a type"
, process :: String -> Cmd (ModuleT () LB) ()
process = forall (m :: * -> *). MonadLB m => String -> String -> Cmd m ()
runit String
":k"
}
]
, contextual :: String -> Cmd (ModuleT () LB) ()
contextual = \String
text ->
let (String
prefix, String
expr) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
3 String
text
in case String
prefix of
String
":t " -> forall (m :: * -> *). MonadLB m => String -> String -> Cmd m ()
runit String
":t" String
expr
String
":k " -> forall (m :: * -> *). MonadLB m => String -> String -> Cmd m ()
runit String
":k" String
expr
String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
}
runit :: MonadLB m =>
String -> String -> Cmd m ()
runit :: forall (m :: * -> *). MonadLB m => String -> String -> Cmd m ()
runit String
s String
expr = forall (m :: * -> *). MonadLB m => String -> String -> m String
query_ghci String
s String
expr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). Monad m => String -> Cmd m ()
say
theCommand :: [Char] -> [Char] -> [Char]
theCommand :: String -> String -> String
theCommand String
cmd String
foo = String
cmd forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
foo
signature_regex :: Regex
signature_regex :: Regex
signature_regex = forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
source -> regex
makeRegex
String
"^(\\*?[A-Z][_a-zA-Z0-9]*(\\*?[A-Z][_a-zA-Z0-9]*)*>)? *(.*[ -=:].*)"
stripComments :: String -> String
[] = []
stripComments (Char
'\n':String
_) = []
stripComments (Char
'-':Char
'-':String
_) = []
stripComments (Char
'{':Char
'-':String
cs)= String -> String
stripComments (Int -> String -> String
go Int
1 String
cs)
stripComments (Char
c:String
cs) = Char
c forall a. a -> [a] -> [a]
: String -> String
stripComments String
cs
go :: Int -> String -> String
go :: Int -> String -> String
go Int
0 String
xs = String
xs
go Int
_ (Char
'-':[]) = []
go Int
n (Char
'-':Char
x:String
xs)
| Char
x forall a. Eq a => a -> a -> Bool
== Char
'}' = Int -> String -> String
go (Int
nforall a. Num a => a -> a -> a
-Int
1) String
xs
| Bool
otherwise = Int -> String -> String
go Int
n (Char
xforall a. a -> [a] -> [a]
:String
xs)
go Int
_ (Char
'{':[]) = []
go Int
n (Char
'{':Char
x:String
xs)
| Char
x forall a. Eq a => a -> a -> Bool
== Char
'-' = Int -> String -> String
go (Int
nforall a. Num a => a -> a -> a
+Int
1) String
xs
| Bool
otherwise = Int -> String -> String
go Int
n (Char
xforall a. a -> [a] -> [a]
:String
xs)
go Int
n (Char
_:String
xs) = Int -> String -> String
go Int
n String
xs
go Int
_ String
_ = []
extract_signatures :: String -> Maybe String
String
output
= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
removeExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(Char
' 'forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
[String] -> String
unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
expandTab Int
8) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a}. [a] -> Maybe a
last') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. MatchResult a -> [a]
mrSubList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall regex source target (m :: * -> *).
(RegexContext regex source target, MonadFail m) =>
regex -> source -> m target
matchM Regex
signature_regex) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> [String]
lines forall a b. (a -> b) -> a -> b
$ String
output
where
last' :: [a] -> Maybe a
last' [] = forall a. Maybe a
Nothing
last' [a]
xs = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [a]
xs
removeExp :: String -> Maybe String
removeExp :: String -> Maybe String
removeExp [] = forall a. Maybe a
Nothing
removeExp String
xs = Int -> String -> Maybe String
removeExp' Int
0 String
xs
removeExp' :: Int -> String -> Maybe String
removeExp' :: Int -> String -> Maybe String
removeExp' Int
0 (Char
' ':Char
':':Char
':':Char
' ':String
_) = forall a. a -> Maybe a
Just []
removeExp' Int
n (Char
'(':String
xs) = (Char
'('forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> String -> Maybe String
removeExp' (Int
nforall a. Num a => a -> a -> a
+Int
1) String
xs
removeExp' Int
n (Char
')':String
xs) = (Char
')'forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> String -> Maybe String
removeExp' (Int
nforall a. Num a => a -> a -> a
-Int
1) String
xs
removeExp' Int
n (Char
x :String
xs) = (Char
x forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> String -> Maybe String
removeExp' Int
n String
xs
removeExp' Int
_ [] = forall a. Maybe a
Nothing
query_ghci :: MonadLB m => String -> String -> m String
query_ghci :: forall (m :: * -> *). MonadLB m => String -> String -> m String
query_ghci String
cmd String
expr = do
String
l <- forall (m :: * -> *). MonadLB m => m String
findL_hs
[String]
exts <- forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
languageExts
let context :: String
context = String
":load "forall a. [a] -> [a] -> [a]
++String
lforall a. [a] -> [a] -> [a]
++String
"\n:m *L\n"
extFlags :: [String]
extFlags = [String
"-X" forall a. [a] -> [a] -> [a]
++ String
ext | String
ext <- [String]
exts]
String
ghci <- forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
ghciBinary
(ExitCode
_, String
output, String
errors) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
ghci
(String
"-v0"forall a. a -> [a] -> [a]
:String
"-fforce-recomp"forall a. a -> [a] -> [a]
:String
"-iState"forall a. a -> [a] -> [a]
:String
"-ignore-dot-ghci"forall a. a -> [a] -> [a]
:[String]
extFlags)
(String
context forall a. [a] -> [a] -> [a]
++ String -> String -> String
theCommand String
cmd (String -> String
stripComments (String -> String
decodeString String
expr)))
let ls :: Maybe String
ls = String -> Maybe String
extract_signatures String
output
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Maybe String
ls of
Maybe String
Nothing -> String -> String
encodeString forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map String -> String
cleanRE2 forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> [String]
lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
expandTab Int
8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
cleanRE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/=Char
'\r') forall a b. (a -> b) -> a -> b
$ String
errors
Just String
t -> String
t
where
cleanRE, cleanRE2 :: String -> String
cleanRE :: String -> String
cleanRE String
s
| String
s forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target) =>
source1 -> source -> target
=~ String
notfound = String
"Couldn\'t find qualified module."
| Just MatchResult String
m <- String
s forall source source1 target (m :: * -> *).
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target, MonadFail m) =>
source1 -> source -> m target
=~~ String
ghci_msg = forall a. MatchResult a -> a
mrAfter MatchResult String
m
| Bool
otherwise = String
s
cleanRE2 :: String -> String
cleanRE2 String
s
| Just MatchResult String
m <- String
s forall source source1 target (m :: * -> *).
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target, MonadFail m) =>
source1 -> source -> m target
=~~ String
ghci_msg = forall a. MatchResult a -> a
mrAfter MatchResult String
m
| Bool
otherwise = String
s
ghci_msg :: String
ghci_msg = String
"<interactive>:[^:]*:[^:]*: ?"
notfound :: String
notfound = String
"Failed to load interface"