{-# 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 "type")
            { help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say "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 ":t"
            }
        , (String -> Command Identity
command "kind")
            { help :: Cmd (ModuleT () LB) ()
help = String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say "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 ":k"
            }
        ]

    , contextual :: String -> Cmd (ModuleT () LB) ()
contextual = \text :: String
text ->
        let (prefix :: String
prefix, expr :: String
expr) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt 3 String
text
        in case String
prefix of
            ":t " -> String -> String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). MonadLB m => String -> String -> Cmd m ()
runit ":t" String
expr
            ":k " -> String -> String -> Cmd (ModuleT () LB) ()
forall (m :: * -> *). MonadLB m => String -> String -> Cmd m ()
runit ":k" String
expr
            _     -> () -> 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 s :: String
s expr :: 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 cmd :: String
cmd foo :: String
foo = String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " 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
    "^(\\*?[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 ('\n':_)    = [] -- drop any newwline and rest. *security*
stripComments ('-':'-':_) = []  --
stripComments ('{':'-':cs :: String
cs)= String -> String
stripComments (Int -> String -> String
go 1 String
cs)
stripComments (c :: Char
c:cs :: 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 0 xs :: String
xs         = String
xs
go _ ('-':[])   = []   -- unterminated
go n :: Int
n ('-':x :: Char
x:xs :: String
xs)
    | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '}'  = Int -> String -> String
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) String
xs
    | Bool
otherwise = Int -> String -> String
go Int
n (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs)
go _ ('{':[])   = []  -- unterminated
go n :: Int
n ('{':x :: Char
x:xs :: String
xs)
    | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-'  = Int -> String -> String
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) String
xs
    | Bool
otherwise = Int -> String -> String
go Int
n (Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
xs)
go n :: Int
n (_:xs :: String
xs) = Int -> String -> String
go Int
n String
xs
go _ _      = []   -- 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 output :: 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 -> 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 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' xs :: [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 xs :: String
xs = Int -> String -> Maybe String
removeExp' 0 String
xs

        removeExp' :: Int -> String -> Maybe String
        removeExp' :: Int -> String -> Maybe String
removeExp' 0 (' ':':':':':' ':_) = String -> Maybe String
forall a. a -> Maybe a
Just []
        removeExp' n :: Int
n ('(':xs :: String
xs)            = ('('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
+1) String
xs
        removeExp' n :: Int
n (')':xs :: String
xs)            = (')'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
-1) String
xs
        removeExp' n :: Int
n (x :: Char
x  :xs :: 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' _ []                  = 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 cmd :: String
cmd expr :: 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 = ":load "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
lString -> String -> String
forall a. [a] -> [a] -> [a]
++"\n:m *L\n" -- using -fforce-recomp to make sure we get *L in scope instead of just L
        extFlags :: [String]
extFlags = ["-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
    (_, output :: String
output, errors :: 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
        ("-v0"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:"-fforce-recomp"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:"-iState"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:"-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
               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 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 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
/='\r') (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
errors -- "bzzt"
               Just t :: String
t -> String
t

    where
        cleanRE, cleanRE2 :: String -> String
        cleanRE :: String -> String
cleanRE s :: 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  = "Couldn\'t find qualified module."
            | Just m :: 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 s :: String
s
            | Just m :: 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 = "<interactive>:[^:]*:[^:]*: ?"
        notfound :: String
notfound = "Failed to load interface"