{-# LANGUAGE PatternGuards #-}
-- |   The Type Module - another progressive plugin for lambdabot
--
-- pesco hamburg 2003-04-05
--
--     Greetings reader,
--
--     whether you're a regular follower of the series or dropping in for
--     the first time, let me present for your pleasure the Type Module:
--
--     One thing we enjoy on #haskell is throwing function types at each
--     other instead of spelling out tiresome monologue about arguments
--     or return values. Unfortunately such a toss often involves a local
--     lookup of the type signature in question because one is seldom
--     sure about the actual argument order.
--
--     Well, what do you know, this plugin enables lambdabot to automate
--     that lookup for you and your fellow lambda hackers.
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 = 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
"type")
            { help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"type <expr>. Return the type of a value"
            , process :: String -> Cmd (ModuleT () LB) ()
process = String -> String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). MonadLB m => String -> String -> Cmd m ()
runit String
":t"
            }
        , (String -> Command Identity
command String
"kind")
            { help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"kind <type>. Return the kind of a type"
            , process :: String -> Cmd (ModuleT () LB) ()
process = String -> String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). MonadLB m => String -> String -> Cmd m ()
runit String
":k"
            }
        ]

    , contextual :: String -> Cmd (ModuleT () LB) ()
contextual = \String
text ->
        let (String
prefix, String
expr) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
3 String
text
        in case String
prefix of
            String
":t " -> String -> String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). MonadLB m => String -> String -> Cmd m ()
runit String
":t" String
expr
            String
":k " -> String -> String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). MonadLB m => String -> String -> Cmd m ()
runit String
":k" String
expr
            String
_     -> () -> Cmd (ModuleT () LB) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    }

runit :: MonadLB m =>
         String -> String -> Cmd m ()
runit :: String -> String -> Cmd m ()
runit String
s String
expr = String -> String -> Cmd m String
forall (m :: * -> *). MonadLB m => String -> String -> m String
query_ghci String
s String
expr Cmd m String -> (String -> Cmd m ()) -> Cmd m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Cmd m ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say

--     In accordance with the KISS principle, the plan is to delegate all
--     the hard work! To get the type of foo, pipe

theCommand :: [Char] -> [Char] -> [Char]
theCommand :: String -> String -> String
theCommand String
cmd String
foo = String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
foo

--     into GHCi and send any line matching

signature_regex :: Regex
signature_regex :: Regex
signature_regex = String -> 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]*)*>)? *(.*[       -=:].*)"

--
-- Rather than use subRegex, which is new to 6.4, we can remove comments
-- old skool style.
-- Former regex for this:
--    "(\\{-[^-]*-+([^\\}-][^-]*-+)*\\}|--.*$)"
--
stripComments :: String -> String
stripComments :: String -> String
stripComments []          = []
stripComments (Char
'\n':String
_)    = [] -- drop any newwline and rest. *security*
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 Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
stripComments String
cs

-- Adapted from ghc/compiler/parser/Lexer.x
go :: Int -> String -> String
go :: Int -> String -> String
go Int
0 String
xs         = String
xs
go Int
_ (Char
'-':[])   = []   -- unterminated
go Int
n (Char
'-':Char
x:String
xs)
    | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'}'  = Int -> String -> String
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) String
xs
    | Bool
otherwise = Int -> String -> String
go Int
n (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs)
go Int
_ (Char
'{':[])   = []  -- unterminated
go Int
n (Char
'{':Char
x:String
xs)
    | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'  = Int -> String -> String
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) String
xs
    | Bool
otherwise = Int -> String -> String
go Int
n (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs)
go Int
n (Char
_:String
xs) = Int -> String -> String
go Int
n String
xs
go Int
_ String
_      = []   -- unterminated

--     through IRC.

