{-# 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 = 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

--     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 forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
foo

--     into GHCi and send any line matching

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

--
-- 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 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 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
'{':[])   = []  -- unterminated
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
_      = []   -- 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
        = 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

--
--     With this the command handler can be easily defined using readProcessWithExitCode:
--
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" -- using -fforce-recomp to make sure we get *L in scope instead of just L
        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 -- "bzzt"
               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"