lambdabot-haskell-plugins-5.0: src/Lambdabot/Plugin/Haskell/Instances.hs

{- | A module to output the instances of a typeclass.
     Some sample input\/output:

> lambdabot> @instances Monad
> [], ArrowMonad a, WriterT w m, Writer w, ReaderT r m, Reader r,
> StateT s m, State s, RWST r w s m, RWS r w s, ErrorT e m, Either e,
> ContT r m, Cont r, Maybe, ST s, IO
>
> lambdabot> @instances Show
> Float, Double, Integer, ST s a, [a], (a, b, c, d), (a, b, c), (a, b),
> (), Ordering, Maybe a, Int, Either a b, Char, Bool
>
> lambdabot> @instances-importing Text.Html Data.Tree Show
> Float, Double, Tree a, HtmlTable, HtmlAttr, Html, HotLink, Integer,
> ST s a, [a], (a, b, c, d), (a, b, c), (a, b), (), Ordering, Maybe a,
> Int
-}

module Lambdabot.Plugin.Haskell.Instances (instancesPlugin) where

import Text.ParserCombinators.Parsec

import Lambdabot.Config.Haskell
import Lambdabot.Plugin
import Lambdabot.Util

import Control.Applicative ((*>))
import Control.Monad
import Data.Char
import Data.List
import Data.List.Split
import Data.Maybe
import System.FilePath
import System.Process
import Text.Regex.TDFA

type Instance   = String
type ClassName  = String
type ModuleName = String

instancesPlugin :: Module ()
instancesPlugin = newModule
    { moduleCmds = return
        [ (command "instances")
            { help = say "instances <typeclass>. Fetch the instances of a typeclass."
            , process = fetchInstances >=> say
            }
        , (command "instances-importing")
            { help = say $
                "instances-importing [<module> [<module> [<module...]]] <typeclass>. " ++
                "Fetch the instances of a typeclass, importing specified modules first."
            , process = fetchInstancesImporting >=> say
            }
        ]
    }

-- | Nice little combinator used to throw away error messages from an Either
--   and just keep a Maybe indicating the success of the computation.
eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe = either (const Nothing) Just

-- * Parsing
--

-- | Parse an instance declaration. Sample inputs:
--
-- > instance Monad []
-- > instance (Monoid w) => Monad (Writer w)
-- > instance (State s)
--
instanceP :: ClassName -> CharParser st Instance
instanceP cls
    =  string "instance " *> (try constrained <|> unconstrained) *> skipMany space
    *> anyChar `manyTill` end
    where constrained   = noneOf "=" `manyTill` string ("=> " ++ cls)
          unconstrained = string cls
          
          -- break on the "imported from" comment or a newline.
          end           = void (try (string "--")) <|> eof

-- | Wrapper for the instance parser.
parseInstance :: ClassName -> String -> Maybe Instance
parseInstance cls = fmap (strip isSpace) . eitherToMaybe
                    . parse (instanceP cls) "GHCi output"

-- | Split the input into a list of the instances, then run each instance
--   through the parser. Collect successes.
getInstances :: String -> ClassName -> [Instance]
getInstances s cls
    | not classFound -- can't trust those dodgy folk in #haskell
    = ["Couldn't find class `"++cls++"'. Try @instances-importing"]

   | otherwise = sort $ mapMaybe doParse (tail splut)

    where classFound   = s =~ ("class.*" ++ cls ++ ".*where")
          splut        = splitOn "instance" s -- splut being the past participle
                                            -- of 'to split', obviously. :)
          notOperator  = all (\c -> or
                               [ isAlpha c,
                                 isSpace c,
                                 c `elem` "()" ])
          unbracket str | head str == '(' && last str == ')' &&
                          all (/=',') str && notOperator str && str /= "()" =
                          init $ tail str
                        | otherwise = str
          doParse = fmap unbracket . parseInstance cls . ("instance"++)

-- * Delegation; interface with GHCi
--

-- | The standard modules we ask GHCi to load.
stdMdls :: [ModuleName]
stdMdls = controls
    where monads   = map ("Monad."++)
                       [ "Cont", "Error", "Fix", "Reader", "RWS", "ST",
                         "State", "Trans", "Writer" ]
          controls = map ("Control." ++) $ monads ++ ["Arrow"]

-- | Main processing function for \@instances. Takes a class name and
--   return a list of lines to output (which will actually only be one).
fetchInstances :: MonadLB m => ClassName -> m String
fetchInstances cls = fetchInstances' cls stdMdls

-- | Main processing function for \@instances-importing. Takes the args, which
--   are words'd. The all but the last argument are taken to be the modules to
--   import, and the last is the typeclass whose instances we want to print.
fetchInstancesImporting :: MonadLB m => String -> m String
fetchInstancesImporting args = fetchInstances' cls mdls
    where args' = words args
          cls   = last args'
          mdls  = nub $ init args' ++ stdMdls

-- | Interface with GHCi to get the input for the parser, then send it through
--   the parser.
fetchInstances' :: MonadLB m => String -> [ModuleName] -> m String
fetchInstances' cls mdls = do
    stateDir <- getConfig outputDir
    let s = unlines $ map unwords
            [ [":l", show (stateDir </> "L")]
            ,  ":m" : "+" : mdls
            , [":i", cls]
            ]
    
    ghci <- getConfig ghciBinary
    (_, out, err) <- io $ readProcessWithExitCode ghci ["-ignore-dot-ghci","-fglasgow-exts"] s
    let is = getInstances out cls
    return $ if null is
               then err
               else intercalate ", " is