-- Copyright (c) 2004-5 Don Stewart - http://www.cse.unsw.edu.au/~dons
-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)

-- | Talk to Neil Mitchell's `Hoogle' program
module Lambdabot.Plugin.Haskell.Hoogle (hooglePlugin) where

import Lambdabot.Config.Haskell
import Lambdabot.Plugin
import Lambdabot.Util
import System.Process

hooglePlugin :: Module [String]
hooglePlugin :: Module [String]
hooglePlugin = Module [String]
forall st. Module st
newModule
    { moduleDefState :: LB [String]
moduleDefState = [String] -> LB [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    , moduleCmds :: ModuleT [String] LB [Command (ModuleT [String] LB)]
moduleCmds = [Command (ModuleT [String] LB)]
-> ModuleT [String] LB [Command (ModuleT [String] LB)]
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
"hoogle")
            { help :: Cmd (ModuleT [String] LB) ()
help = String -> Cmd (ModuleT [String] LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"hoogle <expr>. Haskell API Search for either names, or types."
            , process :: String -> Cmd (ModuleT [String] LB) ()
process = \String
s -> do
                String
binary <- Config String -> Cmd (ModuleT [String] LB) String
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config String
hoogleBinary
                [String]
o <- IO [String] -> Cmd (ModuleT [String] LB) [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> String -> IO [String]
hoogle String
binary String
s)
                let ([String]
this,[String]
that) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
3 [String]
o
                LBState (Cmd (ModuleT [String] LB)) -> Cmd (ModuleT [String] LB) ()
forall (m :: * -> *). MonadLBState m => LBState m -> m ()
writeMS [String]
LBState (Cmd (ModuleT [String] LB))
that
                (String -> Cmd (ModuleT [String] LB) ())
-> [String] -> Cmd (ModuleT [String] LB) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Cmd (ModuleT [String] LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say [String]
this
            }
        , (String -> Command Identity
command String
"hoogle+")
            -- TODO: what does this really do?  give it a proper help msg
            { help :: Cmd (ModuleT [String] LB) ()
help = String -> Cmd (ModuleT [String] LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"hoogle <expr>. Haskell API Search for either names, or types."
            , process :: String -> Cmd (ModuleT [String] LB) ()
process = \String
_ -> do
                [String]
this <- (LBState (Cmd (ModuleT [String] LB))
 -> (LBState (Cmd (ModuleT [String] LB))
     -> Cmd (ModuleT [String] LB) ())
 -> Cmd (ModuleT [String] LB) [String])
-> Cmd (ModuleT [String] LB) [String]
forall (m :: * -> *) a.
MonadLBState m =>
(LBState m -> (LBState m -> m ()) -> m a) -> m a
withMS ((LBState (Cmd (ModuleT [String] LB))
  -> (LBState (Cmd (ModuleT [String] LB))
      -> Cmd (ModuleT [String] LB) ())
  -> Cmd (ModuleT [String] LB) [String])
 -> Cmd (ModuleT [String] LB) [String])
-> (LBState (Cmd (ModuleT [String] LB))
    -> (LBState (Cmd (ModuleT [String] LB))
        -> Cmd (ModuleT [String] LB) ())
    -> Cmd (ModuleT [String] LB) [String])
-> Cmd (ModuleT [String] LB) [String]
forall a b. (a -> b) -> a -> b
$ \LBState (Cmd (ModuleT [String] LB))
st LBState (Cmd (ModuleT [String] LB)) -> Cmd (ModuleT [String] LB) ()
write -> do
                    let ([String]
this,[String]
that) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
3 [String]
LBState (Cmd (ModuleT [String] LB))
st
                    LBState (Cmd (ModuleT [String] LB)) -> Cmd (ModuleT [String] LB) ()
write [String]
LBState (Cmd (ModuleT [String] LB))
that
                    [String] -> Cmd (ModuleT [String] LB) [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
this
                (String -> Cmd (ModuleT [String] LB) ())
-> [String] -> Cmd (ModuleT [String] LB) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Cmd (ModuleT [String] LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say [String]
this
            }
        ]
    }

------------------------------------------------------------------------

-- arbitrary cutoff point
cutoff :: Int
cutoff :: Int
cutoff = -Int
10

-- | Actually run the hoogle binary
hoogle :: String -> String -> IO [String]
hoogle :: String -> String -> IO [String]
hoogle String
binary String
s = do
        let args :: [String]
args = [String
"--count=20", String
s]
        (ExitCode
_,String
out,String
err) <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
binary [String]
args String
""
        [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> [String]
result String
out String
err

    where result :: String -> String -> [String]
result [] [] = [String
"A Hoogle error occurred."]
          result [] String
ys = [String
ys]
          result String
xs String
_  =
                let xs' :: [(Int, String)]
xs' = (String -> (Int, String)) -> [String] -> [(Int, String)]
forall a b. (a -> b) -> [a] -> [b]
map String -> (Int, String)
toPair ([String] -> [(Int, String)]) -> [String] -> [(Int, String)]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
xs
                    res :: [String]
res = ((Int, String) -> String) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int, String) -> String
forall a b. (a, b) -> b
snd ([(Int, String)] -> [String]) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ ((Int, String) -> Bool) -> [(Int, String)] -> [(Int, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
cutoff) (Int -> Bool) -> ((Int, String) -> Int) -> (Int, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, String) -> Int
forall a b. (a, b) -> a
fst) [(Int, String)]
xs'
                in if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
res
                   then [String
"No matches, try a more general search"]
                   else [String]
res

          toPair :: String -> (Int, String)
toPair String
s' = let (String
res, String
meta)  = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'@') String
s'
                          rank :: String
rank = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
' ') (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
meta
                      in case String -> Maybe Int
forall (m :: * -> *) a. (MonadFail m, Read a) => String -> m a
readM String
rank :: Maybe Int of
                         Just Int
n  -> (Int
n,String
res)
                         Maybe Int
Nothing -> (Int
0,String
res)