--
--     We filtering out the lines that match our regex,
--     selecting the last subset match on each matching line before finally concatting
--     the whole lot together again.
--
extract_signatures :: String -> Maybe String
extract_signatures :: String -> Maybe String
extract_signatures String
output
        = (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
forall a. [a] -> [a]
reverse (Maybe String -> Maybe String)
-> (String -> Maybe String) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
removeExp (String -> Maybe String)
-> (String -> String) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          (Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          [String] -> String
unwords ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
expandTab Int
8) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          (String -> Maybe String) -> [String] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Maybe [String] -> ([String] -> Maybe String) -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> Maybe String
forall a. [a] -> Maybe a
last') (Maybe [String] -> Maybe String)
-> (String -> Maybe [String]) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MatchResult String -> [String])
-> Maybe (MatchResult String) -> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MatchResult String -> [String]
forall a. MatchResult a -> [a]
mrSubList (Maybe (MatchResult String) -> Maybe [String])
-> (String -> Maybe (MatchResult String))
-> String
-> Maybe [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Regex -> String -> Maybe (MatchResult String)
forall regex source target (m :: * -> *).
(RegexContext regex source target, MonadFail m) =>
regex -> source -> m target
matchM Regex
signature_regex) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          String -> [String]
lines (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
output
        where
        last' :: [a] -> Maybe a
last' [] = Maybe a
forall a. Maybe a
Nothing
        last' [a]
xs = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall a. [a] -> a
last [a]
xs

        removeExp :: String -> Maybe String
        removeExp :: String -> Maybe String
removeExp [] = Maybe String
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
_) = String -> Maybe String
forall a. a -> Maybe a
Just []
        removeExp' Int
n (Char
'(':String
xs)            = (Char
'('Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> String -> Maybe String
removeExp' (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) String
xs
        removeExp' Int
n (Char
')':String
xs)            = (Char
')'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> String -> Maybe String
removeExp' (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) String
xs
        removeExp' Int
n (Char
x  :String
xs)            = (Char
x  Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Int -> String -> Maybe String
removeExp'  Int
n    String
xs
        removeExp' Int
_ []                  = Maybe String
forall a. Maybe a
Nothing

--
--     With this the command handler can be easily defined using readProcessWithExitCode:
--
query_ghci :: MonadLB m => String -> String -> m String
query_ghci :: String -> String -> m String
query_ghci String
cmd String
expr = do
    String
l <- m String
forall (m :: * -> *). MonadLB m => m String
findL_hs
    [String]
exts <- Config [String] -> m [String]
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config [String]
languageExts
    let context :: String
context = String
":load "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
lString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n:m *L\n" -- using -fforce-recomp to make sure we get *L in scope instead of just L
        extFlags :: [String]
extFlags = [String
"-X" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ext | String
ext <- [String]
exts]
    String
ghci <- Config String -> m String
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
ghciBinary
    (ExitCode
_, String
output, String
errors) <- 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
"-v0"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"-fforce-recomp"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"-iState"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"-ignore-dot-ghci"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
extFlags)
        (String
context String -> String -> String
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
    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
$ case Maybe String
ls of
               Maybe String
Nothing -> String -> String
encodeString (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
3 ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
cleanRE2 ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          String -> [String]
lines (String -> [String]) -> (String -> String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
expandTab Int
8 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
cleanRE (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\r') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
errors -- "bzzt"
               Just String
t -> String
t

    where
        cleanRE, cleanRE2 :: String -> String
        cleanRE :: String -> String
cleanRE String
s
            |           String
s String -> String -> Bool
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 String -> String -> Maybe (MatchResult String)
forall source source1 target (m :: * -> *).
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target, MonadFail m) =>
source1 -> source -> m target
=~~ String
ghci_msg  = MatchResult String -> String
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 String -> String -> Maybe (MatchResult String)
forall source source1 target (m :: * -> *).
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target, MonadFail m) =>
source1 -> source -> m target
=~~ String
ghci_msg  = MatchResult String -> String
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"