    {-# 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 = return
            [ (command "type")
                { help = say "type <expr>. Return the type of a value"
                , process = runit ":t"
                }
            , (command "kind")
                { help = say "kind <type>. Return the kind of a type"
                , process = runit ":k"
                }
            ]

        , 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 a. a -> Cmd (ModuleT () LB) a
    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 = 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 a b. Cmd m a -> (a -> Cmd m b) -> Cmd m b
    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 a b. (a -> b) -> Maybe a -> Maybe b
    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 a b. Maybe a -> (a -> Maybe b) -> Maybe b
    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 a b. (a -> b) -> Maybe a -> Maybe b
    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
    forall (m :: * -> *).
    MonadFail m =>
    Regex -> String -> m (MatchResult String)
    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. HasCallStack => [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 a b. (a -> b) -> Maybe a -> Maybe b
    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 a b. (a -> b) -> Maybe a -> Maybe b
    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 a b. (a -> b) -> Maybe a -> Maybe b
    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 :: forall (m :: * -> *). MonadLB m => String -> String -> m String
    query_ghci String
    cmd String
    expr = do
        l <- m String
    forall (m :: * -> *). MonadLB m => m String
    findL_hs
        exts <- getConfig languageExts
        let 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
    "-X" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ext | String
    ext <- [String]
    exts]
        ghci <- getConfig ghciBinary
        (_, output, errors) <- io $ readProcessWithExitCode ghci
            ("-v0":"-fforce-recomp":"-iState":"-ignore-dot-ghci":extFlags)
            (context ++ theCommand cmd (stripComments (decodeString expr)))
        let ls = String -> Maybe String
    extract_signatures String
    output
        return $ case 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 a. [a] -> 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"