packages feed

lambdabot 4.2.3.3 → 4.3

raw patch · 221 files changed

+12791/−17061 lines, 221 filesdep +QuickCheckdep +SafeSemaphoredep +dependent-mapdep −haskell-srcdep −lambdabot-utilsdep −old-timedep ~HTTPdep ~IOSpecdep ~MonadRandomnew-uploader

Dependencies added: QuickCheck, SafeSemaphore, dependent-map, dependent-sum, dependent-sum-template, dice, edit-distance, haskeline, hoogle, hslogger, hstatsd, lambdabot, lifted-base, misfortune, monad-control, mueval, process, random-fu, random-source, regex-tdfa, split, time, transformers, transformers-base, zlib

Dependencies removed: haskell-src, lambdabot-utils, old-time, readline, regex-compat

Dependency ranges changed: HTTP, IOSpec, MonadRandom, array, arrows, base, binary, brainfuck, bytestring, containers, data-memocombinators, directory, filepath, haskell-src-exts, logict, mtl, network, numbers, oeis, parsec, pretty, random, show, syb, tagsoup, template-haskell, unix, unlambda, utf8-string, vector-space

Files

+ AUTHORS.md view
@@ -0,0 +1,158 @@+AUTHORS+========++The following people have made contributions to the Lambdabot project.  There are probably others as well.++* Andrew J. Bromage <ajb@spamcop.net> aka Pseudonym on #haskell++  - the 'bot itself+  - @free++* Shae M. Erisson <shae@ScannedInAvian.com> aka shapr on #haskell++  - FactModule+  - FortuneModule+  - StateModule+  - SystemModule++* Taylor Campbell <riastradh@users.sourceforge.net> aka Riastradh on #haskell++  - KarmaModule++* Derek Elkins <ddarius@users.sourceforge.net> aka Darius on #haskell++  - EvalModule++* Sven M. Hallberg <pesco@haquebright.de> aka pesco on #haskell++  - TopicModule++* Tom Moertel <tom@moertel.com> aka tmoertel on #haskell++  - DictModule++* Mats-Ola Persson <polli@users.sourceforge.net> aka polli on #haskell++  - rewrite of the plugin system++* Ganesh Sittampalam <ganesh@earth.li> aka Heffalump on #haskell++  - Various restructuring to improve bot robustness+  - Dynamic module loading++* Don Stewart <dons@galois.com> aka dons on #haskell++  - New build system, 6.4 port+  - dynamic module loading with hs-plugins+  - Simplfied module interface+  - @babel, @plugs, @version, @code, @spell, @djinn, @unlambda, @hylo, @freshname, @ft, @src+  - Offline mode+  - General hacking+  - Cabalised build system+  - GHCi build system++* Jesper Louis Andersen <jlouis@mongers.org> aka jlouis on #haskell++  - Code/Documentation cleanups++* Thomas Jäger <TheHunter2000@web.de> aka TheHunter on #haskell++  - PlModule+  - General hacking/refactoring.++* Stefan Wehr <mail@stefanwehr.de> aka stefanw on #haskell++  - DarcsPatchWatch module++* Simon Winwood++  - Babel module+  - Log module++* Mark Wotton (blackdog)++  - Vixen++* Paolo Martini (xerox)++  - @hoogle, @botsnack, work on @karma++* Vaclav Haisman++  - Tweaks to textual interface++* Joel Koerwer++  - google calculator++* Josef Svenningsson++  - @elite++* Ketil Malde++  - Improved @seen++* Echo Nolan++  - grammar++* Samuel Bronson++  - Improved search code. @google++* Peter Davis++  - @moos ++++* andres@cs.uu.nl++  - line breaks, topics,++* Kenneth Hoste++  - @vote++* softpro@gmx.net++  - @pretty++* tatd2@kent.ac.uk++  - actions / slapping++* rizzix <rizzixs@fastmail.fm>++  - Minor fixed and workarounds+  - @gsite++* David House <dmhouse@gmail.com>++  - Instances, Tell.++* Pete Kazmier <pete-lambdabot@kazmier.com>++  - Url page title chaser+  - Contextual messages++* Stefan O'Rear <stefanor@cox.net> aka sorear on #haskell++  - @nazi-on, @nazi-off, @activity+  - Non-flat nick namespace+  - Separation of servers out of base++* Spencer Janssen <sjanssen@cse.unl.edu> aka sjanssen on #haskell++  - @undo, @redo++* Gwern Branwen <gwern0@gmail.com> aka gwern on #haskell++  - Packaging of unlambda and brainfuck++* James Cook <mokus@deepbondi.net> aka mokus on #haskell++  - Stuff.  I dedicate all my contributions to the public domain.++* Jan Stolarek <jan.stolarek@p.lodz.pl> aka killy9999 on #haskell++  - More stuff, mostly code cleanup.
+ COMMANDS view
@@ -0,0 +1,47 @@+activity provides: activity+base has no visible commands+bf provides: bf+check provides: check+compose provides: @ ? . compose+dice provides: dice roll+dict provides: dict-help all-dicts bouvier cide devils easton elements foldoc gazetteer hitchcock jargon thesaurus vera wn world02+djinn provides: djinn djinn-add djinn-del djinn-env djinn-names djinn-clr djinn-ver+dummy provides: eval choose dummy bug id show wiki paste docs learn haskellers botsnack get-shapr shootout faq googleit hackage thanks thx thank you ping tic-tac-toe+elite provides: elite leet l33t 1337+eval provides: run let define undefine+filter provides: austro b1ff brooklyn chef cockney drawl dubya fudd funetak jethro jive kraut pansy pirate postmodern redneck valspeak warez+free provides: free+fresh provides: freshname+haddock provides: index+help provides: help+hoogle provides: hoogle hoogle++instances provides: instances instances-importing+irc has no visible commands+karma provides: karma karma+ karma- karma-all+localtime provides: time localtime localtime-reply+more provides: more+oeis provides: oeis sequence+offlinerc has no visible commands+pl provides: pointless pl pl-resume+pointful provides: pointful pointy repoint unpointless unpl unpf+poll provides: poll-list poll-show poll-add choice-add vote poll-result poll-close poll-remove+pretty provides: pretty+quote provides: quote remember forget ghc fortune yow arr yarr keal b52s pinky brain palomer girl19 v yhjulwwiefzojcbxybbruweejw protontorpedo nixon farber+search provides: google gsite gwiki+seen provides: users seen+slap provides: slap smack+source provides: src+spell provides: spell spell-all+system provides: listchans listmodules listservers list echo uptime+tell provides: tell ask messages messages-loud messages? clear-messages+ticker provides: ticker bid+todo provides: todo todo-add+topic provides: set-topic get-topic unshift-topic queue-topic shift-topic push-topic pop-topic dequeue-topic clear-topic+type provides: type kind+undo provides: undo do+unlambda provides: unlambda+unmtl provides: unmtl+url provides: url-title tiny-url+version provides: version+vixen provides: vixen+where provides: where url what where+
+ COMMENTARY.md view
@@ -0,0 +1,88 @@+COMMENTARY ON LAMBDABOT+=======================++Basic concepts+------------++Lambdabot's functionality is provided by a "core" that provides message routing and some basic infrastructure for several "plugins", which implement specific user-facing behaviors.  The core makes some assumptions about the nature of those behaviors.  The following, in no particular order, are some of the central concepts of the lambdabot design:++- Messages.  An IRC-centric representation of a chat message.  Includes information about the sender and addressee, as well as the "kind" (PRIVMSG, CTCP PING, etc.) and the text of the message.++- Servers.  A "server" is a simplified model of the kind of user interaction provided by an IRC server.  It accepts messages from a user, feeds them into the lambdabot core, and forwards messages from the core back to users.  There are currently 2 types of server defined - IRC connections and the "OfflineRC" REPL.++- Plugins (sometimes called "modules").  A plugin is described by a record of type `Module st`, where `st` is the type of the plugin's internal state.  The plugin is able to define functions to initialize, serialize, deserialize, and clean-up that state, and may additionally define "commands" and "contextual" behaviors, both defined below.++- Commands.  A plugin defines zero or more commands, which are keywords users can use in chat (prefixed by a sigil, '@' or '?' by default) to interact with the plugin.++- Contextual behaviors.  Every time a chat message is received that isn't processed as a command, plugins are offered a chance to process and respond to it.++- Callbacks.  Plugins can register callbacks to react to non-chat messages such as nick changes, join/part events, etc.++User code execution+--------------------++Lambdabot provides the ability to execute user-supplied Haskell code.  This is obviously a somewhat risky thing to do.  We use 2 main mechanisms to mitigate this risk:++- Safe Haskell.  The "Safe Haskell" GHC extension tracks usage of features such as `unsafePerformIO` and the FFI (among others) which subvert the type system.  The full details are available in the GHC documentation.  By default, lambdabot only trusts a small set of common libraries.  The user may override this set on the command-line.++- Sandboxing and resource limits.  The `mueval` program implements timeouts and resource limits to keep user-provided code from hogging the system.  Lambdabot uses `mueval` to run code++Monads+------++Lambdabot uses a few different monads/transformers to encapsulate state and provide additional context for various subsystems.  They are:++- LB.  The `LB` monad is the base environment for all operations that depend on or affect the core system.  These are mainly things like loading or unloading plugins, registering servers or callbacks, etc.++- ModuleT.  The `ModuleT` monad transformer is used for all code provided by a plugin.  It provides access to the plugin's name and current state.++- CmdT. The `CmdT` monad transformer is used for implementing commands within modules, and provides access to information such as the name the command was invoked as, the message that triggered the command, and information about that message such as the sender and addressee.+++Configuration system+--------------------++Code in all the monads above has access to the configuration system, which is a typed key-value store that is initialized at startup and thenceforth immutable.  The `getConfig` function provides access to the value associated with any config key.  New keys can be defined using the `config` Template Haskell function - see `Lambdabot.Config` for the interface and `Lambdabot.Config.Core` for some examples.++To set a config value, add a binding to the configuration parameter of `lambdabotMain`.  For example:++    module MyBot where+    +    import Lambdabot.Main+    {- import your plugins here -}+    +    main = lambdabotMain myPlugins +        [ configKey  :=> value+        , anotherKey :=> anotherValue+        ]++Any key not listed will be assigned the default value specified in its original declaration.++Source layout and module heirarchy+----------------------------------++- src/+-- Lambdabot.Compat.*++Modules supporting backward-compatibility with older versions of lambdabot (mostly functions to read old serialization formats)++-- Lambdabot.Config.*++Currently only "Core", this module defines the configuration keys for the lambdabot core system.  Packages providing additional plugins are encouraged to use this namespace (or the module in which they are used, if they prefer) for additional configuration key definitions.  The configuration system is described above.++-- Lambdabot.Plugin.*++As the name suggests, all lambdabot plugins are defined in modules under this namespace.++-- Lambdabot.Util.*++Utility functions for use by lambdabot plugins.  This is not considered a stable public interface; I am actively working on eliminating them in favor of external libraries that provide equivalent functionality.++-- Lambdabot, Lambdabot.*++The core lambdabot system.  Like the Util namespace, these are not especially stable right now.++- main/++Defines the main lambdabot executable, usable either as-is or as a template for a customized executable.+
− Config.hs 
@@ -1,60 +0,0 @@------ | Configuration data for lambdabot----module Config where---- | The 'Config' type provides configurations for lambdabot. It is used---   when lambdabot is started to determine the name of lambdabot, what---   IRC-network lambdabot should join, which channels lambdabot should---   join upon successful connection, etc.----data Config = Config {-        verbose   :: Bool,          -- ^ Should lambdabot be verbose?-        textwidth :: Int,           -- ^ How many columns should we use-        proxy     :: Maybe ([Char], Integer), -- ^ A proxy given as-                                              --   a pair of host and port.--        -- | The 'path' component is a string to the location where the fortune files-        --   are located. On some systems, this is "\/usr\/share\/games\/fortunes", on others-        --   this is "\/usr\/share\/games\/fortune". Alter this to suit your configuration-        fortunePath :: FilePath,--        -- | Path to the top of "\$fptools", used by "\@code"-        fptoolsPath :: FilePath,--        -- | which ghci to use (in "\@type")-        ghci        :: FilePath,-        outputDir   :: FilePath,--        -- | what prefixes to use for commands-        commandPrefixes :: [String],--        -- | what prefixes to use for Haskell evalution-        evalPrefixes :: [String],--        -- | Particular commands we'd like to disable-        -- (to disable whole plugins, remove them from Modules.hs)-        disabledCommands :: [String]-}------- Useful defaults for #haskell.----config :: Config-config = Config {-        verbose         = True,-        textwidth       = 350,-        proxy           = Nothing, -- Just ("www-proxy",3128),--        fortunePath     = "/usr/share/games/fortunes/",-        fptoolsPath     = "/home/dons/fptools",--        ghci            = "ghci",-        outputDir       = "State/",--        commandPrefixes = ["@","?"],-        evalPrefixes    = [">"],--        disabledCommands = ["state"]--   }
− File.hs 
@@ -1,83 +0,0 @@-module File where--import Control.Monad-import System.Directory-import System.FilePath-import Paths_lambdabot (getDataFileName)---- | Constants.-lambdabot, local, state :: FilePath-lambdabot = ".lambdabot"-state = lambdabot </> local-local = "State"--maybeFileExists :: FilePath -> IO (Maybe FilePath)-maybeFileExists path = -    do b <- doesFileExist path-       return $ if b then Just path else Nothing---- | For a given file, look locally under State/. That is, suppose one is--- running out of a Lambdabot darcs repository in /home/cale/lambdabot. Then------ > lookLocally "fact" ~> "/home/cale/lambdabot/State/fact"-lookLocally :: FilePath -> IO (Maybe String)-lookLocally file = maybeFileExists $ local </> file---- | For a given file, look at the home directory. By default, we stash files in--- ~/.lambdabot. So, running Lambdabot normally would let us do:------ > lookHome "fact" ~> "/home/cale/lambdabot/State/fact"------ (Note that for convenience we preserve the "State/foo" address pattern.)-lookHome :: FilePath -> IO (Maybe String)-lookHome f = do home <- getHomeDirectory-                maybeFileExists $ home </> state </> f---- | Do ~/.lambdabot & ~/.lambdabot/State exist?-isHome :: IO Bool-isHome = do home <- getHomeDirectory-            fmap and . mapM (doesDirectoryExist . (home </>)) $ [lambdabot, state]---- | Create ~/.lambdabot and ~/.lambdabot/State-mkdirL :: IO ()-mkdirL = do home <- getHomeDirectory-            mapM_ (createDirectory . (home </>)) $ [lambdabot, state]---- | Ask Cabal for the read-only copy of a file, and copy it into ~/.lambdabot/State.-cpDataToHome :: FilePath -> IO ()-cpDataToHome f = do rofile <- getDataFileName (local </> f)-                    home <- getHomeDirectory-                    -- cp /.../lambdabot-4.foo/State/foo ~/.lambdabot/State/foo-                    copyFile rofile (home </> state </> f)---- | Complicated. If a file exists locally, we return that. If a file exists in--- ~/lambdabot/State, we return that. If neither the file nor ~/lambdabot/State--- exist, we create the directories and then copy the file into it.--- Note that the return type is simple so we can just do a binding and stuff it--- into the conventional functions easily; unfortunately, this removes--- error-checking, as an error is now just \"\".-findFile :: FilePath -> IO String-findFile f = do first <- lookLocally f-                case first of-                  -- With any luck we can exit quickly-                  Just a -> return a-                  Nothing -> do second <- lookHome f-                                case second of-                                  -- OK, we didn't get lucky with local, so-                                  -- hopefully it's in ~/.lambdabot-                                  Just a -> return a-                                  -- Uh oh. We didn't find it locally, nor did we-                                  -- find it in ~/.lambdabot/State. So now we-                                  -- need to make ~/.lambdabot/State and copy it in.-                                  Nothing -> do exists <- isHome-                                                when (not exists) mkdirL-                                                cpDataToHome f-                                                -- With the file copied/created,-                                                -- a second attempt should work.-                                                g <- lookHome f-                                                case g of-                                                  Just a -> return a-                                                  Nothing -> -                                                      do home <- getHomeDirectory -                                                         fail $ "File.findFile: couldn't find file " -                                                                ++ f ++ " in " ++ home </> state
− IRCBase.hs 
@@ -1,141 +0,0 @@------ | The IRC module processes the IRC protocol and provides a nice API for sending---   and recieving IRC messages with an IRC server.----module IRCBase ( IrcMessage(..)-               , privmsg-               , quit-               , timeReply-               , errShowMsg -- TODO: remove-               , user-               , setNick-               ) where--import Message-import Lambdabot.Util (split, breakOnGlue, clean)-import qualified Lambdabot.Util as Util (concatWith)--import Data.Char (chr,isSpace)--import Control.Monad (liftM2)---- | An IRC message is a server, a prefix, a command and a list of parameters.-data IrcMessage-  = IrcMessage {-        msgServer   :: !String,-        msgLBName   :: !String,-        msgPrefix   :: !String,-        msgCommand  :: !String,-        msgParams   :: ![String]-  }-  deriving (Show)--instance Message IrcMessage where-    nick          = IRCBase.nick-    server        = IRCBase.msgServer-    fullName      = IRCBase.fullName-    names         = IRCBase.names-    channels      = IRCBase.channels-    joinChannel   = IRCBase.join-    partChannel   = IRCBase.part-    getTopic      = IRCBase.getTopic-    setTopic      = IRCBase.setTopic-    body          = IRCBase.msgParams-    command       = IRCBase.msgCommand-    lambdabotName = IRCBase.lambdabotName---- | 'mkMessage' creates a new message from a server, a cmd, and a list of parameters.-mkMessage :: String -- ^ Server-          -> String -- ^ Command-          -> [String] -- ^ Parameters-          -> IrcMessage -- ^ Returns: The created message--mkMessage svr cmd params = IrcMessage { msgServer = svr, msgPrefix = "", msgCommand = cmd, msgParams = params,-                                        msgLBName = "urk!<outputmessage>" }---- | 'nick' extracts the nickname involved in a given message.-nick :: IrcMessage -> Nick-nick = liftM2 Nick msgServer (fst . breakOnGlue "!" . msgPrefix)---- | 'fullName' extracts the full user name involved in a given message.-fullName :: IrcMessage -> String-fullName = snd . breakOnGlue "!" . msgPrefix---- | 'channels' extracts the channels a IrcMessage operate on.-channels :: IrcMessage -> [Nick]-channels msg-  = let cstr = head $ msgParams msg-    in map (Nick (msgServer msg)) $-       map (\(x:xs) -> if x == ':' then xs else x:xs) (split "," cstr)-           -- solves what seems to be an inconsistency in the parser---- | 'privmsg' creates a private message to the person designated.-privmsg :: Nick -- ^ Who should recieve the message (nick)-        -> String -- ^ What is the message?-        -> IrcMessage -- ^ Constructed message-privmsg who msg = if action then mk [nName who, ':':(chr 0x1):("ACTION " ++ clean_msg ++ ((chr 0x1):[]))]-                            else mk [nName who, ':' : clean_msg]-    where mk = mkMessage (nTag who) "PRIVMSG"-          cleaned_msg = case concatMap clean msg of-              str@('@':_) -> ' ':str-              str         -> str-          (clean_msg,action) = case cleaned_msg of-              ('/':'m':'e':r) -> (dropWhile isSpace r,True)-              str             -> (str,False)---- | 'setTopic' takes a channel and a topic. It then returns the message---   which sets the channels topic.-setTopic :: Nick -- ^ Channel-         -> String -- ^ Topic-         -> IrcMessage-setTopic chan topic = mkMessage (nTag chan) "TOPIC" [nName chan, ':' : topic]---- | 'getTopic' Returns the topic for a channel, given as a String-getTopic :: Nick -> IrcMessage-getTopic chan = mkMessage (nTag chan) "TOPIC" [nName chan]---- | 'quit' creates a server QUIT message. The input string given is the---   quit message, given to other parties when leaving the network.-quit :: String -> String -> IrcMessage-quit svr msg = mkMessage svr "QUIT" [':' : msg]---- | 'join' creates a join message. String given is the location (channel)---   to join.-join :: Nick -> IrcMessage-join loc = mkMessage (nTag loc) "JOIN" [nName loc]---- | 'part' parts the channel given.-part :: Nick -> IrcMessage-part loc = mkMessage (nTag loc) "PART" [nName loc]---- | 'names' builds a NAMES message from a list of channels.-names :: String -> [String] -> IrcMessage-names svr chans = mkMessage svr "NAMES" [Util.concatWith "," chans]---- | Construct a privmsg from the CTCP TIME notice, to feed up to--- the @localtime-reply plugin, which then passes the output to--- the appropriate client.-timeReply :: IrcMessage -> IrcMessage-timeReply msg    =-   IrcMessage { msgPrefix  = msgPrefix (msg)-              , msgServer  = msgServer (msg)-              , msgLBName  = msgLBName (msg)-              , msgCommand = "PRIVMSG"-              , msgParams  = [head (msgParams msg)-                             ,":@localtime-reply " ++ (nName $ IRCBase.nick msg) ++ ":" ++-                                (init $ drop 7 (last (msgParams msg))) ]-              }---- Only needed for Base.hs-errShowMsg :: IrcMessage -> String-errShowMsg msg = "ERROR> <" ++ msgServer msg ++ (':' : msgPrefix msg) ++-      "> [" ++ msgCommand msg ++ "] " ++ show (msgParams msg)--user :: String -> String -> String -> String -> IrcMessage-user svr nick_ server_ ircname = IRCBase.mkMessage svr "USER" [nick_, "localhost", server_, ircname]--setNick :: Nick -> IrcMessage-setNick nick_ = IRCBase.mkMessage (nTag nick_) "NICK" [nName nick_]--lambdabotName :: IrcMessage -> Nick-lambdabotName msg = Nick (msgServer msg) (msgLBName msg)
− LBState.hs 
@@ -1,139 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--- | Support for the LB (LambdaBot) monad-module LBState (-        -- ** Functions to access the module's state-        readMS, withMS, modifyMS, writeMS,-        accessorMS,--        -- ** Utility functions for modules that need state for each target.-        GlobalPrivate(global), mkGlobalPrivate, withPS, readPS, withGS, readGS,-        writePS, writeGS,--        -- * more LB support-        forkLB, liftLB-  ) where--import Lambdabot-import Lambdabot.Util            (withMWriter, timeout)--import Control.Concurrent (forkIO, readMVar, modifyMVar_, newMVar, MVar, ThreadId)-import Control.Monad.Reader-import Control.Monad.Trans (liftIO)--import Message (Nick)---- withMWriter :: MVar a -> (a -> (a -> IO ()) -> IO b) -> IO b--- | Update the module's private state.--- This is the preferred way of changing the state. The state will be locked--- until the body returns. The function is exception-safe, i.e. even if--- an error occurs or the thread is killed (e.g. because it deadlocked and--- therefore exceeded its time limit), the state from the last write operation--- will be restored. If the writer escapes, calling it will have no observable--- effect.--- @withMS@ is not composable, in the sense that a readMS from within the body--- will cause a dead-lock. However, all other possibilies to access the state--- that came to my mind had even more serious deficiencies such as being prone--- to race conditions or semantic obscurities.-withMS :: (s -> (s -> LB ()) -> LB a) -> ModuleT s LB a-withMS f = do-    ref <- getRef-    lift . lbIO $ \conv -> withMWriter ref $ \x writer ->-        conv $ f x (liftIO . writer)---- | Read the module's private state.-readMS :: ModuleT s LB s-readMS = getRef >>= liftIO . readMVar---- | Produces a with-function. Needs a better name.-accessorMS :: (s -> (t, t -> s)) ->-  (t -> (t -> LB ()) -> LB a) -> ModuleT s LB a-accessorMS decompose f = withMS $ \s writer ->-  let (t,k) = decompose s in f t (writer . k)---- | Modify the module's private state.-modifyMS :: (s -> s) -> ModuleT s LB ()-modifyMS f = getRef >>= liftIO . flip modifyMVar_ (return . f)---- | Write the module's private state. Try to use withMS instead.-writeMS :: s -> ModuleT s LB ()-writeMS (x :: s) = modifyMS . const $ x     -- need to help out 6.5---- | This datatype allows modules to conviently maintain both global---   (i.e. for all clients they're interacting with) and private state.---   It is implemented on top of readMS\/withMS.------ This simple implementation is linear in the number of private states used.-data GlobalPrivate g p = GP {-  global :: !g,-  private :: ![(Nick,MVar (Maybe p))],-  maxSize :: Int-}---- | Creates a @GlobalPrivate@ given the value of the global state. No private---   state for clients will be created.-mkGlobalPrivate :: Int -> g -> GlobalPrivate g p-mkGlobalPrivate ms g = GP {-  global = g,-  private = [],-  maxSize = ms-}---- Needs a better interface. The with-functions are hardly useful.--- | Writes private state. For now, it locks everything.-withPS :: Nick  -- ^ The target-  -> (Maybe p -> (Maybe p -> LB ()) -> LB a)-    -- ^ @Just x@ writes x in the user's private state, @Nothing@ removes it.-  -> ModuleT (GlobalPrivate g p) LB a-withPS who f = do-  mvar <- accessPS return id who-  lift . lbIO $ \conv -> withMWriter mvar $ \x writer ->-      conv $ f x (liftIO . writer)---- | Reads private state.-readPS :: Nick -> ModuleT (GlobalPrivate g p) LB (Maybe p)-readPS = accessPS (liftIO . readMVar) (\_ -> return Nothing)---- | Reads private state, executes one of the actions success and failure--- which take an MVar and an action producing a @Nothing@ MVar, respectively.-accessPS :: (MVar (Maybe p) -> LB a) -> (LB (MVar (Maybe p)) -> LB a) -> Nick-  -> ModuleT (GlobalPrivate g p) LB a-accessPS success failure who = withMS $ \state writer ->-  case lookup who $ private state of-    Just mvar -> do-      let newPrivate = (who,mvar):-            filter ((/=who) . fst) (private state)-      length newPrivate `seq` writer (state { private = newPrivate })-      success mvar-    Nothing -> failure $ do-      mvar <- liftIO $ newMVar Nothing-      let newPrivate = take (maxSize state) $ (who,mvar): private state-      length newPrivate `seq` writer (state { private = newPrivate })-      return mvar---- | Writes global state. Locks everything-withGS :: (g -> (g -> LB ()) -> LB ()) -> ModuleT (GlobalPrivate g p) LB ()-withGS f = withMS $ \state writer ->-  f (global state) $ \g -> writer $ state { global = g }---- | Reads global state.-readGS :: ModuleT (GlobalPrivate g p) LB g-readGS = global `fmap` readMS----- The old interface, as we don't wanna be too fancy right now.-writePS :: Nick -> Maybe p -> ModuleT (GlobalPrivate g p) LB ()-writePS who x = withPS who (\_ writer -> writer x)--writeGS :: g -> ModuleT (GlobalPrivate g p) LB ()-writeGS g = withGS (\_ writer -> writer g)---- | run an IO action in another thread, with a timeout, lifted into LB-forkLB :: LB a -> LB ThreadId-forkLB f = (`liftLB` f) $ \g -> do-            forkIO $ do-                timeout (15 * 1000 * 1000) g-                return ()---- | lift an io transformer into LB-liftLB :: (IO a -> IO b) -> LB a -> LB b-liftLB f = LB . mapReaderT f . runLB -- lbIO (\conv -> f (conv lb))
− LMain.hs 
@@ -1,52 +0,0 @@-module LMain where--import Shared-import Lambdabot-import Message-import IRCBase--import Lambdabot.Util( listToMaybeAll )--import qualified Data.Map as M--import System.Environment--import Data.Maybe-import Control.Monad.State (get, liftIO)--data Args = Args { initcmds   :: [String] }--main' :: Maybe DynLoad -> (LB (), [String]) -> IO ()-main' dyn (loadStaticModules, pl) = do-    x    <- getArgs-    let a = parseArgs x-    case a of-        Just args -> runIrc (fromMaybe ["offline"] $ listToMaybeAll $ initcmds args) loadStaticModules ld pl-        _         -> putStrLn "Usage: lambdabot [-e 'cmd']*"--    where ld = fromMaybe (error "no dynamic loading") dyn-          parseArgs ("-e":cmd:x)       = parseArgs x >>$ \a -> a { initcmds = cmd : initcmds a }-          parseArgs []                 = Just $ Args { initcmds = [] }-          parseArgs _                  = Nothing-          (>>$) = flip fmap-----------------------------------------------------------------------------received :: IrcMessage -> LB ()-received msg = do s   <- get-                  case M.lookup (command msg) (ircCallbacks s) of-                    Just cbs -> allCallbacks (map snd cbs) msg-                    _        -> return ()---- If an error reaches allCallbacks, then all we can sensibly do is--- write it on standard out. Hopefully BaseModule will have caught it already--- if it can see a better place to send it--allCallbacks :: Message a => [a -> LB ()] -> a -> LB ()-allCallbacks [] _ = return ()-allCallbacks (f:fs) msg = do-    handleIrc (liftIO . putStrLn . ("Main: caught (and ignoring) "++). show) (f msg)-    allCallbacks fs msg--------------------------------------------------------------------------
− Lambdabot.hs 
@@ -1,747 +0,0 @@-{-# LANGUAGE CPP, ExistentialQuantification, FlexibleContexts,-  FunctionalDependencies, GeneralizedNewtypeDeriving, MultiParamTypeClasses,-  PatternGuards, RankNTypes, TypeOperators #-}--- | The guts of lambdabot.------ The LB/Lambdabot monad--- Generic server connection,disconnection--- The module typeclass, type and operations on modules-module Lambdabot (-        MODULE(..), Module(..),-        ModuleT, ModuleLB, ModuleUnit, Mode(..),--        IRCRState(..), IRCRWState(..), IRCError(..),--        LB(..), lbIO,--        withModule, withAllModules, getDictKeys,--        getRef, getName, bindModule0, bindModule1, bindModule2,--        send, addServer, remServer, addServer',-        ircPrivmsg, ircPrivmsg', -- not generally used-        ircPrivmsgF,--        ircQuit, ircReconnect,-        ircGetChannels,-        ircSignalConnect, Callback, ircInstallOutputFilter, OutputFilter,-        ircInstallModule, ircUnloadModule,-        flushModuleState,--        ircLoad, ircUnload,--        checkPrivs, checkIgnore, mkCN, handleIrc, catchIrc, runIrc,-  ) where--import File (findFile)--import qualified Message as Msg-import qualified Shared  as S-import qualified IRCBase as IRC (IrcMessage, quit, privmsg)--import Lambdabot.Signals-import Lambdabot.Util-import Lambdabot.Serial--import Prelude hiding           (mod, catch)--import Network                  (withSocketsDo)--import System.Exit-import System.IO-import System.IO.Unsafe--#ifndef mingw32_HOST_OS-import System.Posix.Signals---- n.b comment this out for prof-import System.Posix.Process     ( exitImmediately )-#endif--import Data.Char-import Data.IORef               (newIORef, IORef, readIORef, writeIORef)-import Data.List                (isSuffixOf, inits, tails)-import Data.Maybe               (isJust)-import Data.Map (Map)-import qualified Data.Map as M hiding (Map)-import qualified Data.ByteString.Char8 as P-import Data.ByteString (ByteString)--import Control.Concurrent (myThreadId, newEmptyMVar, newMVar, readMVar, putMVar,-                           takeMVar, threadDelay, MVar, ThreadId)-import Control.OldException-import Control.Monad.Error (MonadError (..))-import Control.Monad.Reader-import Control.Monad.State-import Control.Monad.Trans      ( liftIO )--import GHC.Err--#ifdef mingw32_HOST_OS--- compatability shim-exitImmediately :: ExitCode -> IO a-exitImmediately = exitWith-#endif-------------------------------------------------------------------------------- Lambdabot state------- | Global read-only state.-data IRCRState-  = IRCRState {-        ircMainThread  :: ThreadId,-        ircInitDoneMVar:: MVar (),-        ircQuitMVar    :: MVar ()-        -- ^This is a mildly annoying hack.  In order to prevent the program-        -- from closing immediately, we have to keep the main thread alive, but-        -- the obvious infinite-MVar-wait technique doesn't work - the garbage-        -- collector helpfully notices that the MVar is dead, kills the main-        -- thread (which will never wake up, so why keep it around), thus-        -- terminating the program.  Behold the infinite wisdom that is the-        -- Glasgow FP group.-  }--type Callback = IRC.IrcMessage -> LB ()--type OutputFilter = Msg.Nick -> [String] -> LB [String]---- | Global read\/write state.-data IRCRWState = IRCRWState {-        ircServerMap       :: Map String (String, IRC.IrcMessage -> LB ()),-        ircPrivilegedUsers :: Map Msg.Nick Bool,-        ircIgnoredUsers    :: Map Msg.Nick Bool,--        ircChannels        :: Map ChanName String,-            -- ^ maps channel names to topics--        ircModules         :: Map String ModuleRef,-        ircCallbacks       :: Map String [(String,Callback)],-        ircOutputFilters   :: [(String,OutputFilter)],-            -- ^ Output filters, invoked from right to left--        ircCommands        :: Map String ModuleRef,-        ircPrivCommands    :: [String],-        ircStayConnected   :: !Bool,-        ircDynLoad         :: S.DynLoad,-        ircOnStartupCmds   :: [String],-        ircPlugins         :: [String]-    }---- The virtual chat system.------ The virtual chat system sits between the chat drivers and the rest of--- Lambdabot.  It provides a mapping between the String server "tags" and--- functions which are able to handle sending messages.------ When a message is recieved, the chat module is expected to call--- `LMain.received'.  This is not ideal.--addServer :: String -> (IRC.IrcMessage -> LB ()) -> ModuleT s LB ()-addServer tag sendf = do-    s <- get-    let svrs = ircServerMap s-    name <- getName-    case M.lookup tag svrs of-        Nothing -> put (s { ircServerMap = M.insert tag (name,sendf) svrs})-        Just _ -> fail $ "attempted to create two servers named " ++ tag---- This is a crutch until all the servers are pluginized.-addServer' :: String -> (IRC.IrcMessage -> LB ()) -> LB ()-addServer' tag sendf = do-    s <- get-    let svrs = ircServerMap s-    case M.lookup tag svrs of-        Nothing -> put (s { ircServerMap = M.insert tag ("<core>",sendf) svrs})-        Just _ -> fail $ "attempted to create two servers named " ++ tag--remServer :: String -> LB ()-remServer tag = do-    s <- get-    let svrs = ircServerMap s-    case M.lookup tag svrs of-        Just _ -> do let svrs' = M.delete tag svrs-                     main <- asks ircMainThread-                     when (M.null svrs') $ io $ throwTo main (ErrorCall "all servers detached")-                     put (s { ircServerMap = svrs' })-        Nothing -> fail $ "attempted to delete nonexistent servers named " ++ tag--send :: IRC.IrcMessage -> LB ()-send msg = do-    s <- gets ircServerMap-    case M.lookup (Msg.server msg) s of-        Just (_, sendf) -> sendf msg-        Nothing -> io $ hPutStrLn stderr $ "sending message to bogus server: " ++ show msg--newtype ChanName = ChanName { getCN :: Msg.Nick } -- should be abstract, always lowercase-  deriving (Eq, Ord)--instance Show ChanName where show (ChanName x) = show x---- | only use the "smart constructor":-mkCN :: Msg.Nick -> ChanName-mkCN = ChanName . liftM2 Msg.Nick Msg.nTag (map toLower . Msg.nName)---- --------------------------------------------------------------------------- The LB (LambdaBot) monad------- | The IRC Monad. The reader transformer holds information about the---   connection to the IRC server.------ instances Monad, Functor, MonadIO, MonadState, MonadError---newtype LB a = LB { runLB :: ReaderT (IRCRState,IORef IRCRWState) IO a }-    deriving (Monad,Functor,MonadIO)---- Actually, this isn't a reader anymore-instance MonadReader IRCRState LB where-    ask   = LB $ asks fst-    local = error "You are not supposed to call local"--instance MonadState IRCRWState LB where-    get = LB $ do-        ref <- asks snd-        lift $ readIORef ref-    put x = LB $ do-        ref <- asks snd-        lift $ writeIORef ref x---- And now a MonadError instance to map IRCErrors to MonadError in LB,--- so throwError and catchError "just work"-instance MonadError IRCError LB where-  throwError (IRCRaised e)    = io $ throwIO e-  throwError (SignalCaught e) = io $ evaluate (throwDyn $ SignalException e)-  m `catchError` h = lbIO $ \conv -> (conv m-              `catchDyn` \(SignalException e) -> conv $ h $ SignalCaught e)-              `catch` \e -> conv $ h $ IRCRaised e---- A type for handling both Haskell exceptions and external signals-data IRCError = IRCRaised Exception | SignalCaught Signal--instance Show IRCError where-    show (IRCRaised    e) = show e-    show (SignalCaught s) = show s---- lbIO return :: LB (LB a -> IO a)--- CPS to work around predicativiy of haskell's type system.-lbIO :: ((forall a. LB a -> IO a) -> IO b) -> LB b-lbIO k = LB . ReaderT $ \r -> k (\(LB m) -> m `runReaderT` r)---- | run a computation in the LB monad-evalLB :: LB a -> IRCRState -> IRCRWState -> IO a-evalLB (LB lb) rs rws = do-    ref  <- newIORef rws-    lb `runReaderT` (rs,ref)---- May wish to add more things to the things caught, or restructure things--- a bit. Can't just catch everything - in particular EOFs from the socket--- loops get thrown to this thread and we musn't just ignore them.-handleIrc :: MonadError IRCError m => (IRCError -> m ()) -> m () -> m ()-handleIrc handler m = catchError m handler---- Like handleIrc, but with arguments reversed-catchIrc :: MonadError IRCError m => m () -> (IRCError -> m ()) -> m ()-catchIrc = flip handleIrc-------------------------------------------------------------------------------- Lambdabot modes, networked , or command line----data Mode = Online | Offline deriving Eq---- | The Lambdabot entry point.--- Initialise plugins, connect, and run the bot in the LB monad------ Also, handle any fatal exceptions (such as non-recoverable signals),--- (i.e. print a message and exit). Non-fatal exceptions should be dealt--- with in the mainLoop or further down.-runIrc :: [String] -> LB a -> S.DynLoad -> [String] -> IO ()-runIrc evcmds initialise ld plugins = withSocketsDo $ do-    rost <- initRoState-    r <- try $ evalLB (do withDebug "Initialising plugins" initialise-                          withIrcSignalCatch mainLoop)-                       rost (initState ld plugins evcmds)--    -- clean up and go home-    case r of-        Left er -> do putStrLn "exception:"-                      print er-                      exitWith (ExitFailure 1) -- won't happen.  exitImmediately cleans it all up-        Right _ -> exitWith ExitSuccess------- | Default ro state----initRoState :: IO IRCRState-initRoState = do-    threadmain <- io myThreadId-    quitMVar <- io newEmptyMVar-    initDoneMVar <- io newEmptyMVar--    return $ IRCRState {-                 ircQuitMVar    = quitMVar,-                 ircInitDoneMVar= initDoneMVar,-                 ircMainThread  = threadmain-             }------- | Default rw state----initState :: S.DynLoad -> [String] -> [String] -> IRCRWState-initState ld plugins evcmds = IRCRWState {-        ircPrivilegedUsers = M.singleton (Msg.Nick "offlinerc" "null") True,-        ircIgnoredUsers    = M.empty,-        ircChannels        = M.empty,-        ircModules         = M.empty,-        ircServerMap       = M.empty,-        ircCallbacks       = M.empty,-        ircOutputFilters   = [-            ([],cleanOutput),-            ([],lineify),-            ([],cleanOutput),-        --  ([],reduceIndent),-            ([],checkRecip) ],-        ircCommands        = M.empty,-        ircPrivCommands    = [],-        ircStayConnected   = True,-        ircDynLoad         = ld,-        ircPlugins         = plugins,-        ircOnStartupCmds   = evcmds-    }---- Actually, this isn't a loop anymore.  FIXME: better name.-mainLoop :: LB ()-mainLoop = do--    catchIrc-       (do asks ircInitDoneMVar >>= io . flip putMVar ()-           asks ircQuitMVar >>= io . takeMVar-           fail "don't write to the quitMVar!")-       (\e -> do -- catch anything, print informative message, and clean up-            io $ hPutStrLn stderr $-                       (case e of-                            IRCRaised ex   -> "Exception: " ++ show ex-                            SignalCaught s -> "Signal: " ++ ircSignalMessage s)-        --  withDebug "Running exit handlers"    runExitHandlers-        --  withDebug "Writing persistent state" flushModuleState-            runExitHandlers >> flushModuleState--      -- this kills profiling output:-            io $ exitImmediately (ExitFailure 1))--      --    throwError e)---- | run 'exit' handler on modules-runExitHandlers:: LB ()-runExitHandlers = withAllModules moduleExit >> return ()---- | flush state of modules-flushModuleState :: LB ()-flushModuleState = do-    withAllModules (\m -> getName >>= writeGlobalState m)-    return ()------------------------------------------------------------------------------ | The Module type class.--- Minimal complete definition: @moduleHelp@, @moduleCmds@, and--- either @process@ or @process_@-class Module m s | m -> s where-    -- | If the module wants its state to be saved, this function should-    --   return a Serial.-    ---    --   The default implementation returns Nothing.-    moduleSerialize :: m -> Maybe (Serial s)--    -- | If the module maintains state, this method specifies the default state-    --   (for example in case the state can't be read from a state).-    ---    --   The default implementation returns an error and assumes the state is-    --   never accessed.-    moduleDefState  :: m -> LB s--    -- | Is the module sticky? Sticky modules (as well as static ones) can't be-    --   unloaded. By default, modules are not sticky.-    moduleSticky    :: m -> Bool--    -- | The commands the module listenes to.-    moduleCmds      :: m -> [String]--    -- | This method should return a help string for every command it defines.-    moduleHelp      :: m -> String -> String--    -- | The privileged commands the module listenes to.-    modulePrivs     :: m -> [String]--    -- | Initialize the module. The default implementation does nothing.-    moduleInit      :: m -> ModuleT s LB ()--    -- | Finalize the module. The default implementation does nothing.-    moduleExit      :: m -> ModuleT s LB ()--    -- | Process a command a user sent, the resulting string is draw in-    -- some fashion. If the `process' function doesn't exist, we catch-    -- an exception when we try to call it, and instead call `process_'-    -- which is guaranteed to at least have a default instance.-    -- This magic (well, for Haskell) occurs in Base.hs-    ---    process :: Msg.Message a-        => m                                -- ^ phantom     (required)-        -> a                                -- ^ the message (uneeded by most?)-        -> Msg.Nick                         -- ^ target-        -> String                           -- ^ command-        -> String                           -- ^ the arguments to the command-        -> ModuleLB s                       -- ^ maybe output--    -- | Process contextual input. A plugin that implements 'contextual'-    -- is able to respond to text not part of a normal command.-    contextual :: Msg.Message a-        => m                                -- ^ phantom     (required)-        -> a                                -- ^ the message-        -> Msg.Nick                         -- ^ target-        -> String                           -- ^ the text-        -> ModuleLB s                       -- ^ maybe output--    -- | Like process, but uncommonly used args are ignored-    -- Lambdabot will attempt to run process first, and then fall back-    -- to process_, which in turn has a default instance.-    ---    process_ :: m                           -- ^ phantom-             -> String -> String            -- ^ command, args-             -> ModuleLB s                  -- ^ maybe output--    -- A bytestring version-    ---    fprocess_ :: m                        -- ^ phantom-              -> ByteString -> ByteString -- ^ command, args-              -> ModuleF s                -- ^ maybe output----------------------------------------------------------------------------    contextual _ _ _ _ = return []-    process_ _ _ _     = return []--    moduleHelp m _     = concat (map ('@':) (moduleCmds m))-    modulePrivs _      = []-    moduleCmds      _  = []-    moduleExit _       = return ()-    moduleInit _       = return ()-    moduleSticky _     = False-    moduleSerialize _  = Nothing-    moduleDefState  _  = return $ error "state not initialized"---- | An existential type holding a module, used to represent modules on--- the value level, for manipluation at runtime by the dynamic linker.-data MODULE = forall m s. (Module m s) => MODULE m--data ModuleRef = forall m s. (Module m s) => ModuleRef m (MVar s) String------- | This transformer encodes the additional information a module might---   need to access its name or its state.----newtype ModuleT s m a = ModuleT { moduleT :: ReaderT (MVar s, String) m a }-    deriving (Functor, Monad, MonadTrans, MonadIO, MonadError e, MonadState t)--getRef :: Monad m => ModuleT s m (MVar s)-getRef  = ModuleT $ ask >>= return . fst--getName :: Monad m => ModuleT s m String-getName = ModuleT $ ask >>= return . snd---- | bind an action to the current module so it can be run from the plain---   `LB' monad.-bindModule0 :: ModuleT s LB a -> ModuleT s LB (LB a)-bindModule0 act = bindModule1 (const act) >>= return . ($ ())---- | variant of `bindModule0' for monad actions with one argument-bindModule1 :: (a -> ModuleT s LB b) -> ModuleT s LB (a -> LB b)-bindModule1 act = ModuleT $-    ask >>= \st -> return (\val -> runReaderT (moduleT $ act val) st)---- | variant of `bindModule0' for monad actions with two arguments-bindModule2 :: (a -> b -> ModuleT s LB c) -> ModuleT s LB (a -> b -> LB c)-bindModule2 act = bindModule1 (uncurry act) >>= return . curry---- | A nicer synonym for some ModuleT stuffs-type ModuleLB s = ModuleT s LB [String]---- | And for packed output-type ModuleF  s = ModuleT s LB [ByteString]--type ModuleUnit s = ModuleT s LB ()---- --------------------------------------------------------------------------- Handling global state------- | Peristence: write the global state out-writeGlobalState :: Module m s => m -> String -> ModuleT s LB ()-writeGlobalState mod name = case moduleSerialize mod of-  Nothing  -> return ()-  Just ser -> do-    state <- getRef >>= (io . readMVar) -- readMS-    case serialize ser state of-        Nothing  -> return ()   -- do not write any state-        Just out -> io $ P.writeFile (toFilename name) out---- | Read it in-readGlobalState :: Module m s => m -> String -> IO (Maybe s)-readGlobalState mod name-    | Just ser <- moduleSerialize mod  = do-        state <- Just `fmap` P.readFile (toFilename name) `catch` \_ -> return Nothing-        catch (evaluate $ maybe Nothing (Just $!) (deserialize ser =<< state)) -- Monad Maybe)-              (\e -> do hPutStrLn stderr $ "Error parsing state file for: "-                                        ++ name ++ ": " ++ show e-                        hPutStrLn stderr $ "Try removing: "++ show (toFilename name)-                        return Nothing) -- proceed regardless-    | otherwise = return Nothing---- | helper-toFilename :: String -> String-toFilename = unsafePerformIO . findFile-------------------------------------------------------------------------------- | Register a module in the irc state----ircInstallModule :: MODULE -> String -> LB ()-ircInstallModule (MODULE mod) modname = do-    savedState <- io $ readGlobalState mod modname-    state      <- maybe (moduleDefState mod) return savedState-    ref        <- io $ newMVar state--    let modref = ModuleRef mod ref modname--    flip runReaderT (ref, modname) . moduleT $ do-        moduleInit mod-        let cmds  = moduleCmds mod-            privs = modulePrivs mod--        s <- get-        let modmap = ircModules s-            cmdmap = ircCommands s-        put $ s {-          ircModules = M.insert modname modref modmap,-          ircCommands = addList [ (cmd,modref) | cmd <- cmds++privs ] cmdmap,-          ircPrivCommands = ircPrivCommands s ++ privs-        }-        io $ hPutStr stderr "." >> hFlush stderr------- | Unregister a module's entry in the irc state----ircUnloadModule :: String -> LB ()-ircUnloadModule modname = withModule ircModules modname (error "module not loaded") (\m -> do-    when (moduleSticky m) $ error "module is sticky"-    moduleExit m-    writeGlobalState m modname-    s <- get-    let modmap = ircModules s-        cmdmap = ircCommands s-        cbs    = ircCallbacks s-        svrs   = ircServerMap s-        ofs    = ircOutputFilters s-    put $ s { ircCommands      = M.filter (\(ModuleRef _ _ name) -> name /= modname) cmdmap }-            { ircModules       = M.delete modname modmap }-            { ircCallbacks     = filter ((/=modname) . fst) `fmap` cbs }-            { ircServerMap     = M.filter ((/=modname) . fst) svrs }-            { ircOutputFilters = filter ((/=modname) . fst) ofs }-  )------- | Binding to dynamic loader functions (stored as a bundle in state)--- passed from Boot. DynamicModule goes through here to get at them.----ircLoad :: FilePath -> S.Symbol -> LB (S.Module, a)-ircLoad mod sym = do-    s <- get-    let fn  = S.dynload (ircDynLoad s)-    io $ (fn mod sym)------- | Dynamically unload a module----ircUnload :: FilePath -> LB ()-ircUnload mod = do-    s <- get-    io $ (S.unload (ircDynLoad s)) (S.Module mod)----------------------------------------------------------------------------ircSignalConnect :: String -> Callback -> ModuleT s LB ()-ircSignalConnect str f = do-    s <- get-    let cbs = ircCallbacks s-    name <- getName-    case M.lookup str cbs of -- TODO-        Nothing -> put (s { ircCallbacks = M.insert str [(name,f)]    cbs})-        Just fs -> put (s { ircCallbacks = M.insert str ((name,f):fs) cbs})--ircInstallOutputFilter :: OutputFilter -> ModuleT s LB ()-ircInstallOutputFilter f = do-    name <- getName-    modify $ \s ->-        s { ircOutputFilters = (name, f): ircOutputFilters s }---- | Checks if the given user has admin permissions and excecute the action---   only in this case.-checkPrivs :: IRC.IrcMessage -> LB Bool-checkPrivs msg = gets (isJust . M.lookup (Msg.nick msg) . ircPrivilegedUsers)---- | Checks if the given user is being ignored.---   Privileged users can't be ignored.-checkIgnore :: IRC.IrcMessage -> LB Bool-checkIgnore msg = liftM2 (&&) (liftM not (checkPrivs msg))-                  (gets (isJust . M.lookup (Msg.nick msg) . ircIgnoredUsers))----------------------------------------------------------------------------- Some generic server operations--ircGetChannels :: LB [Msg.Nick]-ircGetChannels = (map getCN . M.keys) `fmap` gets ircChannels---- Send a quit message, settle and wait for the server to drop our--- handle. At which point the main thread gets a closed handle eof--- exceptoin, we clean up and go home-ircQuit :: String -> String -> LB ()-ircQuit svr msg = do-    modify $ \state -> state { ircStayConnected = False }-    send  $ IRC.quit svr msg-    liftIO $ threadDelay 1000-    io $ hPutStrLn stderr "Quit"--ircReconnect :: String -> String -> LB ()-ircReconnect svr msg = do-    send $ IRC.quit svr msg-    liftIO $ threadDelay 1000---- | Send a message to a channel\/user. If the message is too long, the rest---   of it is saved in the (global) more-state.-ircPrivmsg :: Msg.Nick      -- ^ The channel\/user.-           -> String        -- ^ The message.-           -> LB ()--ircPrivmsg who msg = do-    filters   <- gets ircOutputFilters-    sendlines <- foldr (\f -> (=<<) (f who)) ((return . lines) msg) $ map snd filters-    mapM_ (\s -> ircPrivmsg' who (take textwidth s)) (take 10 sendlines)---- A raw send version-ircPrivmsg' :: Msg.Nick -> String -> LB ()-ircPrivmsg' who ""  = ircPrivmsg' who " "-ircPrivmsg' who msg = send $ IRC.privmsg who msg--------------------------------------------------------------------------------------ircPrivmsgF :: Msg.Nick -> ByteString -> LB ()-ircPrivmsgF who s= ircPrivmsg who (P.unpack s) -- TODO--{--rawPrivmsgF :: String -> Maybe ByteString -> LB ()-rawPrivmsgF _   Nothing  = send Nothing-rawPrivmsgF who (Just s) | P.null s  = ircPrivmsg' who (Just " ")-                         | otherwise = send . Just $ IRC.privmsgF who msg--}----------------------------------------------------------------------------- Module handling---- | Interpret an expression in the context of a module.--- Arguments are which map to use (@ircModules@ and @ircCommands@ are--- the only sensible arguments here), the name of the module\/command,--- action for the case that the lookup fails, action if the lookup--- succeeds.----withModule :: (Ord k)-           => (IRCRWState -> Map k ModuleRef)-           -> k-           -> LB a-           -> (forall mod s. Module mod s => mod -> ModuleT s LB a)-           -> LB a--withModule dict modname def f = do-    maybemod <- gets (M.lookup modname . dict)-    case maybemod of-      -- TODO stick this ref stuff in a monad instead. more portable in-      -- the long run.-      Just (ModuleRef m ref name) -> do-          runReaderT (moduleT $ f m) (ref, name)-      _                           -> def---- | Interpret a function in the context of all modules-withAllModules :: (forall mod s. Module mod s => mod -> ModuleT s LB a) -> LB [a]-withAllModules f = do-    mods <- gets $ M.elems . ircModules :: LB [ModuleRef]-    (`mapM` mods) $ \(ModuleRef m ref name) -> do-        runReaderT (moduleT $ f m) (ref, name)--getDictKeys :: (MonadState s m) => (s -> Map k a) -> m [k]-getDictKeys dict = gets (M.keys . dict)------------------------------------------------------------------------------ | Print a debug message, and perform an action-withDebug :: String -> LB a -> LB ()-withDebug s a = do-    io $ hPutStr stderr (s ++ " ...")  >> hFlush stderr-    a-    io $ hPutStrLn stderr " done." >> hFlush stderr--------------------------------------------------------------------------- Output filters--textwidth :: Int-textwidth = 200 -- IRC maximum msg length, minus a bit for safety.---- | For now, this just checks for duplicate empty lines.-cleanOutput :: OutputFilter-cleanOutput _ msg = return $ remDups True msg'-    where-        remDups True  ([]:xs) =    remDups True xs-        remDups False ([]:xs) = []:remDups True xs-        remDups _     (x: xs) = x: remDups False xs-        remDups _     []      = []-        msg' = map dropSpaceEnd msg---- | wrap long lines.-lineify :: OutputFilter-lineify = const (return . mlines . unlines)---- | break into lines-mlines :: String -> [String]-mlines = (mbreak =<<) . lines-    where-        mbreak :: String -> [String]-        mbreak xs-            | null bs   = [as]-            | otherwise = (as++cs) : filter (not . null) (mbreak ds)-            where-                (as,bs) = splitAt (w-n) xs-                breaks  = filter (not . isAlphaNum . last . fst) $ drop 1 $-                                  take n $ zip (inits bs) (tails bs)-                (cs,ds) = last $ (take n bs, drop n bs): breaks-                w = textwidth-                n = 10---- | Don't send any output to alleged bots.-checkRecip :: OutputFilter-checkRecip who msg---  FIXME: this doesn't work with plugin protocols :(---  | who == Config.name Config.config                   = return []-    | "bot" `isSuffixOf` lowerCaseString (Msg.nName who) = return []-    | otherwise                                          = return msg---- | Divide the lines' indent by two-{--reduceIndent :: OutputFilter-reduceIndent _ msg = return $ map redLine msg-    where-        redLine (' ':' ':xs)        = ' ':redLine xs-        redLine xs                  = xs--}
− Main.hs 
@@ -1,26 +0,0 @@------ | Let's go lambdabot!----module Main where--import LMain-import Modules      (modulesInfo)-import Lambdabot--import Data.Maybe-import System.Posix.Signals---- do argument handling-main :: IO ()-main = do-    -- when 'popen' is called on a non-existing executable, SIGPIPE is sent,-    -- causing lambdabot to exit:-    installHandler sigPIPE Ignore Nothing-    main' Nothing modulesInfo---- special online target for ghci use-online :: [String] -> IO ()-online strs = runIrc strs (fst modulesInfo) ld pl-    where-    ld = fromMaybe (error "no dynamic loading") Nothing-    pl = []
− Message.hs 
@@ -1,110 +0,0 @@------ Provides interface to messages, message pipes----module Message(Message(..), Nick(..), showNick, readNick, Pipe, packNick, unpackNick) where--import qualified Data.ByteString.Char8 as P-import Control.Concurrent (Chan)-import Data.Char (toUpper)--import Control.Arrow (first)---- TODO: probably remove "Show a" later-class Show a => Message a where-    -- | extracts the tag of the server involved in a given message-    server      :: a -> String--    -- | extracts the nickname involved in a given message.-    nick        :: a -> Nick--    -- | 'fullName' extracts the full user name involved in a given message.-    fullName    :: a -> String--    -- | 'names' builds a NAMES message from a list of channels.-    names       :: String -> [String] -> a--    -- | 'channels' extracts the channels a Message operate on.-    channels    :: a -> [Nick]--    -- | 'join' creates a join message. String given is the location (channel) to join-    joinChannel :: Nick -> a--    -- | 'part' parts the channel given.-    partChannel :: Nick -> a--    -- | 'getTopic' Returns the topic for a channel, given as a String-    getTopic    :: Nick -> a--    -- | 'setTopic' takes a channel and a topic. It then returns the message-    --   which sets the channels topic.-    setTopic :: Nick -> String -> a--    -- TODO: recheck this. It's usage heavily relies on the fact that message comes from IRC-    body :: a -> [String]--    -- TODO: too IRC-specific-    command :: a -> String--    -- TODO: there must be a better way of handling this ...-    lambdabotName :: a -> Nick---- | The type of nicknames isolated from a message.-data Nick-  = Nick {-        nTag :: !String, -- ^The tag of the server this nick is on-        nName :: !String -- ^The server-specific nickname of this nick-  }---- This definition of canonicalizeName breaks strict RFC rules, but so does--- freenode-canonicalizeName :: String -> String-canonicalizeName = map toUpper--instance Eq Nick where-  (Nick tag name) == (Nick tag2 name2) =-     (canonicalizeName name == canonicalizeName name2) && (tag == tag2)--instance Ord Nick where-  (Nick tag name) <= (Nick tag2 name2) =-     (tag, canonicalizeName name) <= (tag2, canonicalizeName name2)----- Helper functions-upckStr :: String -> String -> Nick-upckStr def str | null ac   = Nick def str-                | otherwise = Nick bc (tail ac)-    where (bc, ac) = break (==':') str--pckStr :: Nick -> String-pckStr nck = nTag nck ++ ':' : nName nck---- | Format a nickname for display.  This will automatically omit the server--- field if it is the same as the server of the provided message.-showNick :: Message a => a -> Nick -> String-showNick msg nick_ | nTag nick_ == server msg = nName nick_-                   | otherwise                = pckStr nick_---- | Parse a nickname received in a message.  If the server field is not--- provided, it defaults to the same as that of the message.-readNick :: Message a => a -> String -> Nick-readNick msg str = upckStr (server msg) str'-        where str' | last str `elem` ":" = init str-                   | otherwise           = str--instance Show Nick where-    show x | nTag x == "freenode" = show $ nName x-           | otherwise            = show $ pckStr x--instance Read Nick where-    readsPrec prec str = map (first (upckStr "freenode")) (readsPrec prec str)---- | Pack a nickname into a ByteString.  Note that the resulting strings are--- not optimally formatted for human consumtion.-packNick :: Nick -> P.ByteString-packNick = P.pack . pckStr---- | Unpack a nickname packed by 'packNick'.-unpackNick :: P.ByteString -> Nick-unpackNick = upckStr "freenode" . P.unpack--type Pipe a = Chan (Maybe a)
− Modules.hs 
@@ -1,117 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Modules (modulesInfo) where--import Plugin-import Data.List (nub)---- to add a new plugin, one must first add a qualified import here, and also--- add a string in the list below-import qualified Plugin.Activity-import qualified Plugin.Babel-import qualified Plugin.Base-import qualified Plugin.BF-import qualified Plugin.Check-import qualified Plugin.Compose-import qualified Plugin.Dice-import qualified Plugin.Dict-import qualified Plugin.Djinn-import qualified Plugin.Dummy-import qualified Plugin.Elite-import qualified Plugin.Eval-import qualified Plugin.Fact-import qualified Plugin.Free-import qualified Plugin.Fresh-import qualified Plugin.FT-import qualified Plugin.Haddock-import qualified Plugin.Help-import qualified Plugin.Hoogle-import qualified Plugin.Instances-import qualified Plugin.IRC-import qualified Plugin.Karma-import qualified Plugin.Localtime-import qualified Plugin.More-import qualified Plugin.OEIS-import qualified Plugin.OfflineRC-import qualified Plugin.Pl-import qualified Plugin.Pointful-import qualified Plugin.Poll-import qualified Plugin.Pretty-import qualified Plugin.Quote-import qualified Plugin.Search---import qualified Plugin.Seen-import qualified Plugin.Slap-import qualified Plugin.Source-import qualified Plugin.Spell-import qualified Plugin.State-import qualified Plugin.System-import qualified Plugin.Tell-import qualified Plugin.Ticker-import qualified Plugin.Todo-import qualified Plugin.Topic-import qualified Plugin.Type-import qualified Plugin.Undo-import qualified Plugin.Unlambda-import qualified Plugin.UnMtl---import qualified Plugin.Url-import qualified Plugin.Version-import qualified Plugin.Vixen-import qualified Plugin.Where--modulesInfo :: (LB (), [String])-modulesInfo = $(modules $ nub-                    -- these must be listed first.  Maybe.  Nobody really-                    -- knows, but better to be safe than sorry.-                    [ "Base"-                    , "State"-                    , "System"-                    , "OfflineRC"--                    -- plugins also go in this list:-                    , "Activity"-                    , "Babel"-                    , "BF"-                    , "Check"-                    , "Compose"-                    , "Dice"-                    , "Dict"-                    , "Djinn"-                    , "Dummy"-                    , "Elite"-                    , "Eval"-                    , "Fact"-                    , "Free"-                    , "Fresh"-                    , "FT"-                    , "Haddock"-                    , "Help"-                    , "Hoogle"-                    , "Instances"-                    , "IRC"-                    , "Karma"-                    , "Localtime"-                    , "More"-                    , "OEIS"-                    , "Pl"-                    , "Pointful"-                    , "Poll"-                    , "Pretty"-                    , "Quote"-                    , "Search"-                    --, "Seen"-                    , "Slap"-                    , "Source"-                    , "Spell"-                    , "Tell"-                    , "Ticker"-                    , "Todo"-                    , "Topic"-                    , "Type"-                    , "Undo"-                    , "Unlambda"-                    , "UnMtl"-                    --, "Url"-                    , "Version"-                    , "Vixen"-                    , "Where"-                    ])
− Modules.hs-boot 
@@ -1,1 +0,0 @@-module Modules where { plugins::[[Char]] }
− NickEq.hs 
@@ -1,49 +0,0 @@------ | Nickname equality subsystem.------ This component is responsible for deciding whether two nicknames--- refer to the same person, for the purposes of @tell et al.  Nickname--- equality must be monadic because it uses mutable state maintained--- by the @link and @unlink commands.------ Also provided is a concept of polynicks (by analogy to polytypes);--- polynicks can refer to an (open) set of nicknames.  For instance '@tell--- *lambdabot Why does X do Y' could tell a message to anyone who has--- identified as a lambdabot maintainer.  A polynick consists of a--- bar-separated list of (nicks or open terms); an open term is like a--- nick but preceded with a star.--module NickEq ( Polynick, nickMatches, readPolynick, showPolynick, lookupMononickMap, mononickToPolynick ) where--import Message( Message, Nick, readNick, showNick )-import Lambdabot-import Lambdabot.Util (concatWith, split)-import Data.Maybe (mapMaybe)--import qualified Data.Map as M--data Polynick = Polynick [Nick] deriving (Eq) -- for now---- |Determine if a nick matches a polynick.  The state is read at the--- point of binding.-nickMatches :: LB (Nick -> Polynick -> Bool)-nickMatches = return m'-    where-      m' nck (Polynick nck2) = nck `elem` nck2---- | Parse a read polynick.-readPolynick :: Message a => a -> String -> Polynick-readPolynick m = Polynick . map (readNick m) . split "|"---- | Format a polynick.-showPolynick :: Message a => a -> Polynick -> String-showPolynick m (Polynick n) = concatWith "|" $ map (showNick m) n---- | Convert a regular mononick into a polynick.-mononickToPolynick :: Nick -> Polynick-mononickToPolynick = Polynick . (:[])---- | Lookup (using a polynick) in a map keyed on mononicks.-lookupMononickMap :: LB (Polynick -> M.Map Nick a -> [(Nick,a)])-lookupMononickMap = return $ look'-    where look' (Polynick ns) m = mapMaybe (\n -> (,) n `fmap` M.lookup n m) ns
− Plugin.hs 
@@ -1,107 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}------- Copyright (c) 2006 Don Stewart - http://www.cse.unsw.edu.au/~dons--- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)------ Syntactic sugar for developing plugins.--- Simplifies import lists, and abstracts over common patterns----module Plugin (-        ios, box, list, ios80, plugin, modules,--        module Lambdabot,-        module LBState,-        module Config,--        module Lambdabot.Util,-        module Lambdabot.Serial,-        module Lambdabot.Process,-        module Lambdabot.MiniHTTP,-        module Lambdabot.Url,-        module Lambdabot.Regex,--        module Data.List,-        module Data.Char,-        module Data.Maybe,-        module Data.Either,-        module System.IO,--        module Control.Monad.Error--    ) where--import Lambdabot-import LBState-import Config--import Lambdabot.Util-import Lambdabot.Serial-import Lambdabot.Process-import Lambdabot.MiniHTTP-import Lambdabot.Url-import Lambdabot.Regex--import Message--import Data.List-import Data.Char-import Data.Maybe-import Data.Either--import System.IO--import Control.Monad.Error-import Control.Monad.Trans--import Codec.Binary.UTF8.String--import Language.Haskell.TH--import Codec.Binary.UTF8.String--import Language.Haskell.TH--import Codec.Binary.UTF8.String--import Language.Haskell.TH---- | convenience, we often want to perform some io, get a string, and box it.-ios  :: (Functor m, MonadIO m) => IO a -> m [a]-ios  = list . io--list :: (Functor m, Monad m) => m a -> m [a]-list = (return `fmap`)--box :: (Functor m, Monad m) => a -> m [a]-box = return . return---- | convenience, similar to ios but also cut output to channel to 80 characters--- usage:  @process _ _ to _ s = ios80 to (plugs s)@-ios80 :: (Functor m, MonadIO m) => Nick -> IO String -> m [String]-ios80 to what = list . io $ what >>= return . lim . encodeString . spaceOut . removeControl . decodeString-    where lim = case nName to of-                    ('#':_) -> abbr 80 -- message to channel: be nice-                    _       -> id      -- private message: get everything-          spaceOut = unlines . map (' ':) . lines-          removeControl = filter (\x -> isSpace x || not (isControl x))-          abbr n s = let (b, t) = splitAt n s in-                     if null t then b else take (n-3) b ++ "..."--plugin :: String -> Q [Dec]-plugin n = sequence [typedec, fundec]- where-    fundec = funD themod [clause [] (normalB ([| MODULE $(conE mod) |]) ) []]-    -- typedec = newtypeD (cxt []) mod [] (normalC mod [strictType notStrict [t|()|]]) []-    typedec = dataD (cxt []) mod [] [normalC mod []] []-    themod = mkName "theModule"-    mod = mkName $ n ++ "Module"--modules :: [String] -> Q Exp-modules xs = [| ($install, $names) |]- where-    names = listE $ map (stringE . map toLower) xs-    install = [| sequence_ $(listE $ map instalify xs) |]-    instalify x = let mod = varE $ mkName $ concat $ ["Plugin.", x, ".theModule"]-                      low = stringE $ map toLower x-                  in [| ircInstallModule $mod $low |]
− Plugin/Activity.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeSynonymInstances #-}--- | Logging an IRC channel..-module Plugin.Activity (theModule) where--import Plugin-import qualified Message as Msg--import Control.Arrow ((&&&))-import Data.Maybe (fromMaybe)-import Control.OldException (evaluate)--import System.Time--$(plugin "Activity")--type ActivityState = [(ClockTime,Msg.Nick)]--instance Module ActivityModule ActivityState where-    moduleHelp _ _              = "activity seconds. Find out where/how much the bot is being used"-    moduleCmds   _              = ["activity"]-    modulePrivs  _              = ["activity-full"]-    moduleDefState _            = return []-    moduleInit   _              = bindModule2 activityFilter >>=-                                      ircInstallOutputFilter-    process      _ msg _ cmd rest = do-        TOD secs ps <- io getClockTime-        let cutoff = TOD (secs - (fromMaybe 90 $ readM rest)) ps-        users <- (map (obscure . snd) . takeWhile ((> cutoff) . fst)) `fmap` readMS-        let agg_users = reverse . sort . map (length &&& head) . group . sort $ users-        let fmt_agg = concatWith " " . (:) (show (length users) ++ "*total") .-                      map (\(n,u) -> show n ++ "*" ++ Msg.showNick msg u) $ agg_users-        return [fmt_agg]-      where obscure nm | cmd == "activity-full" || isPrefixOf "#" (Msg.nName nm) = nm-                       | otherwise = Msg.readNick msg "private"--activityFilter :: Msg.Nick -> [String] -> ModuleLB ActivityState-activityFilter target lns = do io $ evaluate $ foldr seq () $ map (foldr seq ()) $ lns-                               withMS $ \ st wr -> do-                                 now <- io getClockTime-                                 wr (map (const (now,target)) lns ++ st)-                               return lns
− Plugin/BF.hs 
@@ -1,36 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}--- Copyright (c) 2006 Jason Dagit - http://www.codersbase.com/--- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)---- | A plugin for the Haskell interpreter for the brainf*ck language--- http://www.muppetlabs.com/~breadbox/bf/-module Plugin.BF (theModule) where--import Plugin--$(plugin "BF")--instance Module BFModule () where-    moduleCmds   _     = ["bf"]-    moduleHelp _ _     = "bf <expr>. Evaluate a brainf*ck expression"-    process _ _ to _ s = ios80 to (bf s)--binary :: String-binary = "bf"--bf :: String -> IO String-bf src = run binary src scrub-  where scrub = unlines . take 6 . map (' ':) . filter (not.null) . map cleanit . lines------- Clean up output----cleanit :: String -> String-cleanit s | terminated `matches'`    s = "Terminated\n"-          | otherwise                  = filter printable s-    where terminated = regex' "waitForProc"-          -- the printable ascii chars are in the range [32 .. 126]-          -- according to wikipedia:-          -- http://en.wikipedia.org/wiki/ASCII#ASCII_printable_characters-          printable x = 31 < ord x && ord x < 127-
− Plugin/Babel.hs 
@@ -1,132 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}--- Copyright (c) 2004 Simon Winwood - http://www.cse.unsw.edu.au/~sjw--- Copyright (c) 2004-6 Don Stewart - http://www.cse.unsw.edu.au/~dons--- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)---- | A translator module for lambdabot, a binding to babelfish-module Plugin.Babel where--import Plugin-import qualified Text.Regex as R--$(plugin "Babel")--instance Module BabelModule () where-    moduleCmds _   = ["babel"]-    process_   _ _ = lift . babel-    moduleHelp _ _ = unlines ["babel <lang1> <lang2> <phrase>."-                             ,"Translate a phrase in lang1 to lang2."-                             ,"Language is an element of" ++ showClean supportedLangs]------- The @babel command.------      * translate a phrase---      * translate last 'i' lines of history buffer---      * translate a line of history indexed by a regex------ TODO add range/context. i.e. !f-3 or 5-4----babel :: String -> LB [String]-babel s = do-    let cmd = split2 ' ' 3 s-    msg <- babel' cmd-    let msg' = map ("  " ++) msg-    return [unlines msg']---- help msg-babel' :: (MonadIO m) => [String] -> m [String]-babel' ["help"]      = return $ ["usage: babel lang lang phrase"]-babel' ["languages"] = return $ [show shortLangs]-babel' [f,t,i]       = do p <- liftIO $ babelFish f t i ; return [p]-babel' _             = return ["bzzt."]----------------------------------------------------------------------------babelFishURL :: [Char]-babelFishURL = "http://babelfish.altavista.com/babelfish/tr"--supportedLangs :: [([Char], [Char])]-supportedLangs =-    [("german", "de")-    ,("greek", "el")-    ,("english", "en")-    ,("spanish", "es")-    ,("french", "fr")-    ,("italian", "it")-    ,("dutch", "nl")-    ,("portuguese", "pt")---   ("japanese", "ja")---   ("korean", "ko")---   ("russian", "ru")---   ("chinese-simp", "zh")---   ("chinese-trad", "zt")-     ]--shortLangs :: [[Char]]-shortLangs = ["de","el","en","es","fr","it","ja","ko","nl","pt","ru","zh","zt"]--type URIVars = [(String, String)]--constantVars :: URIVars-constantVars =-    [("doit", "done"),-     ("intl", "1"),-     ("tt", "urltext")]--justEither :: a -> Maybe b -> Either a b-justEither a Nothing = Left a-justEither _ (Just v) = Right v--langVars :: String -> String -> URIVars -> Either String URIVars-langVars inLang outLang vars =-    lookupLang inLang >>= \ins ->-        lookupLang outLang >>= \outs ->-            Right (("lp", ins ++ "_" ++ outs) : vars)-    where-    lookupLang lang | length lang == 2 && lang `elem` shortLangs = Right lang-    lookupLang lang = justEither ("Language " ++ lang ++ " not supported")-                                 (lookup (map toLower lang) supportedLangs)--mkBody :: String -> String -> String -> Either String String-mkBody inLang outLang string-    = mapconcat mkString "&" vars-    where-    vars = langVars inLang outLang (("urltext", string) : constantVars)-    mkString (var, val) = var ++ "=" ++ (urlEncode val)-    mapconcat :: (a -> String) -> String -> Either String [a] -> Either String String-    mapconcat _ _ (Left s) = Left s-    mapconcat f m (Right l) = Right $ concat (intersperse m (map f l))--getBabel :: [String] -> String-getBabel lins =  cleanLine (concat (intersperse " " region))-    where-    region = hd ++ [(head tl)]-    (hd, tl) = span (\x -> (not (matches' reEnd x)))-                    (dropWhile (\x -> (not (matches' reStart x))) lins)--    cleanLine x = maybe "can't parse this language" head $ R.matchRegex reLine x--    reLine  = regex' ".*padding:10px[^>]*>(.*)</div>.*"-    reStart = regex' ".*padding:10px[^>]*>"-    reEnd   = regex' "</div>"--babelFish :: String -> String -> String -> IO String-babelFish inLang outLang string = do-    body <- either (\s -> error ("Error: " ++ s))-                   (\body -> return body) (mkBody inLang outLang string)-    lins <- readPage (proxy config) uri (mkPost uri body) body-    return (getBabel lins)-    where-    uri = (fromJust $ parseURI babelFishURL)------------------------------------------------------------------        {--        -- totally unrelated :}-        process _ _ src "timein.hs" s =-          if s == "help"-            then ircPrivmsg src "  http://www.timeanddate.com"-            else do (o,_,_) <- liftIO $ popen "timein.hs" [s] Nothing-                    ircPrivmsg src $ "  " ++ o-        -}
− Plugin/Base.hs 
@@ -1,346 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}--- | Lambdabot base module. Controls message send and receive-module Plugin.Base (theModule) where--import Plugin--import IRCBase (IrcMessage, timeReply, errShowMsg)--- import Message (getTopic, nick, joinChannel, body, fullName, channels)-import Message (getTopic, nick, server, body, Nick(..), lambdabotName, showNick, readNick)--import qualified Data.Map as M   (insert, delete)--import Control.Monad.State  (MonadState(..), when, gets)--import Control.OldException (Exception(NoMethodError))--import qualified Data.ByteString.Char8 as P-import qualified Text.Regex as R---- valid command prefixes-commands :: [String]-commands  = commandPrefixes config--$(plugin "Base")--type BaseState = GlobalPrivate () ()-type Base a = ModuleT BaseState LB a--instance Module BaseModule BaseState where-    moduleDefState  _ = return $ mkGlobalPrivate 20 ()-    moduleInit _ = do-             ircSignalConnect "PING"    doPING-             bindModule1 doNOTICE >>= ircSignalConnect "NOTICE"-             ircSignalConnect "PART"    doPART-             ircSignalConnect "JOIN"    doJOIN-             ircSignalConnect "NICK"    doNICK-             ircSignalConnect "MODE"    doMODE-             ircSignalConnect "TOPIC"   doTOPIC-             ircSignalConnect "QUIT"    doQUIT-             bindModule1 doPRIVMSG >>= ircSignalConnect "PRIVMSG"-             ircSignalConnect "001"     doRPL_WELCOME--          {- ircSignalConnect "002"     doRPL_YOURHOST-             ircSignalConnect "003"     doRPL_CREATED-             ircSignalConnect "004"     doRPL_MYINFO -}--             ircSignalConnect "005"     doRPL_BOUNCE--          {- ircSignalConnect "250"     doRPL_STATSCONN-             ircSignalConnect "251"     doRPL_LUSERCLIENT-             ircSignalConnect "252"     doRPL_LUSEROP-             ircSignalConnect "253"     doRPL_LUSERUNKNOWN-             ircSignalConnect "254"     doRPL_LUSERCHANNELS-             ircSignalConnect "255"     doRPL_LUSERME-             ircSignalConnect "265"     doRPL_LOCALUSERS-             ircSignalConnect "266"     doRPL_GLOBALUSERS -}--             ircSignalConnect "332"     doRPL_TOPIC--          {- ircSignalConnect "353"     doRPL_NAMRELY-             ircSignalConnect "366"     doRPL_ENDOFNAMES-             ircSignalConnect "372"     doRPL_MOTD-             ircSignalConnect "375"     doRPL_MOTDSTART-             ircSignalConnect "376"     doRPL_ENDOFMOTD -}--doIGNORE :: Callback-doIGNORE msg = debugStrLn $ show msg- --   = debugStrLn $ "IGNORING> <" ++ msgPrefix msg ++---      "> [" ++ msgCommand msg ++ "] " ++ show (body msg)---doPING :: Callback-doPING msg-    = debugStrLn $ errShowMsg msg---- If this is a "TIME" then we need to pass it over to the localtime plugin--- otherwise, dump it to stdout-doNOTICE :: IrcMessage -> Base ()-doNOTICE msg =-  if isCTCPTimeReply-     then do-        -- bind implicit params to Localtime module. boo on implict params :/-  --    withModule ircModules-  --               "Localtime"-  --               (error "Plugin/Base: no Localtime plugin? So I can't handle CTCP time messges")-  --               (\_ -> doPRIVMSG (timeReply msg))--          -- need to say which module to run the privmsg in--          doPRIVMSG (timeReply msg)--     else debugStrLn $ "NOTICE: " ++ show (body msg)-    where-      isCTCPTimeReply = ":\SOHTIME" `isPrefixOf` (last (body msg))--doJOIN :: Callback-doJOIN msg | lambdabotName msg /= nick msg = doIGNORE msg-           | otherwise-  = do s <- get-       put (s { ircChannels = M.insert  (mkCN loc) "[currently unknown]" (ircChannels s)}) -- the empty topic causes problems-       send $ getTopic loc -- initialize topic-   where (_, aloc) = breakOnGlue ":" (head (body msg))-         loc       = case aloc of-                        [] -> Nick "freenode" "weird#"-                        _  -> Nick (server msg) (tail aloc)--doPART :: Callback-doPART msg-  = when (lambdabotName msg == nick msg) $ do-        let loc = Nick (server msg) (head (body msg))-        s <- get-        put (s { ircChannels = M.delete (mkCN loc) (ircChannels s) })--doNICK :: Callback-doNICK msg-  = doIGNORE msg--doMODE :: Callback-doMODE msg-  = doIGNORE msg---doTOPIC :: Callback-doTOPIC msg-    = do let loc = Nick (server msg) ((head (body msg)))-         s <- get-         put (s { ircChannels = M.insert (mkCN loc) (tail $ head $ tail $ body msg) (ircChannels s)})--doRPL_WELCOME :: Callback-doRPL_WELCOME = doIGNORE--doQUIT :: Callback-doQUIT msg = doIGNORE msg--doRPL_BOUNCE :: Callback-doRPL_BOUNCE _msg = debugStrLn "BOUNCE!"--doRPL_TOPIC :: Callback-doRPL_TOPIC msg -- nearly the same as doTOPIC but has our nick on the front of body-    = do let loc = Nick (server msg) ((body msg) !! 1)-         s <- get-         put (s { ircChannels = M.insert (mkCN loc) (tail $ last $ body msg) (ircChannels s) })--doPRIVMSG :: IrcMessage -> Base ()-doPRIVMSG msg = do---  now <- io getClockTime---  io $ appendFile (File.findFile "log") $ ppr now-    ignored <- lift $ checkIgnore msg-    if ignored-      then lift $ doIGNORE msg-      else mapM_ (doPRIVMSG' (lambdabotName msg) msg) targets-  where-    alltargets = head (body msg)-    targets = map (readNick msg) $ split "," alltargets---  where---    ppr now = concat [ timeStamp now, " ", "<", (nick msg), " ", (fullName msg), " #"---                     , (concat . intersperse ","  $ channels msg) ,  "> "---                     , (tail . concat . intersperse " " . tail) (body msg), "\n"]------- | What does the bot respond to?----doPRIVMSG' :: Nick -> IrcMessage -> Nick -> Base ()-doPRIVMSG' myname msg target-  | myname == target-    = let (cmd, params) = breakOnGlue " " text-      in doPersonalMsg cmd (dropWhile (== ' ') params)--  | flip any ":," $ \c -> (showNick msg myname ++ [c]) `isPrefixOf` text-    = let Just wholeCmd = maybeCommand (showNick msg myname) text-          (cmd, params) = breakOnGlue " " wholeCmd-      in doPublicMsg cmd (dropWhile (==' ') params)--  | (commands `arePrefixesOf` text)-  && length text > 1-  && (text !! 1 /= ' ') -- elem of prefixes-  && (not (commands `arePrefixesOf` [text !! 1]) ||-      (length text > 2 && text !! 2 == ' ')) -- ignore @@ prefix, but not the @@ command itself-    = let (cmd, params) = breakOnGlue " " (dropWhile (==' ') text)-      in doPublicMsg cmd (dropWhile (==' ') params)--  | otherwise =  doContextualMsg text--  where-    text = tail (head (tail (body msg)))-    who = nick msg--    doPersonalMsg s r-        | commands `arePrefixesOf` s        = doMsg (tail s) r who-        | s `elem` (evalPrefixes config)    = doMsg "run"    r who-        | otherwise                         = (lift $ doIGNORE msg)--    doPublicMsg s r-        | commands `arePrefixesOf` s        = doMsg (tail s) r target-        | (evalPrefixes config) `arePrefixesWithSpaceOf` s = doMsg "run" r target -- TODO-        | otherwise                         = (lift $ doIGNORE msg)--    ---    -- normal commands.-    ---    -- check privledges, do any spell correction, dispatch, handling-    -- possible timeouts.-    ---    -- todo, refactor-    ---    doMsg cmd rest towhere = do-        let ircmsg = ircPrivmsg towhere-        allcmds <- getDictKeys ircCommands-        let ms      = filter (isPrefixOf cmd) allcmds-        case ms of-            [s] -> docmd s                  -- a unique prefix-            _ | cmd `elem` ms -> docmd cmd  -- correct command (usual case)-            _ | otherwise     -> case closests cmd allcmds of-                  (n,[s]) | n < e ,  ms == [] -> docmd s -- unique edit match-                  (n,ss)  | n < e || ms /= []            -- some possibilities-                          -> lift . ircmsg $ "Maybe you meant: "++showClean(nub(ms++ss))-                  _ -> docmd cmd         -- no prefix, edit distance too far-        where-            e = 3   -- edit distance cut off. Seems reasonable for small words--            fcmd  = P.pack cmd      -- TODO-            frest = P.pack rest--            docmd cmd' = do-              act <- bindModule0 . withPS towhere $ \_ _ -> do-                withModule ircCommands cmd'   -- Important.-                    (ircPrivmsg towhere "Unknown command, try @list")-                    (\m -> do-                        name'   <- getName-                        privs   <- gets ircPrivCommands-                        let illegal = disabledCommands config-                        ok      <- liftM2 (||) (return $ cmd' `notElem` (privs ++ illegal))-                                               (lift $ checkPrivs msg)-                        if not ok-                          then lift $ ircPrivmsg towhere "Not enough privileges"-                          else catchIrc--                            (do mstrs <- catchError-                                 (Right `fmap` fprocess_ m fcmd frest)-                                 (\ex -> case (ex :: IRCError) of -- dispatch-                                   (IRCRaised (NoMethodError _)) -> catchError-                                        (Left `fmap` process m msg towhere cmd' rest)-                                        (\ey -> case (ey :: IRCError) of -- dispatch-                                            (IRCRaised (NoMethodError _)) ->-                                                Left `fmap` process_ m cmd' rest-                                            _ -> throwError ey)-                                   _ -> throwError ex)--                                -- send off our strings/bytestrings-                                case mstrs of-                                    Right ps -> lift $ mapM_ (ircPrivmsgF towhere) ps--                                    Left  ms -> lift $ mapM_ (ircPrivmsg towhere) ms)--                            (lift . ircPrivmsg towhere .-                                (("Plugin `" ++ name' ++ "' failed with: ") ++) . show))-              lift $ act-    ---    -- contextual messages are all input that isn't an explicit command.-    -- they're passed to all modules (todo, sounds inefficient) for-    -- scanning, and any that implement 'contextual' will reply.-    ---    -- we try to run the contextual functions from all modules, on every-    -- non-command. better hope this is efficient.-    ---    -- Note how we catch any plugin errors here, rather than letting-    -- them bubble back up to the mainloop-    ---    doContextualMsg r = lift $ do-        withAllModules ( \m -> do-            act <- bindModule0 ( do-                            ms <- contextual m msg target r-                            lift $ mapM_ (ircPrivmsg target) ms-                   )-            name' <- getName-            lift $ catchIrc act (debugStrLn . (name' ++) .-                (" module failed in contextual handler: " ++) . show)-            )-        return ()----------------------------------------------------------------------------maybeCommand :: String -> String -> Maybe String-maybeCommand nm text = case R.matchRegexAll re text of-      Nothing -> Nothing-      Just (_, _, cmd, _) -> Just cmd-    where re = regex' (nm ++ "[.:,]*[[:space:]]*")------- And stuff we don't care about-----{--doRPL_YOURHOST :: Callback-doRPL_YOURHOST _msg = return ()--doRPL_CREATED :: Callback-doRPL_CREATED _msg = return ()--doRPL_MYINFO :: Callback-doRPL_MYINFO _msg = return ()--doRPL_STATSCONN :: Callback-doRPL_STATSCONN _msg = return ()--doRPL_LUSERCLIENT :: Callback-doRPL_LUSERCLIENT _msg = return ()--doRPL_LUSEROP :: Callback-doRPL_LUSEROP _msg = return ()--doRPL_LUSERUNKNOWN :: Callback-doRPL_LUSERUNKNOWN _msg = return ()--doRPL_LUSERCHANNELS :: Callback-doRPL_LUSERCHANNELS _msg = return ()--doRPL_LUSERME :: Callback-doRPL_LUSERME _msg = return ()--doRPL_LOCALUSERS :: Callback-doRPL_LOCALUSERS _msg = return ()--doRPL_GLOBALUSERS :: Callback-doRPL_GLOBALUSERS _msg = return ()--doUNKNOWN :: Callback-doUNKNOWN msg-    = debugStrLn $ "UNKNOWN> <" ++ msgPrefix msg ++-      "> [" ++ msgCommand msg ++ "] " ++ show (body msg)--doRPL_NAMREPLY :: Callback-doRPL_NAMREPLY _msg = return ()--doRPL_ENDOFNAMES :: Callback-doRPL_ENDOFNAMES _msg = return ()--doRPL_MOTD :: Callback-doRPL_MOTD _msg = return ()--doRPL_MOTDSTART :: Callback-doRPL_MOTDSTART _msg = return ()--doRPL_ENDOFMOTD :: Callback-doRPL_ENDOFMOTD _msg = return ()--}
− Plugin/Check.hs 
@@ -1,91 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, PatternGuards #-}--- Copyright (c) 6 DonStewart - http://www.cse.unsw.edu.au/~dons--- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)---- | Test a property with QuickCheck-module Plugin.Check where--import File (findFile)-import Plugin-import Lambdabot.Parser--import qualified Text.Regex as R-import Codec.Binary.UTF8.String (decodeString)--$(plugin "Check")--instance Module CheckModule () where-    moduleCmds   _     = ["check"]-    moduleHelp _ _     = "check <expr>\nYou have QuickCheck and 3 seconds. Prove something."-    process _ _ to _ s = ios80 to (check s)--binary :: String-binary = "mueval"--check :: String -> IO String-check src = do-    -- first, verify the source is actually a Haskell 98 expression, to-    -- avoid code injection bugs.-    case parseExpr (decodeString src) of-        Left  e -> return e-        Right _ -> do-            l <- findFile "L.hs"-            (out,err,_) <- popen binary ["--loadfile=", l, "-XExtendedDefaultRules", "-e", "myquickcheck $ " ++ src] Nothing-            case (out,err) of-                ([],[]) -> return "Terminated\n"-                _       -> do-                    let o = munge out-                        e = munge err-                    return $ case () of {_-                        | null o && null e -> "Terminated\n"-                        | null o           -> " " ++ e-                        | otherwise        -> " " ++ o-                    }--munge :: String -> String-munge = expandTab . dropWhile (=='\n') . dropNL . clean_---- Clean up check's output-clean_ :: String -> String-clean_ s|  no_io      `matches'`    s = "No IO allowed\n"-        |  terminated `matches'`    s = "Terminated\n"-        |  hput       `matches'`    s = "Terminated\n"-        |  stack_o_f  `matches'`    s = "Stack overflow\n"-        |  loop       `matches'`    s = "Loop\n"-        |  undef      `matches'`    s = "Undefined\n"-        |  type_sig   `matches'`    s = "Add a type signature\n"--        | Just (_,m,_,_) <- ambiguous  `R.matchRegexAll` s = m-        | Just (_,_,b,_) <- inaninst   `R.matchRegexAll` s = clean_ b-        | Just (_,_,b,_) <- irc        `R.matchRegexAll` s = clean_ b-        | Just (_,m,_,_) <- nomatch    `R.matchRegexAll` s = m-        | Just (_,m,_,_) <- notinscope `R.matchRegexAll` s = m-        | Just (_,m,_,_) <- hsplugins  `R.matchRegexAll`  s = m-        | Just (a,_,_,_) <- columnnum  `R.matchRegexAll`  s = a-        | Just (a,_,_,_) <- extraargs  `R.matchRegexAll`  s = a-        | Just (_,_,b,_) <- filename'  `R.matchRegexAll`  s = clean_ b-        | Just (a,_,b,_) <- filename   `R.matchRegexAll`  s = a ++ clean_ b-        | Just (a,_,b,_) <- filepath   `R.matchRegexAll`   s = a ++ clean_ b-        | Just (a,_,b,_) <- runplugs   `R.matchRegexAll`  s = a ++ clean_ b-        | otherwise      = s-    where-        -- s/<[^>]*>:[^:]: //-        type_sig   = regex' "add a type signature that fixes these type"-        no_io      = regex' "No instance for \\(Show \\(IO"-        terminated = regex' "waitForProc"-        stack_o_f  = regex' "Stack space overflow"-        loop       = regex' "runplugs: <<loop>>"-        irc        = regex' "\n*<irc>:[^:]*:[^:]*:\n*"-        filename   = regex' "\n*<[^>]*>:[^:]*:\\?[^:]*:\\?\n* *"-        filename'  = regex' "/tmp/.*\\.hs[^\n]*\n"-        filepath   = regex' "\n*/[^\\.]*.hs:[^:]*:\n* *"-        undef      = regex' "Prelude.undefined"-        ambiguous  = regex' "Ambiguous type variable `a\' in the constraints"-        runplugs   = regex' "runplugs: "-        notinscope = regex' "Variable not in scope:[^\n]*"-        hsplugins  = regex' "Compiled, but didn't create object"-        extraargs  = regex' "[ \t\n]*In the [^ ]* argument"-        columnnum  = regex' " at <[^\\.]*\\.[^\\.]*>:[^ ]*"-        nomatch    = regex' "Couldn't match[^\n]*\n"-        inaninst   = regex' "^[ \t]*In a.*$"-        hput       = regex' "<stdout>: hPutStr"
− Plugin/Code.hs 
@@ -1,80 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}------ Copyright (c) 2005-6 Don Stewart - http://www.cse.unsw.edu.au/~dons--- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)------ grab a random line of code from a directory full of .hs code-----module Plugin.Code where--import Plugin-import Text.Regex--$(plugin "Code")--instance Module CodeModule [FilePath] where--  moduleDefState _ = io $ getSourceFiles $-        fptoolsPath config </> "libraries" </> "base"--  moduleHelp _ _ = "code. Print random line of code from $fptools"-  moduleCmds   _ = ["code"]--  process_ _ "code" _ = do-        fs <- readMS-        (file,line) <- liftIO $ do-                    f    <- stdGetRandItem fs-                    h    <- openFile f ReadMode-                    s    <- hGetContents h-                    l    <- getRandSrcOf (lines s) 1000 -- number of times to try-                    hClose h-                    return (f, (dropSpace . expandTab $ l))--        -- dump raw output-        return [basename file ++ ": " ++ line]------- work out our list of potential source files--- evil!------ Going to be expensive at startup, no?----getSourceFiles :: FilePath -> IO [FilePath]-getSourceFiles d = do-        (o,_,_) <- popen "/usr/bin/find" [d,"-name","*.hs","-o","-name","*.lhs"] Nothing-        return (lines o)---- give up:-getRandSrcOf :: [String] -> Int -> IO String-getRandSrcOf s 0 | s == []   = return []-                 | otherwise = return $ head s---- otherwise get a random src line-getRandSrcOf ss n = do-        s <- stdGetRandItem ss-        case () of {_-                | Just _ <- comment `matchRegex` s -> getRandSrcOf ss (n-1)-                | Just _ <- ws      `matchRegex` s -> getRandSrcOf ss (n-1)-                | Just _ <- nl      `matchRegex` s -> getRandSrcOf ss (n-1)-                | Just _ <- pragma  `matchRegex` s -> getRandSrcOf ss (n-1)-                | Just _ <- imports `matchRegex` s -> getRandSrcOf ss (n-1)-                | Just _ <- wheres  `matchRegex` s -> getRandSrcOf ss (n-1)-                | Just _ <- mods    `matchRegex` s -> getRandSrcOf ss (n-1)-                | Just _ <- nested  `matchRegex` s -> getRandSrcOf ss (n-1)-                | Just _ <- cpp     `matchRegex` s -> getRandSrcOf ss (n-1)-                | Just _ <- cpp'    `matchRegex` s -> getRandSrcOf ss (n-1)-                | length s < 30                    -> getRandSrcOf ss (n-1)-                | otherwise                        -> return s -- got it-        }-        where comment = mkRegex "--"-              nested  = mkRegex "{"-              pragma  = mkRegex "OPTION"-              cpp     = mkRegex "#if"-              cpp'    = mkRegex "#include"-              ws      = mkRegex "^ "	-- line *must* start with an identifer-              nl      = mkRegex "\n"-              imports = mkRegex "^import"-              wheres  = mkRegex "^ *where"-              mods    = mkRegex "module"-
− Plugin/Compose.hs 
@@ -1,142 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, PatternGuards #-}--- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons--- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)---- Another progressive plugin. Compose two (for now) plugins transparently--- A sort of mini interpreter. Could do with some more thinking.-module Plugin.Compose (theModule) where--import Plugin-import Message--import Control.Monad.State-import Control.Arrow (first)-import Control.OldException (Exception(NoMethodError))--$(plugin "Compose")--instance Module ComposeModule () where-    moduleCmds _   = [".", "compose", "@", "?"]-    moduleHelp _ c = unlines $-                       if c `elem` ["@","?"]-                        then [c++" [args]."-                             ,c++" executes plugin invocations in its arguments, parentheses can be used."-                             ," The commands are right associative."-                             ," For example:    "++c++" "++c++"pl "++c++"undo code"-                             ," is the same as: "++c++" ("++c++"pl ("++c++"undo code))"]-                        else [". <cmd1> <cmd2> [args]."-                             ,". [or compose] is the composition of two plugins"-                             ," The following semantics are used: . f g xs == g xs >>= f"]--    process    _ a b c args-        | c `elem` ["@","?"] = lift $ evalBracket (a,b) args--    process    _ a b _ args = lift $ case split " " args of-        (f:g:xs) -> do-            f' <- lookupP (a,b) f-            g' <- lookupP (a,b) g-            compose f' g' (concat $ intersperse " " xs)--        _ -> return ["Not enough arguments to @."]----- | Compose two plugin functions-compose :: (String -> LB [String]) -> (String -> LB [String]) -> (String -> LB [String])-compose f g xs = g xs >>= f . unlines----------------------------------------------------------------------------- | Lookup the `process' method we're after, and apply it to the dummy args--- Fall back to process_ if there's no process.----lookupP :: Message a => (a, Nick) -> String -> LB (String -> LB [String])-lookupP (a,b) cmd = withModule ircCommands cmd-    (error $ "Unknown command: " ++ show cmd)-    (\m -> do-        privs <- gets ircPrivCommands -- no priv commands can be composed-        when (cmd `elem` privs) $ error "Privledged commands cannot be composed"-        bindModule1 $ \str -> catchError-                    (process m a b cmd str)-                    (\ex -> case (ex :: IRCError) of-                                (IRCRaised (NoMethodError _)) -> process_ m cmd str-                                _ -> throwError ex))------------------------------------------------------------------------------- | More interesting composition/evaluation--- @@ @f x y (@g y z)-evalBracket :: Message a => (a, Nick) -> String -> LB [String]-evalBracket a args = liftM (map addSpace . concat') $ mapM (evalExpr a) $ fst $ parseBracket 0 True args- where concat' ([x]:[y]:xs) = concat' ([x++y]:xs)-       concat' xs           = concat xs--       addSpace :: String -> String-       addSpace (' ':xs) = ' ':xs-       addSpace xs       = ' ':xs--evalExpr :: Message a => (a, Nick) -> Expr -> LB [String]-evalExpr _ (Arg s) = return [s]-evalExpr a (Command c args) = do-     args' <- mapM (evalExpr a) args-     let arg = concat $ concat $ map (intersperse " ") args'-     cmd <- lookupP a c-     cmd arg----------------------------------------------------------------------------data Expr = Command String [Expr]-          | Arg String-    deriving Show---- | Parse a command invocation that can contain parentheses---   The Int indicates how many brackets must be closed to end the current argument, or 0---   The Bool indicates if this is a valid location for a character constant-parseBracket :: Int -> Bool -> String -> ([Expr],String)-parseBracket 0 _ []       = ([],[])-parseBracket _ _ []       = error "Missing ')' in nested command"-parseBracket 1 _ (')':xs) = ([],xs)-parseBracket n _ (')':xs) | n > 0-                          = first (addArg ")") $ parseBracket (n-1) True xs-parseBracket n _ ('(':xs) | Just ys <- isCommand xs       -- (@cmd arg arg)-                          = parseCommand n ys-parseBracket n _ ('(':xs) | n > 0-                          = first (addArg "(") $ parseBracket (n+1) True xs-parseBracket n _ xs       | Just ('(':ys) <- isCommand xs -- @(cmd arg arg)-                          = parseCommand n ys-parseBracket n _ xs       | Just ys <- isCommand xs       -- @cmd arg arg-                          = parseInlineCommand n ys-parseBracket n c (x:xs)   | x `elem` "\"'" && (c || x /= '\'')-                          = let (str, ys) = parseString x xs-                                (rest,zs) = parseBracket n True ys-                            in  (addArg (x:str) rest, zs)-parseBracket n c (x:xs)   = first (addArg [x])-                          $ parseBracket n (not (isAlphaNum x) && (c || x /= '\'')) xs--parseCommand, parseInlineCommand :: Int -> String -> ([Expr],String)-parseCommand n xs = let (cmd, ys) = break (`elem` " )") xs-                        (args,zs) = parseBracket 1 True (dropWhile (==' ') ys)-                        (rest,ws) = parseBracket n True zs-                    in  (Command cmd args:rest, ws)--parseInlineCommand n xs = let (cmd, ys) = break (`elem` " )") xs-                              (rest,zs) = parseBracket n True (dropWhile (==' ') ys)-                          in  (Command cmd rest:[], zs)--parseString :: Char -> String -> (String, String)-parseString _     []          = ([],[])-parseString delim ('\\':x:xs) = first (\ys -> '\\':x:ys) (parseString delim xs)-parseString delim (x:xs)-  | delim == x                = ([x],xs)-  | otherwise                 = first (x:) (parseString delim xs)----- | Does xs start with a command prefix?-isCommand :: String -> Maybe String-isCommand xs = msum $ map dropPrefix (commandPrefixes config)- where dropPrefix p-          | p `isPrefixOf` xs = Just $ drop (length p) xs-          | otherwise         = Nothing--addArg :: String -> [Expr] -> [Expr]-addArg s (Arg a:es) = Arg (s++a):es-addArg s es         = Arg s     :es
− Plugin/DarcsPatchWatch.hs 
@@ -1,294 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}---- Copyright (c) 2005 Stefan Wehr (http://www.stefanwehr.de)--- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)---- | Watch darcs patches arriving...-module Plugin.DarcsPatchWatch (theModule) where--import Plugin--import qualified Data.ByteString.Char8 as P-import Prelude hiding ( catch )--import Control.Concurrent (forkIO, killThread, modifyMVar_, readMVar, threadDelay, MVar, ThreadId)-import Control.OldException-import Control.Monad       ( when )--import System.Directory-import System.Time-import Message--$(plugin "DarcsPatchWatch")-------- Configuration variables-----debugFlag :: Bool-debugFlag = False--maxNumberOfRepos :: Int-maxNumberOfRepos = 20--announceTarget :: Nick-announceTarget = Nick {-  nTag  = "freenode",-  nName = "#haskell"-  }--inventoryFile :: String-inventoryFile = "_darcs/inventory"---- in seconds-checkInterval :: Int-checkInterval = 30--darcsCmd :: String-darcsCmd = "darcs"------- The repository data type------- Repositories is a list of Repo's-type Repos = [Repo]---- A repository has a location, a time where it was last (known to be)--- announced and a number of lines for the last announcement.-data Repo = Repo { repo_location     :: FilePath-                 , repo_lastAnnounced :: Maybe CalendarTime-                 , repo_nlinesAtLastAnnouncement :: Int }-            deriving (Eq,Ord,Show,Read)---- | 'showRepo' takes a repository, repo, to a String for pretty printing.-showRepo :: Repo -> String-showRepo repo =-    "{Repository " ++ show (repo_location repo) ++ ", last announcement: " ++-    (case repo_lastAnnounced repo of-       Nothing -> "unknown"-       Just ct -> formatTime ct) ++ "}"---- | 'showRepos' is the logical lifting of showRepo to to list types.-showRepos :: Repos -> String-showRepos [] = "{no repositories defined}"-showRepos l = '{' : ((concat . intersperse ", " . map showRepo) l ++ "}")------- The state of the plugin------- A darcs repository watcher state.-data DarcsPatchWatchState = DarcsPatchWatchState-                          { dpw_threadId  :: Maybe ThreadId-                          , dpw_repos     :: Repos }---- DPW is our monadic state transformer.-type DPW a = ModuleT DarcsPatchWatchState LB a---- Serialize and unserialize DarcsPatchWatch state.-stateSerial :: Serial DarcsPatchWatchState-stateSerial = Serial ser deSer-    where ser (DarcsPatchWatchState _ repos) = Just . P.pack $ show repos-          deSer s =-              do repos <- readM (P.unpack s)-                 return $ (DarcsPatchWatchState-                           { dpw_threadId = Nothing-                           , dpw_repos = repos })--getRepos :: DPW Repos-getRepos = dpw_repos `fmap` readMS---- | 'withRepos' operates on the current state of the repos with a---   given function.-withRepos :: (Repos -> (Repos -> LB ()) -> LB a) -- ^ Function to apply-          -> DPW a--- template haskell?-withRepos = accessorMS $ \s -> (dpw_repos s, \t -> s { dpw_repos = t })--------- The plugin itself-----instance Module DarcsPatchWatchModule DarcsPatchWatchState where--    moduleCmds  _ = ["repos", "repo-add", "repo-del"]--    moduleHelp    _ s = case s of-        "repos"        -> "repos. List all registered darcs repositories"-        "repo-add"     -> "repo-add <path>. Add a repository"-        "repo-del"     -> "repo-del <path>. Delete a repository"-        _              -> "Watch darcs repositories. Provides: repos, repo-add, repo-del"--    moduleSerialize _ = Just stateSerial-    moduleDefState  _ = return (DarcsPatchWatchState Nothing [])-    moduleInit      _ = do-      tid <- watchRepos -- must return thread ID.-      modifyMS (\s -> s { dpw_threadId = Just tid })--    moduleExit      _ =-        do s <- readMS-           case dpw_threadId s of-             Nothing  -> return ()-             Just tid -> io (killThread tid)--    process_ _ cmd rest = case cmd of-                         "repos"       -> printRepos rest-                         "repo-add"    -> addRepo rest-                         "repo-del"    -> delRepo rest-------- Configuration commands----printRepos :: String -> DPW [String]-printRepos [] = getRepos >>= return . (:[]) . showRepos-printRepos _  = error "@todo given arguments, try @todo-add or @list todo"--addRepo :: String -> DPW [String]-addRepo rest | null (dropSpace rest) = return ["argument required"]-addRepo rest = do-   x <- lift $ mkRepo rest-   case x of-     Right r -> withRepos $ \repos setRepos -> case () of {_-            | length repos >= maxNumberOfRepos ->-                return ["maximum number of repositories reached!"]-            | r `elem` repos ->-                return ["cannot add already existing repository " ++ showRepo r]-            | otherwise ->-                do setRepos (r:repos)-                   return ["repository " ++ showRepo r ++ " added"]-            }--     Left s  -> return ["cannot add invalid repository: " ++ s]--delRepo :: String -> DPW [String]-delRepo rest | null (dropSpace rest) = return ["argument required"]-delRepo rest = do-   x <- lift $ mkRepo rest-   case x of-     Left s -> return ["cannot delete invalid repository: " ++ s]-     Right r -> withRepos $ \repos setRepos -> case findRepo r repos of-                 Nothing ->-                   return ["no repository registered with path " ++ repo_location r]-                 Just realRepo ->-                     do setRepos (delete realRepo repos)-                        return ["repository " ++ showRepo realRepo ++ " deleted"]--    where-      cmpRepos r1 r2    = repo_location r1 == repo_location r2-      findRepo _ []     = Nothing-      findRepo x (y:ys) = if cmpRepos x y then Just y else findRepo x ys--mkRepo :: String -> LB (Either String Repo)-mkRepo pref_ =-    do x <- io $ do let pth  = mkInventoryPath pref_-                        pref = dropSpace pref_-                    perms <- getPermissions pth-                    return (Right (pref, perms))-                      `catch` (\e -> return $ Left (show e))-       case x of-         Left e -> return $ Left e-         Right (pref, perms)-             | readable perms -> return $ Right $ Repo pref Nothing 0-             | otherwise ->-                 return $ Left ("repository's inventory file not readable")-------- The heart of the plugin: watching darcs repositories-----watchRepos :: DPW ThreadId-watchRepos = do-      ref <- getRef-      lift . forkForeverLB $ helper ref-    where sleepTime :: Int  -- in milliseconds-          sleepTime = checkInterval * 1000 * 1000-          helper    :: MVar DarcsPatchWatchState -> LB () -- !-          helper ref = do-              repos <- io . liftM dpw_repos . readMVar $ ref-              debug ("checking darcs repositories " ++ showRepos repos)-              repos_ <- mapM checkRepo repos-              io $ modifyMVar_ ref (\s -> return s{dpw_repos = repos_})-              io $ threadDelay sleepTime-              helper ref-          -- | run an IO action in another thread, with a timeout, lifted into LB-          forkForeverLB :: LB a -> LB ThreadId-          forkForeverLB f = (`liftLB` f) $ \g -> do-                      forkIO $ do-                          g-                          return ()----- actually work out if we need to send a message----checkRepo :: Repo -> LB Repo-checkRepo r = do-       (output, errput) <- io $ runDarcs (repo_location r)-       nlines <--         if not (null errput)-            then do info ("\ndarcs failed: " ++ errput)-                    return (repo_nlinesAtLastAnnouncement r)-            else do let olines = lines output-                        lastN = repo_nlinesAtLastAnnouncement r-                        new = take (length olines - lastN) olines-                    when (not (null new)) $-                        send' $ mkMsg (repo_location r) (parseDarcsMsg (unlines new))-                    return (length olines)--       now <- io getClockTime-       ct <- io $ toCalendarTime now-       return $ r { repo_nlinesAtLastAnnouncement = nlines-                  , repo_lastAnnounced = Just ct }-    where-       send' = ircPrivmsg announceTarget--mkMsg :: String -> (String,String,Integer) -> String-mkMsg r (who,msg,0) = "[" ++ basename r ++ ":" ++ who ++ "] " ++ msg-mkMsg r (who,msg,n) = (mkMsg r (who,msg,0)) ++ " (and "++show n++" more)"--runDarcs :: FilePath -> IO (String, String)-runDarcs loc = do-        (output, errput, _) <- popen darcsCmd ["changes", "--repo=" ++ loc] Nothing-        when (not (null errput)) $ info errput-        return (output, errput)---- Extract the committer, and commit msg from the darcs msg-parseDarcsMsg :: String -> (String,String,Integer)-parseDarcsMsg s =-    let (_,rest)   = breakOnGlue "  " s -- two spaces-        (who,msg') = breakOnGlue "\n" rest-        (msg,n)    = countRest (drop 1 msg')-        who'       = if '@' `elem` who then fst (breakOnGlue "@" who) else who-    in (dropSpace who', drop 2 (dropSpace msg),n)-    where-        countRest  t = let (m,r) = breakOnGlue "\n" t in (m, countRest' r)--        countRest' []               = 0-        countRest' (' ':'*':' ':cs) = 1 + countRest' cs-        countRest' (_:cs)           = countRest' cs------- Helpers-----mkInventoryPath :: String -> FilePath-mkInventoryPath prefix =-    let pref = dropSpace prefix-        in joinPath pref inventoryFile--debug :: MonadIO m => String -> m ()-debug s = if debugFlag-             then io (putStrLn ("[DarcsPatchWatch] " ++ s))-             else return ()--info :: MonadIO m => String -> m ()-info s = io $ putStrLn ("[DarcsPatchWatch] " ++ s)--formatTime :: CalendarTime -> String-formatTime = calendarTimeToString-
− Plugin/Dice.hs 
@@ -1,63 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}--- | This module is for throwing dice for e.g. RPGs. (\@dice 3d6+2)---- Copyright Einar Karttunen <ekarttun@cs.helsinki.fi> 2005-04-06.-module Plugin.Dice (theModule) where--import Plugin--import Control.Monad                    (replicateM,foldM)-import System.Random                    (randomRIO)-import Text.ParserCombinators.Parsec--$(plugin "Dice")--instance Module DiceModule () where-    moduleCmds   _  = ["dice"]-    moduleHelp _ _  = "dice <expr>. Throw random dice. <expr> is of the form 3d6+2."-    process_ _ _ xs = ios (dice xs)--dice :: String -> IO String-dice str = case parse expr "dice" (filter (not.isSpace) str) of-            Left err  -> return . trimError $ err-            Right e   -> do res <- eval e-                            return (brk 30 str++" => "++brk 45 (show res))-           where-            brk n s | length s <= n = s-                    | otherwise     = take (n-3) s ++ "..."-            trimError = concat . intersperse ": " . tail . lines . show--eval :: [(Integer, Integer)] -> IO Integer-eval = foldM ef 0-    where ef acc (v,1) = return (acc+v)-          ef acc (n,d) = if n > 100-                            then do x <- ndRandomIO-                                    let e = n*(d+1)`div`2-                                        e' = fromIntegral (n*(d+1)`mod`2)/2-                                        v = fromIntegral (d*d-1)/12-                                        x' = e' + x * sqrt (fromIntegral n * v)-                                    return (acc + e + round x')-                            else do ls <- replicateM (fromIntegral n)-                                                     (randomRIO (1,d))-                                    return (acc + sum ls)---- | get a normally distributed random number-ndRandomIO :: IO Double-ndRandomIO = do r   <- randomRIO (0, 1)-                phi <- randomRIO (0, 2*pi)-                let r' = sqrt (-2 * log r)-                return (r' * sin phi)--expr :: CharParser st [(Integer, Integer)]-expr = do res <- primExp `sepBy1` (char '+')-          eof <?> "end"-          return res--primExp :: CharParser st (Integer, Integer)-primExp = do v <- number-             d <- option 1 (char 'd' >> number)-             return (v,d)--number :: CharParser st Integer-number = read `fmap` many1 digit <?> "number"-
− Plugin/Dict.hs 
@@ -1,121 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, PatternGuards #-}--- | DICT (RFC 2229) Lookup Module for lambdabot IRC robot.--- Tom Moertel <tom@moertel.com>-module Plugin.Dict (theModule) where--import Plugin-import qualified Plugin.Dict.DictLookup as Dict--$(plugin "Dict")---- | This is the module handler.  Here we process commands from users.--instance Module DictModule () where-    moduleHelp _ _ = getHelp []-    moduleCmds _   = "dict" : "dict-help" : dictNames--    process_ _ "dict"      _    = return [quickHelp]-    process_ _ "dict-help" rest = return [getHelp (words rest)]-    process_ _ cmd         rest = do-        let s = parseTerms rest-        results <- mapM doLookup s-        return $ case results of-            [] -> []-            _  -> [concat results]-      where-        doLookup w = io $ do-            result <- lookupFn w-            return $ either ("Error: " ++) id result--        lookupFn = uncurry Dict.simpleDictLookup . fst $-                   fromJust (lookup cmd dictTable)---- | Configuration.--dictTable :: [(String, ((Dict.QueryConfig, String), String))]-dictTable =-    -- @command   ((server  , database),    description)-    [ ("all-dicts",((dict_org, "*")       , "Query all databases on dict.org"))-    , ("elements", ((dict_org, "elements"), "Elements database"))-    , ("web1913" , ((dict_org, "web1913"),-          "Webster's Revised Unabridged Dictionary (1913)"))-    , ("wn"      , ((dict_org, "wn"),       "WordNet (r) 1.7"))-    , ("gazetteer",((dict_org, "gazetteer"),"U.S. Gazetteer (1990)"))-    , ("jargon"  , ((dict_org, "jargon"),   "Jargon File"))-    , ("foldoc"  , ((dict_org, "foldoc"),-          "The Free On-line Dictionary of Computing"))-    , ("easton"  , ((dict_org, "easton"),   "Easton's 1897 Bible Dictionary"))-    , ("hitchcock",((dict_org, "hitchcock"),-          "Hitchcock's Bible Names Dictionary (late 1800's)"))-    , ("devils"  , ((dict_org, "devils"),   "The Devil's Dictionary"))-    , ("world02" , ((dict_org, "world02"),  "CIA World Factbook 2002"))-    , ("vera"    , ((dict_org, "vera"),-           "V.E.R.A.: Virtual Entity of Relevant Acronyms"))---  , ("prelude" , ((moertel_com, "prelude"), "Haskell Standard Prelude"))-    , ("lojban"  , ((lojban_org, "lojban"), "Search lojban.org"))-    ]-    where-    dict_org    = Dict.QC "dict.org" 2628---  moertel_com = Dict.QC "dict.moertel.com" 2628-    lojban_org  = Dict.QC "lojban.org" 2628--dictNames :: [String]-dictNames = sort (map fst dictTable)----- | Print out help.--quickHelp :: String-quickHelp = unlines [ "Supported dictionary-lookup commands:"-                    , "  " ++ concatWith " " dictNames-                    , "Use \"dict-help [cmd...]\" for more."-                    ]--getHelp :: [String] -> String-getHelp []    = "I perform dictionary lookups via the following "-              ++ show (length dictNames) ++ " commands:\n"-              ++ (getHelp dictNames)--getHelp dicts = unlines . map gH $ dicts-    where-    gH dict | Just (_, descr) <- lookup dict dictTable-            = pad dict ++ " " ++ descr--            | otherwise-            = "There is no dictionary database '" ++ dict ++ "'."--    pad xs = take padWidth (xs ++ " " ++ repeat '.')-    padWidth = maximum (map length dictNames) + 4----- | Break a string into dictionary-query terms, handling quoting and--- escaping along the way.  (This is ugly, and I don't particularly--- like it.)  Given a string like the following, we want to do the--- right thing, which is to break it into five query strings:------     firefly "c'est la vie" 'pound cake' 'rock n\' roll' et\ al------     (1) firefly---     (2) "c'est la vie"---     (3) 'pound cake'---     (4) 'rock n\' roll'---     (5) et\ al--parseTerms :: String -> [String]-parseTerms = pW . words-    where-    pW []  = []-    pW (w@(f:_):ws)-        | f `elem` "'\"" = concatWith " " qws : pW ws'-        | last w == '\\' = let (w':rest) = pW ws in concatWith " " [w, w'] : rest-        | otherwise      = w : pW ws-        where-        (qws, ws') = case break isCloseQuotedWord (w:ws) of-            (qws', [])    -> (init qws' ++ [last qws' ++ [f]], [])-            (qw, w':rest) -> (qw ++ [w'], rest)-        isCloseQuotedWord xs = case reverse xs of-            x:y:_ -> f == x && y /= '\\' -- quote doesn't count if escaped-            x:_   -> f == x-            _     -> False-    pW _ = error "DictModule: parseTerms: can't parse"-
− Plugin/Dict/DictLookup.hs 
@@ -1,99 +0,0 @@------ | DICT (RFC 2229) Lookup --- Tom Moertel <tom@moertel.com>--- ---Here's how you might write a program to query the Jargon database for---the definition of "hacker" and then print the result:------ >  main = doJargonLookup "hacker" >>= putStr--- >--- >  doJargonLookup :: String -> IO String--- >  doJargonLookup query = do--- >      result <- simpleDictLookup (QC "dict.org" 2628) "jargon" query --- >      return $ case result of--- >          Left errorResult -> "ERROR: " ++ errorResult--- >          Right dictResult -> dictResult--- >----module Plugin.Dict.DictLookup ( simpleDictLookup, QueryConfig(..), LookupResult) where--import Data.List-import System.IO-import Control.OldException (handle)-import Network--data QueryConfig    = QC { host :: String, port :: Int }-type DictConnection = Handle-data DictCommand    = Quit | Define DictName String-type DictName       = String -- dict-db name | "!" 1st match | "*" all matches-type LookupResult   = Either String String -- Left <error> | Right <result>--simpleDictLookup :: QueryConfig -> DictName -> String -> IO LookupResult-simpleDictLookup config dictnm query =-    handle (\e -> (return $ Left (show e))) $ do-        conn <- openDictConnection config-        result <- queryDict conn dictnm query-        closeDictConnection conn-        return result--openDictConnection :: QueryConfig -> IO DictConnection-openDictConnection config = do-    hDictServer <- connectTo (host config) (mkPortNumber $ port config)-    hSetBuffering hDictServer LineBuffering-    readResponseLine hDictServer -- ignore response-    return hDictServer-    where-    mkPortNumber = PortNumber . fromIntegral--closeDictConnection :: DictConnection -> IO ()-closeDictConnection conn = do-    sendCommand conn Quit-    readResponseLine conn -- ignore response-    hClose conn--{--queryAllDicts :: DictConnection -> String -> IO LookupResult-queryAllDicts = flip queryDict "*"--}--queryDict :: DictConnection -> DictName -> String -> IO LookupResult-queryDict conn dictnm query = do-    sendCommand conn (Define dictnm query)-    response <- readResponseLine conn-    case response of-        '1':'5':_     -> readDefinition >>= return . formatDefinition-        '5':'5':'2':_ -> return $ Right ("No match for \"" ++ query ++ "\".\n")-        '5':_         -> return $ Left response -- error response-        _             -> return $ Left ("Bogus response: " ++ response)-            -    where--    readDefinition = do-        line <- readResponseLine conn-        case line of-            '2':'5':'0':_ -> return []-            _             -> readDefinition >>= return . (line:)--    formatDefinition = Right . unlines . concatMap formater--    formater ('1':'5':'1':rest) = ["", "***" ++ rest]-    formater "."                = []-    formater line               = [line]---readResponseLine :: DictConnection -> IO String-readResponseLine conn = do-    line <- hGetLine conn-    return (filter (/='\r') line)--sendCommand :: DictConnection -> DictCommand -> IO ()-sendCommand conn cmd =-    hSendLine conn $ case cmd of-        Quit -> "QUIT"-        Define db target -> join " " ["DEFINE", db, target]--join :: [a] -> [[a]] -> [a]-join = (concat.) . intersperse--hSendLine :: Handle -> String -> IO ()-hSendLine h line = hPutStr h (line ++ "\r\n")
− Plugin/Djinn.hs 
@@ -1,154 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}--- Copyright (c) 2005 Donald Bruce Stewart - http://www.cse.unsw.edu.au/~dons--- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)---- Written: Mon Dec 12 10:16:56 EST 2005---- | A binding to Djinn.-module Plugin.Djinn (theModule) where--import Plugin-import Data.Char-import Data.List-import Data.Maybe--import qualified Text.Regex as R--$(plugin "Djinn")---- | We can accumulate an interesting environment-type DjinnEnv = ([Decl] {- prelude -}, [Decl])-type Decl = String--instance Module DjinnModule DjinnEnv where--        moduleHelp _ s = case s of-            "djinn"     -> "djinn <type>.\nGenerates Haskell code from a type.\n" ++-                           "http://darcs.augustsson.net/Darcs/Djinn"-            "djinn-add" -> "djinn-add <expr>.\nDefine a new function type or type synonym"-            "djinn-del" -> "djinn-del <ident>.\nRemove a symbol from the environment"-            "djinn-clr" -> "djinn-clr.\nReset the djinn environment"-            "djinn-env" -> "djinn-env.\nShow the current djinn environment"-            "djinn-names" -> "djinn-names.\nShow the current djinn environment, compactly."-            "djinn-ver" -> "djinn-ver.\nShow current djinn version"--        moduleCmds      _ = ["djinn"-                            ,"djinn-add"-                            ,"djinn-del"-                            ,"djinn-env"-                            ,"djinn-names"-                            ,"djinn-clr"-                            ,"djinn-ver"]--        moduleSerialize _ = Nothing -- Just listSerial--        -- this means djinn better be visible at boot time-        moduleDefState  _ = do-                st <- io $ getDjinnEnv ([],[]) -- get the prelude-                return (either (const []) snd{-!-} st, [])--        -- rule out attempts to do IO, if these get into the env,-        -- they'll be executed by djinn-        process_ _ _ s | cmd  `matches'` s = end-          where end  = return ["Invalid command"]-                cmd  = regex' "^ *:"--        -- Normal commands-        process_ _ "djinn" s = do-                (_,env) <- readMS-                e       <- io $ djinn env $ ":set +sorted" <$> "f ?" <+> dropForall s-                return $ either id (parse . lines) e-            where-              dropForall t-                  | Just (_, _, x, _) <- R.matchRegexAll re t = x-                  | otherwise = t-              re = regex' "^forall [[:alnum:][:space:]]+\\."-              parse :: [String] -> [String]-              parse x = if length x < 2-                        then ["No output from Djinn; installed?"]-                        else tail x--        -- Augment environment. Have it checked by djinn.-        process_ _ "djinn-add"  s = do-            (p,st)  <- readMS-            est     <- io $ getDjinnEnv $ (p, dropSpace s : st)-            case est of-                Left e     -> return [head e]-                Right st'' -> modifyMS (const st'') >> return []--        -- Display the environment-        process_ _ "djinn-env"  _ = do-            (prelude,st) <- readMS-            return $ prelude ++ st--        -- Display the environment's names (quarter-baked)-        process_ _ "djinn-names"  _ = do-            (prelude,st) <- readMS-            let names = concat $ intersperse " " $ concatMap extractNames $ prelude ++ st-            return [names]-          where extractNames = filter (isUpper . head) . unfoldr (\x -> case x of _:_ -> listToMaybe (lex x); _ -> Nothing)--        -- Reset the env-        process_ _ "djinn-clr" _ = modifyMS (flip (,) [] . fst) >> return []--        -- Remove sym from environment. We let djinn do the hard work of-        -- looking up the symbols.-        process_ _ "djinn-del" s =  do-            (_,env) <- readMS-            eenv <- io $ djinn env $ ":delete" <+> dropSpace s <$> ":environment"-            case eenv of-                Left e     -> return [head e]-                Right env' -> do-                    modifyMS $ \(prel,_) ->-                        (prel,filter (\p -> p `notElem` prel) . nub . lines $ env')-                    return []--        -- Version number-        process_ _ "djinn-ver"  _ = do-            (out,_,_) <- io $ popen binary [] (Just ":q")-            let v = dropNL . clean_ . drop 18 . head . lines $ out-            return [v]------------------------------------------------------------------------------ | Should be built inplace by the build system-binary :: String-binary = "djinn"---- | Extract the default environment-getDjinnEnv :: DjinnEnv -> IO (Either [String] DjinnEnv)-getDjinnEnv (prel,env') = do-    env <- djinn env' ":environment"-    case env of-        Left e  -> return $ Left e-        Right o -> do let new = filter (\p -> p `notElem` prel) . nub .  lines $ o-                      return $ Right (prel, new)---- | Call the binary:--djinn :: [Decl] -> String -> IO (Either [String] String)-djinn env' src = do-    let env = concat . intersperse "\n" $ env'-    (out,_,_) <- popen binary [] (Just (env <$> src <$> ":q"))-    let safeInit [] = []-        safeInit xs = init xs-        o = dropNL . clean_ . unlines . safeInit . drop 2 . lines $ out-    return $ case () of {_-        | failed `matches'` o ||-          unify  `matches'` o ||-          err    `matches'` o -> Left (lines o)-        | otherwise                          -> Right o-    }-    where-        failed = regex' "Cannot parse command"-        unify  = regex' "cannot be realized"-        err = regex' "^Error:"------- Clean up djinn output----clean_ :: String -> String-clean_ s | Just (a,_,b,_) <- prompt `R.matchRegexAll` s = a ++ clean_ b-         | otherwise      = s-    where prompt = regex' "Djinn>[^\n]*\n"-
− Plugin/Dummy.hs 
@@ -1,120 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}--- | Simple template module--- Contains many constant bot commands.-module Plugin.Dummy (theModule) where--import Plugin--import Plugin.Dummy.DocAssocs (docAssocs)--import qualified Data.Map as M-import qualified Data.ByteString.Char8 as P--$(plugin "Dummy")--instance Module DummyModule () where--  moduleCmds   _ = "eval" : "choose" : map fst dummylst--  moduleHelp _ s = case s of-        "dummy"       -> "dummy. Print a string constant"-        "bug"         -> "bug. Submit a bug to GHC's trac"-        "eval"        -> "eval. Do nothing (perversely)"--        "id"          -> "id <arg>. The identity plugin"-        "read"        -> "read \"<foo>\". Print <foo>"-        "show"        -> "show <foo>. Print \"<foo>\""-        "wiki"        -> "wiki <page>. URLs of Haskell wiki pages"-        "oldwiki"     -> "oldwiki <page>. URLs of the old hawiki pages"-        "paste"       -> "paste. Paste page url"--        "docs"        -> "docs <lib>. Lookup the url for this library's documentation"-        "source"      -> "source <lib>. Lookup the url of fptools libraries"-        "fptools"     -> "fptools <lib>. Lookup url of ghc base library modules"--        "learn"       -> "learn. The learning page url"-        "eurohaskell" -> "eurohaskell. Historical"-        "map"         -> "map. #haskell user map"-        "botsnack"    -> "botsnack. Feeds the bot a snack"-        "get-shapr"   -> "get-shapr. Summon shapr instantly"-        "shootout"    -> "shootout. The debian language shootout"-        "faq"         -> "faq. Answer frequently asked questions about Haskell"-        "choose"      -> "choose. Lambdabot featuring AI power"-        "googleit"    -> "letmegooglethatforyou."--  process_ _ "eval"   _    = return []-  process_ _ "choose" []   = return ["Choose between what?"]-  process_ _ "choose" xs   = fmap return . io . randomElem . lines $ xs-  process_ _ cmd      rest = case lookup cmd dummylst of-    Nothing -> error "Dummy: invalid command"-    Just f  -> return $ lines $ f rest--  contextual _ _ _ "lisppaste2: url" = return [pastebinMsg]-  contextual _ _ _ _                 = return []--pastebinMsg :: String-pastebinMsg = "Haskell pastebin: http://hpaste.org/"--dummylst :: [(String, String -> String)]-dummylst =-    [("id",      (' ' :) . id)-    ,("read",    (' ' :) . filter (/= '\n') . read)-    ,("show",       show)--    ,("dummy",      const "dummy")-    ,("bug",        const "http://hackage.haskell.org/trac/ghc/newticket?type=bug")-    ,("get-shapr",  const "shapr!!")-    ,("faq",        const "The answer is: Yes! Haskell can do that.")-    ,("paste",      const pastebinMsg)-    ,("learn",      const "http://www.haskell.org/learning.html")-    ,("map",        const "http://www.haskell.org/hawiki/HaskellUserLocations")-    ,("shootout",   const "http://shootout.alioth.debian.org/gp4/benchmark.php?test=all&lang=all")-    ,("botsnack",   const ":)")-    ,("thanks",     const "you are welcome")-    ,("thx",        const "you are welcome")-    ,("thank you",  const "you are welcome")-    ,("ping",	    const "pong")--    ,("wiki",       lookupWiki)-    ,("oldwiki",     ("http://www.haskell.org/hawiki/" ++))--    ,("docs",        \x -> if null x-                            then docPrefix <> "index.html"-                            else lookupPackage docPrefix '-' "html" x)--    ,("source",     lookupPackage "http://darcs.haskell.org/packages/" '/' "hs")--    ,("fptools",    lookupPackage "http://darcs.haskell.org/packages/" '/' "hs")-    ,("hackage",    lookupHackage)-    ,("googleit",   lookupGoogle)-    ]--lookupWiki :: String -> String-lookupWiki page = "http://www.haskell.org/haskellwiki/" ++ spacesToUnderscores page-  where spacesToUnderscores = map (\c -> if c == ' ' then '_' else c)--lookupHackage :: String -> String-lookupHackage "" = "http://hackage.haskell.org"-lookupHackage xs = "http://hackage.haskell.org/package/" ++ xs--googlePrefix :: String-googlePrefix = "http://letmegooglethatforyou.com"--lookupGoogle :: String -> String-lookupGoogle "" = googlePrefix-lookupGoogle xs = googlePrefix ++ "/?q=" ++ quote xs- where-    quote = map (\x -> if x == ' ' then '+' else x)--docPrefix :: String-docPrefix = "http://haskell.org/ghc/docs/latest/html/libraries/"--lookupPackage :: String -> Char -> String -> String -> String-lookupPackage begin sep end x'- = case M.lookup (P.pack x) docAssocs of-        Nothing -> x ++ " not available"-        Just m  -> begin-                    <> P.unpack m-                    </> map (choice (=='.') (const sep) id) x-                    <.> end- where x = dropSpace x'
− Plugin/Dummy/DocAssocs.hs 
@@ -1,386 +0,0 @@--module Plugin.Dummy.DocAssocs (docAssocs) where--import qualified Data.Map as M-import qualified Data.ByteString.Char8 as P---- pack all these strings--base :: P.ByteString-base = P.pack "base"-stm :: P.ByteString-stm  = P.pack "stm"-mtl :: P.ByteString-mtl  = P.pack "mtl"-fgl :: P.ByteString-fgl  = P.pack "fgl"-qc  :: P.ByteString-qc   = P.pack "QuickCheck"-hunit  :: P.ByteString-hunit = P.pack "bytestring"-parsec  :: P.ByteString-parsec = P.pack "parsec"-unix  :: P.ByteString-unix   = P.pack "unix"-readline :: P.ByteString-readline = P.pack "readline"-network :: P.ByteString-network  = P.pack "network"-th :: P.ByteString-th       = P.pack "template-haskell"-hs :: P.ByteString-hs       = P.pack "1"-cabal :: P.ByteString-cabal    = P.pack "Cabal"-hgl :: P.ByteString-hgl      = P.pack "3"-glut :: P.ByteString-glut     = P.pack "GLUT"-x11 :: P.ByteString-x11      = P.pack "3"-opengl :: P.ByteString-opengl   = P.pack "OpenGL"-containers :: P.ByteString-containers = P.pack "containers"--docAssocs :: M.Map P.ByteString P.ByteString-docAssocs = {-# SCC "Dummy.DocAssocs" #-} M.fromList [-  (P.pack "Control.Arrow", base),-  (P.pack "Control.Concurrent", base),-  (P.pack "Control.Concurrent.Chan", base),-  (P.pack "Control.Concurrent.MVar", base),-  (P.pack "Control.Concurrent.QSem", base),-  (P.pack "Control.Concurrent.QSemN", base),-  (P.pack "Control.Concurrent.STM", stm),-  (P.pack "Control.Concurrent.STM.TChan", stm),-  (P.pack "Control.Concurrent.STM.TMVar", stm),-  (P.pack "Control.Concurrent.STM.TVar", stm),-  (P.pack "Control.Concurrent.SampleVar", base),-  (P.pack "Control.Exception", base),-  (P.pack "Control.Monad", base),-  (P.pack "Control.Monad.Cont", mtl),-  (P.pack "Control.Monad.Error", mtl),-  (P.pack "Control.Monad.Fix", base),-  (P.pack "Control.Monad.Identity", mtl),-  (P.pack "Control.Monad.List", mtl),-  (P.pack "Control.Monad.RWS", mtl),-  (P.pack "Control.Monad.Reader", mtl),-  (P.pack "Control.Monad.ST", base),-  (P.pack "Control.Monad.ST.Lazy", base),-  (P.pack "Control.Monad.ST.Strict", base),-  (P.pack "Control.Monad.State", mtl),-  (P.pack "Control.Monad.Trans", mtl),-  (P.pack "Control.Monad.Writer", mtl),-  (P.pack "Control.Parallel", base),-  (P.pack "Control.Parallel.Strategies", base),-  (P.pack "Data.Array", base),-  (P.pack "Data.Array.Diff", base),-  (P.pack "Data.Array.IArray", base),-  (P.pack "Data.Array.IO", base),-  (P.pack "Data.Array.MArray", base),-  (P.pack "Data.Array.ST", base),-  (P.pack "Data.Array.Storable", base),-  (P.pack "Data.Array.Unboxed", base),-  (P.pack "Data.Bits", base),-  (P.pack "Data.Bool", base),-  (P.pack "Data.Char", base),-  (P.pack "Data.Complex", base),-  (P.pack "Data.Dynamic", base),-  (P.pack "Data.Either", base),-  (P.pack "Data.FiniteMap", base),-  (P.pack "Data.FunctorM", base),-  (P.pack "Data.Generics", base),-  (P.pack "Data.Generics.Aliases", base),-  (P.pack "Data.Generics.Basics", base),-  (P.pack "Data.Generics.Instances", base),-  (P.pack "Data.Generics.Schemes", base),-  (P.pack "Data.Generics.Text", base),-  (P.pack "Data.Generics.Twins", base),-  (P.pack "Data.Graph", containers),-  (P.pack "Data.Graph.Inductive", fgl),-  (P.pack "Data.Graph.Inductive.Basic", fgl),-  (P.pack "Data.Graph.Inductive.Example", fgl),-  (P.pack "Data.Graph.Inductive.Graph", fgl),-  (P.pack "Data.Graph.Inductive.Graphviz", fgl),-  (P.pack "Data.Graph.Inductive.Internal.FiniteMap", fgl),-  (P.pack "Data.Graph.Inductive.Internal.Heap", fgl),-  (P.pack "Data.Graph.Inductive.Internal.Queue", fgl),-  (P.pack "Data.Graph.Inductive.Internal.RootPath", fgl),-  (P.pack "Data.Graph.Inductive.Internal.Thread", fgl),-  (P.pack "Data.Graph.Inductive.Monad", fgl),-  (P.pack "Data.Graph.Inductive.Monad.IOArray", fgl),-  (P.pack "Data.Graph.Inductive.NodeMap", fgl),-  (P.pack "Data.Graph.Inductive.Query", fgl),-  (P.pack "Data.Graph.Inductive.Query.ArtPoint", fgl),-  (P.pack "Data.Graph.Inductive.Query.BCC", fgl),-  (P.pack "Data.Graph.Inductive.Query.BFS", fgl),-  (P.pack "Data.Graph.Inductive.Query.DFS", fgl),-  (P.pack "Data.Graph.Inductive.Query.Dominators", fgl),-  (P.pack "Data.Graph.Inductive.Query.GVD", fgl),-  (P.pack "Data.Graph.Inductive.Query.Indep", fgl),-  (P.pack "Data.Graph.Inductive.Query.MST", fgl),-  (P.pack "Data.Graph.Inductive.Query.MaxFlow", fgl),-  (P.pack "Data.Graph.Inductive.Query.MaxFlow2", fgl),-  (P.pack "Data.Graph.Inductive.Query.Monad", fgl),-  (P.pack "Data.Graph.Inductive.Query.SP", fgl),-  (P.pack "Data.Graph.Inductive.Query.TransClos", fgl),-  (P.pack "Data.Graph.Inductive.Tree", fgl),-  (P.pack "Data.HashTable", base),-  (P.pack "Data.IORef", base),-  (P.pack "Data.Int", base),-  (P.pack "Data.IntMap", containers),-  (P.pack "Data.IntSet", containers),-  (P.pack "Data.Ix", base),-  (P.pack "Data.List", base),-  (P.pack "Data.Map", containers),-  (P.pack "Data.Maybe", base),-  (P.pack "Data.Monoid", base),-  (P.pack "Data.PackedString", base),-  (P.pack "Data.Queue", base),-  (P.pack "Data.Ratio", base),-  (P.pack "Data.STRef", base),-  (P.pack "Data.STRef.Lazy", base),-  (P.pack "Data.STRef.Strict", base),-  (P.pack "Data.Sequence", containers),-  (P.pack "Data.Set", containers),-  (P.pack "Data.Tree", containers),-  (P.pack "Data.Tuple", base),-  (P.pack "Data.Typeable", base),-  (P.pack "Data.Unique", base),-  (P.pack "Data.Version", base),-  (P.pack "Data.Word", base),-  (P.pack "Debug.QuickCheck", qc),-  (P.pack "Debug.QuickCheck.Batch", qc),-  (P.pack "Debug.QuickCheck.Poly", qc),-  (P.pack "Debug.QuickCheck.Utils", qc),-  (P.pack "Debug.Trace", base),-  (P.pack "Distribution.Compat.Directory", cabal),-  (P.pack "Distribution.Compat.Exception", cabal),-  (P.pack "Distribution.Compat.FilePath", cabal),-  (P.pack "Distribution.Compat.RawSystem", cabal),-  (P.pack "Distribution.Compat.ReadP", cabal),-  (P.pack "Distribution.Extension", cabal),-  (P.pack "Distribution.GetOpt", cabal),-  (P.pack "Distribution.InstalledPackageInfo", cabal),-  (P.pack "Distribution.License", cabal),-  (P.pack "Distribution.Make", cabal),-  (P.pack "Distribution.Package", cabal),-  (P.pack "Distribution.PackageDescription", cabal),-  (P.pack "Distribution.PreProcess", cabal),-  (P.pack "Distribution.PreProcess.Unlit", cabal),-  (P.pack "Distribution.Setup", cabal),-  (P.pack "Distribution.Simple", cabal),-  (P.pack "Distribution.Simple.Build", cabal),-  (P.pack "Distribution.Simple.Configure", cabal),-  (P.pack "Distribution.Simple.GHCPackageConfig", cabal),-  (P.pack "Distribution.Simple.Install", cabal),-  (P.pack "Distribution.Simple.LocalBuildInfo", cabal),-  (P.pack "Distribution.Simple.Register", cabal),-  (P.pack "Distribution.Simple.SrcDist", cabal),-  (P.pack "Distribution.Simple.Utils", cabal),-  (P.pack "Distribution.Version", cabal),-  (P.pack "Foreign", base),-  (P.pack "Foreign.C", base),-  (P.pack "Foreign.C.Error", base),-  (P.pack "Foreign.C.String", base),-  (P.pack "Foreign.C.Types", base),-  (P.pack "Foreign.Concurrent", base),-  (P.pack "Foreign.ForeignPtr", base),-  (P.pack "Foreign.Marshal", base),-  (P.pack "Foreign.Marshal.Alloc", base),-  (P.pack "Foreign.Marshal.Array", base),-  (P.pack "Foreign.Marshal.Error", base),-  (P.pack "Foreign.Marshal.Pool", base),-  (P.pack "Foreign.Marshal.Utils", base),-  (P.pack "Foreign.Ptr", base),-  (P.pack "Foreign.StablePtr", base),-  (P.pack "Foreign.Storable", base),-  (P.pack "GHC.Conc", base),-  (P.pack "GHC.ConsoleHandler", base),-  (P.pack "GHC.Dotnet", base),-  (P.pack "GHC.Exts", base),-  (P.pack "Graphics.HGL", hgl),-  (P.pack "Graphics.HGL.Core", hgl),-  (P.pack "Graphics.HGL.Draw", hgl),-  (P.pack "Graphics.HGL.Draw.Brush", hgl),-  (P.pack "Graphics.HGL.Draw.Font", hgl),-  (P.pack "Graphics.HGL.Draw.Monad", hgl),-  (P.pack "Graphics.HGL.Draw.Pen", hgl),-  (P.pack "Graphics.HGL.Draw.Picture", hgl),-  (P.pack "Graphics.HGL.Draw.Region", hgl),-  (P.pack "Graphics.HGL.Draw.Text", hgl),-  (P.pack "Graphics.HGL.Key", hgl),-  (P.pack "Graphics.HGL.Run", hgl),-  (P.pack "Graphics.HGL.Units", hgl),-  (P.pack "Graphics.HGL.Utils", hgl),-  (P.pack "Graphics.HGL.Window", hgl),-  (P.pack "Graphics.Rendering.OpenGL", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Antialiasing", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.BasicTypes", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.BeginEnd", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Bitmaps", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.BufferObjects", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Clipping", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.ColorSum", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Colors", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.CoordTrans", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.DisplayLists", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Evaluators", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Feedback", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.FlushFinish", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Fog", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Framebuffer", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Hints", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.LineSegments", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.PerFragment", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.PixelRectangles", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.PixelRectangles.Convolution", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.PixelRectangles.Histogram", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.PixelRectangles.Minmax", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelMap", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelStorage", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.PixelRectangles.PixelTransfer", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.PixelRectangles.Rasterization", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Points", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Polygons", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.RasterPos", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.ReadCopyPixels", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Rectangles", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.SavingState", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Selection", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.StateVar", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.StringQueries", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Texturing", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Texturing.Application", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Texturing.Environments", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Texturing.Objects", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Texturing.Parameters", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Texturing.Queries", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.Texturing.Specification", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.VertexArrays", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GL.VertexSpec", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GLU", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GLU.Errors", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GLU.Initialization", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GLU.Matrix", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GLU.Mipmapping", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GLU.NURBS", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GLU.Quadrics", opengl),-  (P.pack "Graphics.Rendering.OpenGL.GLU.Tessellation", opengl),-  (P.pack "Graphics.SOE", hgl),-  (P.pack "Graphics.UI.GLUT", glut),-  (P.pack "Graphics.UI.GLUT.Begin", glut),-  (P.pack "Graphics.UI.GLUT.Callbacks", glut),-  (P.pack "Graphics.UI.GLUT.Callbacks.Global", glut),-  (P.pack "Graphics.UI.GLUT.Callbacks.Window", glut),-  (P.pack "Graphics.UI.GLUT.Colormap", glut),-  (P.pack "Graphics.UI.GLUT.Debugging", glut),-  (P.pack "Graphics.UI.GLUT.DeviceControl", glut),-  (P.pack "Graphics.UI.GLUT.Fonts", glut),-  (P.pack "Graphics.UI.GLUT.GameMode", glut),-  (P.pack "Graphics.UI.GLUT.Initialization", glut),-  (P.pack "Graphics.UI.GLUT.Menu", glut),-  (P.pack "Graphics.UI.GLUT.Objects", glut),-  (P.pack "Graphics.UI.GLUT.Overlay", glut),-  (P.pack "Graphics.UI.GLUT.State", glut),-  (P.pack "Graphics.UI.GLUT.Window", glut),-  (P.pack "Graphics.X11.Types", x11),-  (P.pack "Graphics.X11.Xlib", x11),-  (P.pack "Graphics.X11.Xlib.Atom", x11),-  (P.pack "Graphics.X11.Xlib.Color", x11),-  (P.pack "Graphics.X11.Xlib.Context", x11),-  (P.pack "Graphics.X11.Xlib.Display", x11),-  (P.pack "Graphics.X11.Xlib.Event", x11),-  (P.pack "Graphics.X11.Xlib.Font", x11),-  (P.pack "Graphics.X11.Xlib.Misc", x11),-  (P.pack "Graphics.X11.Xlib.Region", x11),-  (P.pack "Graphics.X11.Xlib.Screen", x11),-  (P.pack "Graphics.X11.Xlib.Types", x11),-  (P.pack "Graphics.X11.Xlib.Window", x11),-  (P.pack "Language.Haskell.Parser", hs),-  (P.pack "Language.Haskell.Pretty", hs),-  (P.pack "Language.Haskell.Syntax", hs),-  (P.pack "Language.Haskell.TH", th),-  (P.pack "Language.Haskell.TH.Lib", th),-  (P.pack "Language.Haskell.TH.Ppr", th),-  (P.pack "Language.Haskell.TH.PprLib", th),-  (P.pack "Language.Haskell.TH.Syntax", th),-  (P.pack "Network", network),-  (P.pack "Network.BSD", network),-  (P.pack "Network.CGI", network),-  (P.pack "Network.Socket", network),-  (P.pack "Network.URI", network),-  (P.pack "Numeric", base),-  (P.pack "Prelude", base),-  (P.pack "System.CPUTime", base),-  (P.pack "System.Cmd", base),-  (P.pack "System.Console.GetOpt", base),-  (P.pack "System.Console.Readline", readline),-  (P.pack "System.Console.SimpleLineEditor", readline),-  (P.pack "System.Directory", base),-  (P.pack "System.Environment", base),-  (P.pack "System.Exit", base),-  (P.pack "System.IO", base),-  (P.pack "System.IO.Error", base),-  (P.pack "System.IO.Unsafe", base),-  (P.pack "System.Info", base),-  (P.pack "System.Locale", base),-  (P.pack "System.Mem", base),-  (P.pack "System.Mem.StableName", base),-  (P.pack "System.Mem.Weak", base),-  (P.pack "System.Posix", unix),-  (P.pack "System.Posix.Directory", unix),-  (P.pack "System.Posix.DynamicLinker", unix),-  (P.pack "System.Posix.DynamicLinker.Module", unix),-  (P.pack "System.Posix.DynamicLinker.Prim", unix),-  (P.pack "System.Posix.Env", unix),-  (P.pack "System.Posix.Error", unix),-  (P.pack "System.Posix.Files", unix),-  (P.pack "System.Posix.IO", unix),-  (P.pack "System.Posix.Process", unix),-  (P.pack "System.Posix.Resource", unix),-  (P.pack "System.Posix.Signals", base),-  (P.pack "System.Posix.Signals.Exts", unix),-  (P.pack "System.Posix.Temp", unix),-  (P.pack "System.Posix.Terminal", unix),-  (P.pack "System.Posix.Time", unix),-  (P.pack "System.Posix.Types", base),-  (P.pack "System.Posix.Unistd", unix),-  (P.pack "System.Posix.User", unix),-  (P.pack "System.Process", base),-  (P.pack "System.Random", base),-  (P.pack "System.Time", base),-  (P.pack "Test.HUnit", hunit),-  (P.pack "Test.HUnit.Base", hunit),-  (P.pack "Test.HUnit.Lang", hunit),-  (P.pack "Test.HUnit.Terminal", hunit),-  (P.pack "Test.HUnit.Text", hunit),-  (P.pack "Test.QuickCheck", qc),-  (P.pack "Test.QuickCheck.Batch", qc),-  (P.pack "Test.QuickCheck.Poly", qc),-  (P.pack "Test.QuickCheck.Utils", qc),-  (P.pack "Text.Html", base),-  (P.pack "Text.Html.BlockTable", base),-  (P.pack "Text.ParserCombinators.Parsec", parsec),-  (P.pack "Text.ParserCombinators.Parsec.Char", parsec),-  (P.pack "Text.ParserCombinators.Parsec.Combinator", parsec),-  (P.pack "Text.ParserCombinators.Parsec.Error", parsec),-  (P.pack "Text.ParserCombinators.Parsec.Expr", parsec),-  (P.pack "Text.ParserCombinators.Parsec.Language", parsec),-  (P.pack "Text.ParserCombinators.Parsec.Perm", parsec),-  (P.pack "Text.ParserCombinators.Parsec.Pos", parsec),-  (P.pack "Text.ParserCombinators.Parsec.Prim", parsec),-  (P.pack "Text.ParserCombinators.Parsec.Token", parsec),-  (P.pack "Text.ParserCombinators.ReadP", base),-  (P.pack "Text.ParserCombinators.ReadPrec", base),-  (P.pack "Text.PrettyPrint", base),-  (P.pack "Text.PrettyPrint.HughesPJ", base),-  (P.pack "Text.Printf", base),-  (P.pack "Text.Read", base),-  (P.pack "Text.Read.Lex", base),-  (P.pack "Text.Regex", base),-  (P.pack "Text.Regex.Posix", base),-  (P.pack "Text.Show", base),-  (P.pack "Text.Show.Functions", base)]
− Plugin/Dynamic.hs 
@@ -1,63 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}--- Copyright (c) 2004-06 Don Stewart - http://www.cse.unsw.edu.au/~dons--- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)------ | Dynamic module, binding to the dynamic linker----module Plugin.Dynamic (theModule) where--import Plugin-import Control.Monad.State--$(plugin "Dynamic")--instance Module DynamicModule () where--    moduleSticky _ = True-    moduleHelp _ _ = "An interface to dynamic linker"-    modulePrivs  _ = ["dynamic-load","dynamic-unload","dynamic-reload"]--    moduleInit   _ = lift $ do-        plugins <- gets ircPlugins-        mapM_ (\p -> load p >> liftIO (putChar '!' >> hFlush stdout)) plugins--    process_ _ s rest = case s of-        "dynamic-load"      -> lift (load rest)                >> return ["module loaded"]-        "dynamic-unload"    -> lift (unload rest)              >> return ["module unloaded"]-        "dynamic-reload"    -> lift (unload rest >> load rest) >> return ["module reloaded"]------- | Load value "theModule" from each plugin, given simple name of a--- plugin, i.e. "google"----load :: String -> LB Bool-load nm = do-    let file = getModuleFile nm-    catchError-        (do (_,md) <- ircLoad file "theModule"-            ircInstallModule md nm-            return True) -- need to put mod in state-        (\_ -> do-            ircUnload file-            liftIO $ putStrLn $ "\nCouldn't load "++nm++", ignoring"-            return False)------- | Unload a module, e.g. "vixen"----unload :: String -> LB ()-unload nm = do-        plugins <- gets ircPlugins-        unless (nm `elem` plugins) $ error "unknown or static module"-        ircUnloadModule nm-        ircUnload (getModuleFile nm)------- | Convert simple plugin name to a valid plugin. Could sanity check.----getModuleFile :: [Char] -> [Char]-getModuleFile s = "Plugin/" ++ upperise s ++ ".o"-    where-        upperise :: [Char] -> [Char]-        upperise []     = []-        upperise (c:cs) = toUpper c:cs
− Plugin/Elite.hs 
@@ -1,79 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}--- (c) Josef Svenningsson, 2005--- Licence: No licence, public domain---- Inspired by the following page:--- http://www.microsoft.com/athome/security/children/kidtalk.mspx-module Plugin.Elite (theModule) where--import Plugin-import qualified Text.Regex as R--import Control.Arrow-import Control.Monad.State--$(plugin "Elite")--instance Module EliteModule () where-    moduleCmds _   = ["elite"]-    moduleHelp _ _ = "elite <phrase>. Translate English to elitespeak"-    process_ _ _ args = ios $-        case words args of-             [] -> return "Say again?"-             wds -> do let instr = map toLower (unwords wds)-                       transWords <- translate instr-                       return transWords--translate :: MonadIO m => String -> m String-translate []  = return []-translate str = case alts of-                  [] -> do rest <- translate (tail str)-                           return (head str : rest)-                  _ -> do (subst,rest) <- liftIO $ stdGetRandItem alts-                          translatedRest <- translate rest-                          return (subst ++ translatedRest)-  where alts = (map (\ (Just (_,_,rest,_),subst) -> (subst,rest)) $-                filter isJustEmpty $-                map (\ (re, subst) -> (R.matchRegexAll re str,subst)) $-                ruleList)-               ++ [([toUpper $ head str],tail str)-                  ,([head str],tail str)-                  ]--isJustEmpty :: (Maybe([a],b,c,d),e) -> Bool-isJustEmpty (Just ([],_,_,_),_) = True-isJustEmpty (_,_)                = False--ruleList :: [(Regex,String)]-ruleList = map (first regex')-           [("a","4")-           ,("b","8")-           ,("c","(")-           ,("ck","xx")-           ,("cks ","x ")-           ,(" cool "," kewl ")-           ,("e","3")-           ,("elite","1337")-           ,("f","ph")-           ,(" for "," 4 ")-           ,("g","9")-           ,("h","|-|")-           ,("k","x")-           ,("l","|")-           ,("l","1")-           ,("m","/\\/\\")-           ,("o","0")-           ,("ph","f")-           ,("s","z")-           ,("s","$")-           ,("s","5")-           ,("s ","z0rz ")-           ,("t","7")-           ,("t","+")-           ,("v","\\/")-           ,("w","\\/\\/")-           ,(" you "," u ")-           ,(" you "," joo ")-           ,("z","s")-           ]-
− Plugin/Eval.hs 
@@ -1,215 +0,0 @@--{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, PatternGuards #-}--- Copyright (c) 2004-6 Donald Bruce Stewart - http://www.cse.unsw.edu.au/~dons--- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)---- | A Haskell evaluator for the pure part, using plugs-module Plugin.Eval where--import File (findFile)-import Plugin-import Lambdabot.Parser-import Language.Haskell.Exts.Parser-import qualified Language.Haskell.Exts.Syntax as Hs-import qualified Text.Regex as R-import System.Directory-import System.Exit-import Codec.Binary.UTF8.String (decodeString)-import qualified Data.ByteString.Char8 as P-import Control.OldException (try)--$(plugin "Plugs")--instance Module PlugsModule () where-    moduleCmds   _             = ["run","let","undefine"]-    moduleHelp _ "let"         = "let <x> = <e>. Add a binding"-    moduleHelp _ "undefine"    = "undefine. Reset evaluator local bindings"-    moduleHelp _ _             = "run <expr>. You have Haskell, 3 seconds and no IO. Go nuts!"-    process _ _ to "run" s     = ios80 to (plugs s)-    process _ _ to "let" s     = ios80 to (define s)-    process _ _ _ "undefine" _ = do l <- io $ findFile "L.hs"-                                    p <- io $ findFile "Pristine.hs"-                                    io $ copyFile p l---                                    x <- io $ comp Nothing---                                    return [x]-                                    return []--    contextual _ _ to txt-        | isEval txt = ios80 to . plugs . dropPrefix $ txt-        | otherwise  = return []--binary :: String-binary = "mueval"--isEval :: String -> Bool-isEval = ((evalPrefixes config) `arePrefixesWithSpaceOf`)--dropPrefix :: String -> String-dropPrefix = dropWhile (' ' ==) . drop 2--plugs :: String -> IO String-plugs src = do-            load <- findFile "L.hs"-            let args = ["-E", "-XBangPatterns", "-XNoMonomorphismRestriction", "-XViewPatterns", "--no-imports", "-l", load, "--expression=" ++ src, "+RTS", "-N2", "-RTS"]-            print args-            (out,err,_) <- popen binary args Nothing-            case (out,err) of-                ([],[]) -> return "Terminated\n"-                _       -> do-                    let o = munge out-                        e = munge err-                    return $ case () of {_-                        | null o && null e -> "Terminated\n"-                        | null o           -> " " ++ e-                        | otherwise        -> " " ++ o-                    }----------------------------------------------------------------------------- define a new binding--define :: String -> IO String-define src = case parseModule (decodeString src ++ "\n") of -- extra \n so comments are parsed correctly-    (ParseOk (Hs.Module _ _ _ _ (Just [Hs.EVar (Hs.UnQual (Hs.Ident "main"))]) [] ds))-        | all okay ds -> comp (Just src)-    (ParseFailed _ e) -> return $ " " ++ e-    _                 -> return "Invalid declaration"- where-    okay (Hs.TypeSig   {}) = True-    okay (Hs.FunBind   {}) = True-    okay (Hs.PatBind   {}) = True-    okay (Hs.InfixDecl {}) = True-    okay _                 = False---- It parses. then add it to a temporary L.hs and typecheck-comp :: Maybe String -> IO String-comp src = do-    l <- findFile "L.hs"-    -- Note we copy to .L.hs, not L.hs. This hides the temporary files as dot-files-    copyFile l ".L.hs"-    case src of-        Nothing -> return () -- just reset from Pristine-        Just s  -> P.appendFile ".L.hs" (P.pack (s  ++ "\n"))--    -- and compile .L.hs-    -- careful with timeouts here. need a wrapper.-    (o',e',c) <- popen "ghc" ["-O","-v0","-c"-                             ,"-Werror"---                             ,"-odir", "State/"---                             ,"-hidir","State/"-                             ,".L.hs"] Nothing-    -- cleanup, in case of error the files are not generated-    try $ removeFile ".L.hi"-    try $ removeFile ".L.o"--    case (munge o', munge e') of-        ([],[]) | c /= ExitSuccess -> return "Error."-                | otherwise -> do-                    renameFile ".L.hs" l-                    return (maybe "Undefined." (const "Defined.") src)-        (ee,[]) -> return ee-        (_ ,ee) -> return ee----- test cases--- lambdabot> undefine--- Undefined.------ lambdabot> let x = 1--- Defined.--- lambdabot> let y = L.x--- Defined.--- lambdabot> > L.x + L.y--- 2--- lambdabot> let type Z = Int--- Defined.--- lambdabot> let newtype P = P Int--- Defined.--- lambdabot> > L.P 1 :: L.P---  add an instance declaration for (Show L.P)--- lambdabot> let instance Show L.P where show _ = "P"--- Defined.--- lambdabot> > L.P 1 :: L.P---  P--------munge :: String -> String-munge = expandTab . dropWhile (=='\n') . dropNL . clean_------- Clean up runplugs' output----clean_ :: String -> String-clean_ = id-{--clean_ s|  no_io      `matches'`    s = "No IO allowed\n"-        |  type_sig   `matches'`    s = "Add a type signature\n"-        |  enomem     `matches'`    s = "Tried to use too much memory\n"--        | Just (_,m,_,_) <- ambiguous  `R.matchRegexAll` s = m-        | Just (_,_,b,_) <- inaninst   `R.matchRegexAll` s = clean_ b-        | Just (_,_,b,_) <- irc        `R.matchRegexAll` s = clean_ b-        | Just (_,m,_,_) <- nomatch    `R.matchRegexAll` s = m-        | Just (_,m,_,_) <- notinscope `R.matchRegexAll` s = m-        | Just (_,m,_,_) <- hsplugins  `R.matchRegexAll`  s = m-        | Just (a,_,_,_) <- columnnum  `R.matchRegexAll`  s = a-        | Just (a,_,_,_) <- extraargs  `R.matchRegexAll`  s = a-        | Just (_,_,b,_) <- filename'  `R.matchRegexAll`  s = clean_ b-        | Just (a,_,b,_) <- filename   `R.matchRegexAll`  s = a ++ clean_ b-        | Just (a,_,b,_) <- filepath   `R.matchRegexAll`   s = a ++ clean_ b-        | Just (a,_,b,_) <- runplugs   `R.matchRegexAll`  s = a ++ clean_ b-        | otherwise      = s-    where-        -- s/<[^>]*>:[^:]: //-        type_sig   = regex' "add a type signature that fixes these type"-        no_io      = regex' "No instance for \\(Show \\(IO"-        irc        = regex' "\n*<irc>:[^:]*:[^:]*:\n*"-        filename   = regex' "\n*<[^>]*>:[^:]*:\\?[^:]*:\\?\n* *"-        filename'  = regex' "/tmp/.*\\.hs[^\n]*\n"-        filepath   = regex' "\n*/[^\\.]*.hs:[^:]*:\n* *"-        ambiguous  = regex' "Ambiguous type variable `a\' in the constraints"-        runplugs   = regex' "runplugs: "-        notinscope = regex' "Variable not in scope:[^\n]*"-        hsplugins  = regex' "Compiled, but didn't create object"-        extraargs  = regex' "[ \t\n]*In the [^ ]* argument"-        columnnum  = regex' " at <[^\\.]*\\.[^\\.]*>:[^ ]*"-        nomatch    = regex' "Couldn't match[^\n]*\n"-        inaninst   = regex' "^[ \t]*In a.*$"-        enomem     = regex' "^Heap exhausted"--}-------------------------------------------------------------------------------- Plugs tests:---  * too long, should be terminated.---      @plugs last [ 1 .. 100000000 ]---      @plugs last [ 1 .. ]---      @plugs product [1..]---      @plugs let loop () = loop () in loop () :: ()------  * stack oflow---      @plugs scanr (*) 1 [1..]------  * type errors, or module scope errors---      @plugs unsafePerformIO (return 42)---      @plugs GHC.Exts.I# 1#---      @plugs $( Language.Haskell.THSyntax.Q (putStr "heya") >> [| 3 |] )---      @plugs Data.Array.listArray (minBound::Int,maxBound) (repeat 0)------  * syntax errors---      @plugs map foo bar---      @plugs $( [| 1 |] )------  * success---      @plugs head [ 1 .. ]---      @plugs [1..]---      @plugs last $ sort [1..100000 ]---      @plugs let fibs = 1:1:zipWith (+) fibs (tail fibs) in take 20 fibs---      @plugs sort [1..10000]---      @plugs ((error "throw me") :: ())---      @plugs Random.randomRs (0,747737437443734::Integer) (Random.mkStdGen 1122)------ More at http://www.scannedinavian.org/~shae/joyXlogs.txt---
− Plugin/FT.hs 
@@ -1,26 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}--- | Free theorems plugin,--- Don Stewart 2006-module Plugin.FT where--import Plugin-import Plugin.Type (query_ghci)--$(plugin "FT")--instance Module FTModule () where-    moduleCmds _   = ["ft"]-    moduleHelp _ _ = "ft <ident>. Generate theorems for free"-    process_ _ _ s = (liftM unlines . lift . query_ghci ":t") s >>= ios . ft--binary :: String-binary = "ftshell"--ft :: String -> IO String-ft src = run binary src $-    unlines . map (' ':) . filter (not.null) . map cleanit . lines--cleanit :: String -> String-cleanit s | terminated `matches'` s = "Terminated\n"-          | otherwise               = filter isAscii s-    where terminated = regex' "waitForProc"
− Plugin/Fact.hs 
@@ -1,78 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeSynonymInstances #-}--- Module    : Fact--- Copyright : 2003 Shae Erisson--- Copyright : 2005-06 Don Stewart------ License:     lGPL------ Quick ugly hack to get factoids in lambdabot.  This is a rewrite of--- Shae's original code to use internal module states. jlouis-module Plugin.Fact (theModule) where--import Plugin-import qualified Data.Map as M-import qualified Data.ByteString.Char8 as P----------------------------------------------------------------------------$(plugin "Fact")--type FactState  = M.Map P.ByteString P.ByteString-type FactWriter = FactState -> LB ()--- type Fact m a   = ModuleT FactState m a--instance Module FactModule FactState where--  moduleCmds   _ = ["fact","fact-set","fact-delete"-                   ,"fact-cons","fact-snoc","fact-update"]-  moduleHelp _ s = case s of-    "fact"        -> "fact <fact>, Retrieve a fact from the database"-    "fact-set"    -> "Define a new fact, guard if exists"-    "fact-update" -> "Define a new fact, overwriting"-    "fact-delete" -> "Delete a fact from the database"-    "fact-cons"   -> "cons information to fact"-    "fact-snoc"   -> "snoc information to fact"-    _             -> "Store and retrieve facts from a database"--  moduleDefState _  = return $ M.empty-  moduleSerialize _ = Just mapPackedSerial--  process_ _ cmd rest =-        list $ withMS $ \factFM writer -> case words rest of-            []         -> return "I can not handle empty facts."-            (fact:dat) -> processCommand factFM writer-                                (P.pack $ lowerCaseString fact)-                                cmd-                                (P.pack $ unwords dat)----------------------------------------------------------------------------processCommand :: FactState -> FactWriter-               -> P.ByteString -> String -> P.ByteString -> LB String-processCommand factFM writer fact cmd dat = case cmd of-        "fact"        -> return $ getFact factFM fact-        "fact-set"    -> updateFact True factFM writer fact dat-        "fact-update" -> updateFact False factFM writer fact dat-        "fact-cons"   -> alterFact ((dat `P.append` (P.pack " ")) `P.append`) factFM writer fact-        "fact-snoc"   -> alterFact (P.append ((P.pack " ") `P.append` dat))   factFM writer fact-        "fact-delete" -> writer ( M.delete fact factFM ) >> return "Fact deleted."-        _ -> return "Unknown command."--updateFact :: Bool -> FactState -> FactWriter -> P.ByteString -> P.ByteString -> LB String-updateFact guarded factFM writer fact dat =-    if guarded && M.member fact factFM-        then return "Fact already exists, not updating"-        else writer ( M.insert fact dat factFM ) >> return "Fact recorded."--alterFact :: (P.ByteString -> P.ByteString)-          -> FactState -> FactWriter -> P.ByteString -> LB String-alterFact f factFM writer fact =-    case M.lookup fact factFM of-        Nothing -> return "A fact must exist to alter it"-        Just x  -> do writer $ M.insert fact (f x) factFM-                      return "Fact altered."--getFact :: M.Map P.ByteString P.ByteString -> P.ByteString -> String-getFact fm fact = case M.lookup fact fm of-        Nothing -> "I know nothing about " ++ P.unpack fact-        Just x  -> P.unpack fact ++ ": " ++ P.unpack x
− Plugin/Filter.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}--- | GNU Talk Filters--- needs: http://www.hyperrealm.com/main.php?s=talkfilters--- Edward Kmett 2006--module Plugin.Filter where--import Plugin--$(plugin "Filter")--instance Module FilterModule () where-        moduleCmds _   = ["austro","b1ff","brooklyn","chef","cockney","drawl","dubya","fudd","funetak","jethro","jive","kraut","pansy","pirate","postmodern","redneck","valspeak","warez"]-        moduleHelp _ "austro" = "austro <phrase>. Talk like Ahhhnold"-        moduleHelp _ "b1ff" = "b1ff <phrase>. B1ff of usenet yore"-        moduleHelp _ "brooklyn" = "brooklyn <phrase>. Yo"-        moduleHelp _ "chef" = "chef <phrase>. Bork bork bork"-        moduleHelp _ "cockney" = "cockney <phrase>. Londoner accent"-        moduleHelp _ "drawl" = "drawl <phrase>. Southern drawl"-        moduleHelp _ "dubya" = "dubya <phrase>. Presidential filter"-        moduleHelp _ "fudd" = "fudd <phrase>. Fudd, Elmer"-        moduleHelp _ "funetak" = "funetak <phrase>. Southern drawl"-        moduleHelp _ "jethro" = "jethro <phrase>. Now listen to a story 'bout a man named Jed..."-        moduleHelp _ "jive" = "jive <phrase>. Slap ma fro"-        moduleHelp _ "kraut" = "kraut <phrase>. German accent"-        moduleHelp _ "pansy" = "pansy <phrase>. Effeminate male"-        moduleHelp _ "pirate" = "pirate <phrase>. Talk like a pirate"-        moduleHelp _ "postmodern" = "postmodern <phrase>. Feminazi"-        moduleHelp _ "redneck" = "redneck <phrase>. Deep south"-        moduleHelp _ "valspeak" = "valley <phrase>. Like, ya know?"-        moduleHelp _ "warez" = "warez <phrase>. H4x0r"-        process_ _ f s = do-                let usage = ["usage: " ++ f ++ " <phrase>"]-                case words s of-                        [] -> return usage-                        t -> io (runFilter f (unwords t))--pathTo :: String -> String-pathTo f = "/usr/local/bin/" ++ f--runFilter :: String -> String -> IO [String]-runFilter f s = do-        (out,_,_) <- popen (pathTo f) [] (Just s)-        return $ result out-    where result [] = ["Couldn't run the filter."]-          result xs = filter (not . all (==' ')) . lines $ xs
− Plugin/Free.hs 
@@ -1,16 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}--- | Free theorems plugin--- Andrew Bromage, 2006-module Plugin.Free where--import Plugin-import Plugin.Free.FreeTheorem-import Plugin.Type (query_ghci)--$(plugin "Free")--instance Module FreeModule () where-    moduleCmds _  = ["free"]-    moduleHelp _ _= "free <ident>. Generate theorems for free"-    process_ _ _ xs = do result <- freeTheoremStr (liftM unlines . lift . query_ghci ":t") xs-                         return . (:[]) . concat . intersperse " " . lines $ result
− Plugin/Free/Expr.hs 
@@ -1,132 +0,0 @@-{-# OPTIONS -w #-}
-
-module Plugin.Free.Expr where
-
-import Plugin.Free.Type
-import Plugin.Free.Util
-
-varInExpr :: Var -> Expr -> Bool
-varInExpr v (EBuiltin _)
-    = False
-varInExpr v (EVar v')
-    = v == v'
-varInExpr v (EVarOp _ _ v')
-    = False
-varInExpr v (EApp e1 e2)
-    = varInExpr v e1 || varInExpr v e2
-varInExpr v (ETyApp e1 t)
-    = varInExpr v e1
-
-leftVarOfExpr :: Expr -> Var
-leftVarOfExpr (EVar v) = v
-leftVarOfExpr (EApp e _) = leftVarOfExpr e
-leftVarOfExpr (ETyApp e _) = leftVarOfExpr e
-
-exprSubst :: Var -> Expr -> Expr -> Expr
-exprSubst v e e'@(EBuiltin _)
-    = e'
-exprSubst v e e'@(EVar v')
-    | v == v'   = e
-    | otherwise = e'
-exprSubst v e e'@(EVarOp _ _ v')
-    | v == v'   = e
-    | otherwise = e'
-exprSubst v e (EApp e1 e2)
-    = EApp (exprSubst v e e1) (exprSubst v e e2)
-exprSubst v e (ETyApp e1 t)
-    = ETyApp (exprSubst v e e1) t
-
-
-type Var = String
-
-data Fixity
-    = FL | FN | FR
-    deriving (Eq, Show)
-
-data Expr
-    = EVar Var
-    | EBuiltin Builtin
-    | EVarOp Fixity Int Var
-    | EApp Expr Expr
-    | ETyApp Expr Type
-        deriving (Eq, Show)
-
-data Builtin
-    = BMap TyName
-    | BId
-    | BProj Int Int
-    | BMapTuple Int
-    | BArr
-        deriving (Eq, Show)
-
-data ExprCtx
-    = ECDot
-    | ECAppL ExprCtx Expr
-    | ECAppR Expr ExprCtx
-    | ECTyApp ExprCtx Type
-        deriving (Eq, Show)
-
-applySimplifierExpr :: (Expr -> Expr) -> (Expr -> Expr)
-applySimplifierExpr s (EApp e1 e2)
-    = EApp (s e1) (s e2)
-applySimplifierExpr s (ETyApp e t)
-    = ETyApp (s e) t
-applySimplifierExpr s e
-    = e
-
-unzipExpr :: Expr -> ExprCtx -> Expr
-unzipExpr e ECDot = e
-unzipExpr e (ECAppL c e2) = unzipExpr (EApp e e2) c
-unzipExpr e (ECAppR e1 c) = unzipExpr (EApp e1 e) c
-unzipExpr e (ECTyApp c t) = unzipExpr (ETyApp e t) c
-
-varInCtx :: Var -> ExprCtx -> Bool
-varInCtx v ECDot
-    = False
-varInCtx v (ECAppL c e2)
-    = varInCtx v c || varInExpr v e2
-varInCtx v (ECAppR e1 c)
-    = varInCtx v c || varInExpr v e1
-varInCtx v (ECTyApp c _)
-    = varInCtx v c
-
-precAPP :: Int
-precAPP = 10
-
-instance Pretty Expr where
-    prettyP p (EBuiltin b)
-        = prettyP p b
-    prettyP _ (EVar v)
-        = text v
-    prettyP _ (EVarOp _ _ v)
-        = lparen <> text v <> rparen
-    prettyP p (EApp (EApp (EVarOp fix prec op) e1) e2)
-        = prettyParen (p > prec) (
-            prettyP pl e1 <+> text op <+> prettyP pr e2
-        )
-        where
-            pl = if fix == FL then prec else prec+1
-            pr = if fix == FR then prec else prec+1
-    prettyP p (EApp e1 e2)
-        = prettyParen (p > precAPP) (
-            prettyP precAPP e1 <+> prettyP (precAPP+1) e2
-        )
-    prettyP p (ETyApp e t)
-        = prettyP precAPP e
-
-instance Pretty Builtin where
-    prettyP p (BMap "[]")   = text "$map"
-    prettyP p (BMap c)      = text ("$map_" ++ c)
-    prettyP p BId           = text "$id"
-    prettyP p (BProj 2 1)   = text "$fst"
-    prettyP p (BProj 2 2)   = text "$snd"
-    prettyP p (BProj 3 1)   = text "$fst3"
-    prettyP p (BProj 3 2)   = text "$snd3"
-    prettyP p (BProj 3 3)   = text "$thd3"
-    prettyP p (BProj l i)   = text ("$proj_" ++ show l ++ "_" ++ show i)
-    prettyP p (BMapTuple 2) = text "$map_Pair"
-    prettyP p (BMapTuple 3) = text "$map_Triple"
-    prettyP p (BMapTuple n) = text $ "$map_Tuple" ++ show n
-    prettyP p BArr          = text "$arr"
-
--- vim: ts=4:sts=4:expandtab:ai
− Plugin/Free/FreeTheorem.hs 
@@ -1,293 +0,0 @@-{-# OPTIONS -w #-}
-
-module Plugin.Free.FreeTheorem where
-
-import Plugin.Free.Type
-import Plugin.Free.Expr
-import Plugin.Free.Theorem
-import Plugin.Free.Parse
-import Plugin.Free.Util
-
-import Control.Monad
-import Control.Monad.State
-import Control.Monad.Identity
-
-import Data.Char
-import qualified Data.Map as M
-
-newtype MyState
-    = MyState {
-        myVSupply :: Int
-    }
-
-type MyMon a = StateT MyState Identity a
-
-type TyEnv = [(TyVar,Var,TyVar,TyVar)]
-
-makeVar :: String -> MyMon String
-makeVar v
-    = do
-        vn <- gets myVSupply
-        modify (\s -> s { myVSupply = vn+1 })
-        return (v ++ "_" ++ show vn)
-
-extractTypes :: TyEnv -> Type -> (Type,Type)
-extractTypes env (TyVar v)
-    = head [ (TyVar t1,TyVar t2) | (v',_,t1,t2) <- env, v == v' ]
-extractTypes env (TyForall v t)
-    = let (t1,t2) = extractTypes ((v,undefined,v,v):env) t
-      in (TyForall v t1, TyForall v t2)
-extractTypes env (TyArr t1 t2)
-    = let (t1a,t1b) = extractTypes env t1
-          (t2a,t2b) = extractTypes env t2
-      in (TyArr t1a t2a, TyArr t1b t2b)
-extractTypes env (TyTuple ts)
-    = let ts12 = map (extractTypes env) ts
-      in (TyTuple (map fst ts12), TyTuple (map snd ts12))
-extractTypes env (TyCons c ts)
-    = let ts12 = map (extractTypes env) ts
-      in (TyCons c (map fst ts12), TyCons c (map snd ts12))
-
-freeTheoremStr :: (Monad m) => (String -> m String) -> String -> m String
-freeTheoremStr tf s
-    = case parse (do
-                    Just (QVarId v) <- getToken
-                    (mplus (do match OpColonColon
-                               t <- parseType
-                               return $ Left (v,t))
-                           (return (Right v)))) (lexer s) of
-        ParseSuccess (Left (v,t)) [] -> return (run' v t)
-        ParseSuccess (Right v)    [] -> do tStr <- tf s
-                                           case parse parseType (lexer tStr) of
-                                             ParseSuccess t [] -> return (run' v t)
-                                             ParseSuccess _ _ -> return $ "Extra stuff at end of line in retrieved type " ++ show tStr
-                                             ParseError msg -> return msg
-        ParseSuccess _ _      -> return "Extra stuff at end of line"
-        ParseError msg        -> return msg
-    where
-        run' v t = renderStyle defstyle (pretty (freeTheorem v t))
-        defstyle = Style {
-                        mode = PageMode,
-                        lineLength = 78,
-                        ribbonsPerLine = 1.5
-                    }
-
-freeTheorem :: String -> Type -> Theorem
-freeTheorem name t
-    = runIdentity $ do
-        (th,_) <- runStateT (freeTheorem' [] v0 v0 t) initState
-        let th' = theoremSimplify th
-        return . fst $ runState (insertRn name name >> rename th') initRnSt
-    where
-        v0 = EVar name
-        initState   = MyState { myVSupply = 1 }
-
-------------------------------------------------------------------------
--- Rename monad, and pretty alpha renamer
-
-data RnSt = RnSt { gamma  :: M.Map Var Var
-                 , unique   :: [Var]
-                 , uniquelist :: [Var]
-                 , uniquefn :: [Var]
-                 }
-    deriving Show
-
-initRnSt
-    = RnSt M.empty suggestionsVal suggestionsList suggestionsFun
-    where
-        suggestionsVal = map (:[]) "xyzuvabcstdeilmnorw"
-                            ++ [ 'x' : show i | i <- [1..] ]
-        suggestionsList = map (:"s") "xyzuvabcstdeilmnorw"
-                            ++ [ "xs" ++ show i | i <- [1..] ]
-        suggestionsFun = map (:[]) "fghkpq"
-                            ++ [ 'f' : show i | i <- [1..] ]
-
-type RN a = State RnSt a
-
--- generate a nice fresh name
-freshName :: RN Var
-freshName = do
-    s <- get
-    let ns    = unique s
-        fresh = head ns
-    put $ s { unique = tail ns }
-    case M.lookup fresh (gamma s) of
-        Nothing -> return fresh
-        _       -> freshName
-
--- generate a nice function name
-freshFunctionName :: RN Var
-freshFunctionName = do
-    s <- get
-    let ns    = uniquefn s
-        fresh = head ns
-    put $ s { uniquefn = tail ns }
-    case M.lookup fresh (gamma s) of
-        Nothing -> return fresh
-        _       -> freshFunctionName
-
--- generate a nice list name
-freshListName :: RN Var
-freshListName = do
-    s <- get
-    let ns    = uniquelist s
-        fresh = head ns
-    put $ s { uniquelist = tail ns }
-    case M.lookup fresh (gamma s) of
-        Nothing -> return fresh
-        _       -> freshListName
-
--- insert a new association into the heap
-insertRn :: Var -> Var -> RN ()
-insertRn old new = modify $ \s ->
-    let gamma' = M.insert old new (gamma s) in s { gamma = gamma' }
-
--- lookup the binding
-lookupRn :: Var -> RN Var
-lookupRn old = do
-    m <- gets gamma
-    return $ case M.lookup old m of
-        Nothing  -> old
-        Just new -> new
-
--- alpha rename a simplified theory to something nice
-rename :: Theorem -> RN Theorem
-rename (ThImplies th1 th2) = do
-    th1' <- rename th1
-    th2' <- rename th2
-    return $ ThImplies th1' th2'
-
-rename (ThEqual e1 e2) = do
-    e1' <- rnExp e1
-    e2' <- rnExp e2
-    return $ ThEqual e1' e2'
-
-rename (ThAnd th1 th2) = do
-    th1' <- rename th1
-    th2' <- rename th2
-    return $ ThAnd th1' th2'
-
-rename (ThForall v ty th) = do
-    v' <- case ty of
-                TyArr _ _     -> freshFunctionName
-                TyCons "[]" _ -> freshListName
-                _             -> freshName
-    insertRn v v'
-    ty' <- rnTy ty
-    th' <- rename th
-    return $ ThForall v' ty' th'
-
-rnExp :: Expr -> RN Expr
-rnExp e@(EBuiltin _) = return e
-rnExp (EVar v)       = EVar       `fmap` lookupRn v
-rnExp (EVarOp f n v) = EVarOp f n `fmap` lookupRn v
-
-rnExp (EApp e1 e2) = do
-    e1' <- rnExp e1
-    e2' <- rnExp e2
-    return (EApp e1' e2')
-
-rnExp (ETyApp e ty) = do
-    e'  <- rnExp e
-    ty' <- rnTy ty
-    return (ETyApp e' ty')
-
-rnTy :: Type -> RN Type
-rnTy ty = return ty
-
-------------------------------------------------------------------------
-
-freeTheorem' :: TyEnv -> Expr -> Expr -> Type -> MyMon Theorem
-
-freeTheorem' env e1 e2 t'@(TyForall v t)
-    = do
-        mv <- makeVar "f"
-        t1 <- makeVar v
-        t2 <- makeVar v
-        let tymv = TyArr (TyVar t1) (TyVar t2)
-        pt <- freeTheorem' ((v,mv,t1,t2):env) (ETyApp e1 (TyVar t1))
-                                              (ETyApp e2 (TyVar t2)) t
-        return (ThForall mv tymv pt)
-
-freeTheorem' env e1 e2 t'@(TyArr t1 t2)
-    = do
-        mv1 <- makeVar "v1"
-        mv2 <- makeVar "v2"
-        let (tmv1,tmv2) = extractTypes env t1
-        p1 <- freeTheorem' env (EVar mv1) (EVar mv2) t1
-        p2 <- freeTheorem' env (EApp e1 (EVar mv1)) (EApp e2 (EVar mv2)) t2
-        return (ThForall mv1 tmv1 (ThForall mv2 tmv2 (ThImplies p1 p2)))
-
-freeTheorem' env e1 e2 t'@(TyTuple [])
-    = do
-        return (ThEqual e1 e2)
-
-freeTheorem' env e1 e2 t'@(TyTuple ts)
-    = do
-        let len = length ts
-
-        fts <- mapM (\t -> do
-                let (t1,t2) = extractTypes env t
-                f <- makeVar "f"
-                x <- makeVar "x"
-                y <- makeVar "y"
-                th <- freeTheorem' env (EVar x) (EVar y) t
-                let eq = ThEqual (EApp (EVar f) (EVar x)) (EVar y)
-                return ((f,TyArr t1 t2),
-                        ThForall x t1 (
-                            ThForall y t2 (
-                                ThImplies th eq
-                            )
-                        )
-                    )
-            ) ts
-        let thf = ThEqual (EApp (foldl (\e ((f,_),_) -> EApp e (EVar f))
-                            (EBuiltin $ BMapTuple len) fts) e1) e2
-        return (foldr (\((f,t),e1) e2 -> ThForall f t (ThImplies e1 e2))
-                thf fts)
-
-freeTheorem' env e1 e2 t'@(TyVar v)
-    = do
-        let f = head [ f | (v',f,_,_) <- env, v' == v ]
-        return (ThEqual (EApp (EVar f) e1) e2)
-
-freeTheorem' env e1 e2 t'@(TyCons _ [])
-    = do
-        return (ThEqual e1 e2)
-
-freeTheorem' env e1 e2 t'@(TyCons c [t])
-    = do
-        f <- makeVar "f"
-        x <- makeVar "x"
-        y <- makeVar "y"
-        let (t1,t2) = extractTypes env t
-        p1 <- freeTheorem' env (EVar x) (EVar y) t
-        let p2 = ThEqual (EApp (EVar f) (EVar x)) (EVar y)
-        let p3 = ThEqual (EApp (EApp (EBuiltin (BMap c)) (EVar f)) e1) e2
-        return (ThForall f (TyArr t1 t2) (
-                ThImplies (ThForall x t1 (ThForall y t2 (ThImplies p1 p2)))
-                            p3))
-
-freeTheorem' env e1 e2 t'@(TyCons c@"Either" ts@[_,_])
-    = do
-        fts <- mapM (\t -> do
-                let (t1,t2) = extractTypes env t
-                f <- makeVar "f"
-                x <- makeVar "x"
-                y <- makeVar "y"
-                th <- freeTheorem' env (EVar x) (EVar y) t
-                let eq = ThEqual (EApp (EVar f) (EVar x)) (EVar y)
-                return ((f,TyArr t1 t2),
-                        ThForall x t1 (
-                            ThForall y t2 (
-                                ThImplies th eq
-                            )
-                        )
-                    )
-            ) ts
-        let thf = ThEqual (EApp (foldl (\e ((f,_),_) -> EApp e (EVar f))
-                            (EBuiltin $ BMap c) fts) e1) e2
-        return (foldr (\((f,t),e1) e2 -> ThForall f t (ThImplies e1 e2))
-                thf fts)
-
--- vim: ts=4:sts=4:expandtab:ai
− Plugin/Free/Parse.hs 
@@ -1,224 +0,0 @@-{-# OPTIONS -w #-}
-
-module Plugin.Free.Parse where
-
-import Control.Monad
-
-data Token
-    = QVarId String
-    | QConId String
-    | QVarSym String
-    | QConSym String
-    | OpenParen
-    | CloseParen
-    | Comma
-    | Semicolon
-    | OpenBracket
-    | CloseBracket
-    | BackQuote
-    | OpenBrace
-    | CloseBrace
-    | OpDotDot
-    | OpColon
-    | OpColonColon
-    | OpEquals
-    | OpBackslash
-    | OpPipe
-    | OpBackArrow
-    | OpArrow
-    | OpAt
-    | OpTilde
-    | OpImplies
-    | IdCase
-    | IdClass
-    | IdData
-    | IdDefault
-    | IdDeriving
-    | IdDo
-    | IdElse
-    | IdForall
-    | IdIf
-    | IdImport
-    | IdIn
-    | IdInfix
-    | IdInfixl
-    | IdInfixr
-    | IdInstance
-    | IdLet
-    | IdModule
-    | IdNewtype
-    | IdOf
-    | IdThen
-    | IdType
-    | IdWhere
-    | IdUscore
-    | TokError String
-        deriving (Show,Eq,Ord)
-
-data ParseResult a
-    = ParseSuccess a [Token]
-    | ParseError String
-        deriving (Show)
-
-newtype ParseS a = ParseS { parse :: [Token] -> ParseResult a }
-
-instance Monad ParseS where
-    return x = ParseS (\ts -> ParseSuccess x ts)
-    m >>= k = ParseS (\ts -> case parse m ts of
-                                ParseSuccess x ts' -> parse (k x) ts'
-                                ParseError s       -> ParseError s)
-    fail str = ParseS (\_ -> ParseError str)
-
-instance MonadPlus ParseS where
-    mzero = ParseS (\ts -> ParseError "parse error")
-    mplus m1 m2
-        = ParseS (\ts -> case parse m1 ts of
-                            res@(ParseSuccess _ _) -> res
-                            ParseError _           -> parse m2 ts)
-
-peekToken :: ParseS (Maybe Token)
-peekToken = ParseS (\ts -> case ts of
-                            []     -> ParseSuccess Nothing []
-                            (t':_) -> ParseSuccess (Just t') ts)
-
-getToken :: ParseS (Maybe Token)
-getToken = ParseS (\ts -> case ts of
-                            []     -> ParseSuccess Nothing []
-                            (t:ts) -> ParseSuccess (Just t) ts)
-
-match :: Token -> ParseS ()
-match m
-    = do
-        mt <- getToken
-        case mt of
-            Just t | t == m -> return ()
-            _               -> fail ("Expected " ++ show m)
-
-ascSymbol = ['!','#','$','%','&','*','+','.','/','<','=','>','?','@','\\',
-                '^','|','-','~']
-
-
-lexer :: String -> [Token]
-lexer []
-    = []
-lexer (' ':cs)
-    = lexer cs
-lexer ('\t':cs)
-    = lexer cs
-lexer ('\f':cs)
-    = lexer cs
-lexer ('\r':cs)
-    = lexer cs
-lexer ('\n':cs)
-    = lexer cs
-lexer ('\v':cs)
-    = lexer cs
-lexer ('-':'-':cs)
-    = lexerLineComment cs
-    where
-        lexerLineComment ('\r':'\n':cs) = lexer cs
-        lexerLineComment ('\r':cs) = lexer cs
-        lexerLineComment ('\n':cs) = lexer cs
-        lexerLineComment ('\f':cs) = lexer cs
-        lexerLineComment (c:cs) = lexerLineComment cs
-        lexerLineComment [] = []
-lexer ('{':'-':cs)
-    = lexerComment lexer cs
-    where
-        lexerComment k ('{':'-':cs) = lexerComment (lexerComment k) cs
-        lexerComment k ('-':'}':cs) = k cs
-        lexerComment k (_:cs) = lexerComment k cs
-        lexerComment k [] = [TokError "Unterminated comment"]
-lexer ('(':cs)
-    = OpenParen : lexer cs
-lexer (')':cs)
-    = CloseParen : lexer cs
-lexer (',':cs)
-    = Comma : lexer cs
-lexer ('[':cs)
-    = OpenBracket : lexer cs
-lexer (']':cs)
-    = CloseBracket : lexer cs
-lexer (c@':':cs)
-    = lexerConSym [c] cs
-    where
-        lexerConSym con (c:cs)                
-            | c == ':'
-                || c `elem` ascSymbol
-                = lexerConSym (c:con) cs
-        lexerConSym con cs
-            = case reverse con of
-                ":"  -> OpColon : lexer cs
-                "::" -> OpColonColon : lexer cs
-                con  -> QConSym con : lexer cs
-lexer (c:cs)
-    | c `elem` ['A'..'Z']
-        = lexerConId [c] cs
-    | c `elem` ['a'..'z'] || c == '_'
-        = lexerVarId [c] cs
-    | c `elem` ascSymbol
-        = lexerVarSym [c] cs
-    | otherwise
-        = [TokError "Illegal char"]
-        where
-            lexerConId con (c:cs)
-                | c `elem` ['A'..'Z']
-                    || c `elem` ['a'..'z']
-                    || c `elem` ['0'..'9']
-                    || c == '\''
-                    || c == '_'
-                        = lexerConId (c:con) cs
-            lexerConId con cs
-                = QConId (reverse con) : lexer cs
-
-            lexerVarId var (c:cs)
-                | c `elem` ['A'..'Z']
-                    || c `elem` ['a'..'z']
-                    || c `elem` ['0'..'9']
-                    || c == '\''
-                    || c == '_'
-                        = lexerVarId (c:var) cs
-            lexerVarId var cs
-                = case reverse var of
-                    "_"        -> IdUscore : lexer cs
-                    "case"     -> IdCase : lexer cs
-                    "class"    -> IdClass : lexer cs
-                    "data"     -> IdData : lexer cs
-                    "default"  -> IdDefault : lexer cs
-                    "deriving" -> IdDeriving : lexer cs
-                    "do"       -> IdDo : lexer cs
-                    "else"     -> IdElse : lexer cs
-                    "forall"   -> IdForall : lexer cs
-                    "if"       -> IdIf : lexer cs
-                    "import"   -> IdImport : lexer cs
-                    "in"       -> IdIn : lexer cs
-                    "infix"    -> IdInfix : lexer cs
-                    "infixl"   -> IdInfixl : lexer cs
-                    "infixr"   -> IdInfixr : lexer cs
-                    "instance" -> IdInstance : lexer cs
-                    "let"      -> IdLet : lexer cs
-                    "module"   -> IdModule : lexer cs
-                    "newtype"  -> IdNewtype : lexer cs
-                    "of"       -> IdOf : lexer cs
-                    "then"     -> IdThen : lexer cs
-                    "type"     -> IdType : lexer cs
-                    "where"    -> IdWhere : lexer cs
-                    v          -> QVarId v : lexer cs
-
-            lexerVarSym var (c:cs)
-                | c == ':' || c `elem` ascSymbol
-                    = lexerVarSym (c:var) cs
-            lexerVarSym var cs
-                = case reverse var of
-                    ".."    -> OpDotDot : lexer cs
-                    "="     -> OpEquals : lexer cs
-                    "\\"    -> OpBackslash : lexer cs
-                    "|"     -> OpPipe : lexer cs
-                    "<-"    -> OpBackArrow : lexer cs
-                    "->"    -> OpArrow : lexer cs
-                    "@"     -> OpAt : lexer cs
-                    "~"     -> OpTilde : lexer cs
-                    "=>"    -> OpImplies : lexer cs
-                    var     -> QVarSym var : lexer cs
-
--- vim: ts=4:sts=4:expandtab:ai
− Plugin/Free/Test.hs 
@@ -1,54 +0,0 @@-module Plugin.Free.Test where
-
-import Plugin.Free.FreeTheorem
-import Plugin.Free.Type
-
-
-tUndef = "undefined :: a -> a"
-
-tMzero = "mzero :: [a]"
-
-tReturnList = "return :: a -> [a]"
-
-tHead = "head :: [a] -> a"
-
-tTail = "tail :: [a] -> [a]"
-
-tId = "id :: a -> a"
-
-tConst = "const :: a -> b -> a"
-
-tIdPair = "id :: (a,b) -> (a,b)"
-
-tSwap = "swap :: (a,b) -> (b,a)"
-
-tGenSwap = "genSwap :: (forall z. a -> b -> z) -> (forall z. b -> a -> z)"
-
-tMap = "map :: (a -> b) -> ([a] -> [b])"
-
-tZip = "zip :: ([a],[b]) -> [(a,b)]"
-
-tIdFun = "id :: (a -> b) -> (a -> b)"
-
-tFst = "fst :: (a,b) -> a"
-
-tFstFun = "fst :: (a->b,c) -> a -> b"
-
-tSnd = "snd :: (a,b) -> b"
-
-
-tContinuation :: Type -> Type
-tContinuation a
-    = TyForall "R" (TyArr (TyArr a r) r)
-    where
-        r = TyVar "R"
-
-tReturnC = "return :: a -> (forall r. (a -> r) -> r)"
-
-tCallCC = "callcc :: ((a -> (forall r. (b -> r) -> r)) -> (forall r. (a -> r) -> r)) -> (forall r. (a -> r) -> r)"
-
-tPierce = "pierce :: ((a -> b) -> a) -> a"
-
-tNot = "not :: (forall z. z -> z -> z) -> (forall z. z -> z -> z)"
-
--- vim: ts=4:sts=4:expandtab:ai
− Plugin/Free/Theorem.hs 
@@ -1,190 +0,0 @@-{-# OPTIONS -w #-}
-
-module Plugin.Free.Theorem where
-
-import Plugin.Free.Type
-import Plugin.Free.Expr
-import Plugin.Free.Util
-
-data Theorem
-    = ThForall Var Type Theorem
-    | ThImplies Theorem Theorem
-    | ThEqual Expr Expr
-    | ThAnd Theorem Theorem
-        deriving (Eq,Show)
-
-precIMPLIES, precAND :: Int
-precIMPLIES = 5
-precAND = 3
-
-instance Pretty Theorem where
-    prettyP p t = prettyTheorem p False t
-
-
-prettyTheorem :: Int -> Bool -> Theorem -> Doc
-prettyTheorem p fa th@(ThForall v t p1)
-    | fa        = prettyForall p [v] p1
-    | otherwise = prettyP p p1
-prettyTheorem p fa (ThImplies p1 p2)
-    = prettyParenIndent (p > precIMPLIES) (
-        prettyTheorem (precIMPLIES+1) True p1
-        $$ nest (-1) (text "=>")
-        $$ prettyTheorem precIMPLIES fa p2
-    )
-prettyTheorem _ _ (ThEqual e1 e2)
-    = prettyP 0 e1 <+> text "=" <+> prettyP 0 e2
-prettyTheorem p fa (ThAnd e1 e2)
-    = prettyParenIndent (p > precAND) (
-        prettyTheorem (precAND+1) fa e1 $$ text "&&"
-        $$ prettyTheorem precAND fa e2
-    )
-
-prettyForall :: Int -> [Var] -> Theorem -> Doc
-prettyForall p vs (ThForall v t p1)
-    = prettyForall p (v:vs) p1
-prettyForall p vs th
-    = parens (
-        text "forall" <+> hsep [ text v | v <- reverse vs ] <> text "."
-        <+> prettyTheorem 0 True th
-    )
-
-varInTheorem :: Var -> Theorem -> Bool
-varInTheorem v (ThForall v' t p)
-    = v /= v' && varInTheorem v p
-varInTheorem v (ThImplies p1 p2)
-    = varInTheorem v p1 || varInTheorem v p2
-varInTheorem v (ThEqual e1 e2)
-    = varInExpr v e1 || varInExpr v e2
-varInTheorem v (ThAnd e1 e2)
-    = varInTheorem v e1 || varInTheorem v e2
-
-applySimplifierTheorem :: (Theorem -> Theorem) -> (Theorem -> Theorem)
-applySimplifierTheorem s (ThForall v t p)
-    = ThForall v t (s p)
-applySimplifierTheorem s (ThImplies p1 p2)
-    = ThImplies (s p1) (s p2)
-applySimplifierTheorem s p@(ThEqual _ _)
-    = p
-applySimplifierTheorem s p@(ThAnd p1 p2)
-    = ThAnd (s p1) (s p2)
-
-peepholeSimplifyTheorem :: Theorem -> Theorem
-peepholeSimplifyTheorem
-    = peepholeSimplifyTheorem' . applySimplifierTheorem peepholeSimplifyTheorem
-
-peepholeSimplifyTheorem' :: Theorem -> Theorem
-peepholeSimplifyTheorem' (ThForall v t p)
-    = case varInTheorem v p of
-            True  -> ThForall v t p
-            False -> p
-peepholeSimplifyTheorem' p@(ThAnd e1 e2)
-    = foldr1 ThAnd (flattenAnd e1 . flattenAnd e2 $ [])
-    where
-        flattenAnd (ThAnd e1 e2) = flattenAnd e1 . flattenAnd e2
-        flattenAnd e = (e:)
-peepholeSimplifyTheorem' p
-    = p
-
-peepholeSimplifyExpr :: Expr -> Expr
-peepholeSimplifyExpr
-    = peepholeSimplifyExpr' . applySimplifierExpr peepholeSimplifyExpr
-
-peepholeSimplifyExpr' :: Expr -> Expr
-peepholeSimplifyExpr' (EApp (EBuiltin BId) e2)
-    = e2
-peepholeSimplifyExpr' (EApp (EBuiltin (BMap _)) (EBuiltin BId))
-    = EBuiltin BId
-peepholeSimplifyExpr' e
-    = e
-
-foldEquality :: Theorem -> Theorem
-foldEquality p@(ThForall _ _ _)
-    = case foldEquality' p [] of
-        Just p' -> p'
-        Nothing -> applySimplifierTheorem foldEquality p
-    where
-        foldEquality' (ThForall v t p) vts
-            = foldEquality' p ((v,t):vts)
-        foldEquality' (ThImplies (ThEqual (EVar v) e2) p) vts
-            | v `elem` map fst vts
-                = foldEquality'' vts (theoremSubst v e2 p)
-        foldEquality' (ThImplies (ThEqual e1 (EVar v)) p) vts
-            | v `elem` map fst vts
-                = foldEquality'' vts (theoremSubst v e1 p)
-        foldEquality' _ vts
-            = Nothing
-
-        foldEquality'' [] e
-            = Just e
-        foldEquality'' ((v,t):vts) e
-            = foldEquality'' vts (ThForall v t e)
-
-foldEquality p
-    = applySimplifierTheorem foldEquality p
-
-tryCurrying :: Theorem -> Theorem
-tryCurrying p@(ThForall _ _ _)
-    = case tryCurrying' p [] of
-        Just p' -> p'
-        Nothing -> applySimplifierTheorem tryCurrying p
-    where
-        tryCurrying' (ThForall v t p) vts
-            = tryCurrying' p ((v,t):vts)
-        tryCurrying' (ThEqual e1 e2) vts
-            = case (traverseRight ECDot e1, traverseRight ECDot e2) of
-                ((ctx1, EVar v1), (ctx2, EVar v2))
-                    | v1 == v2 && v1 `elem` map fst vts
-                        && not (varInCtx v1 ctx1) && not (varInCtx v2 ctx2)
-                        -> tryCurrying'' vts (ThEqual (untraverse ctx1)
-                                                      (untraverse ctx2))
-                _       -> Nothing
-        tryCurrying' _ _
-            = Nothing
-
-        traverseRight ctx (EApp e1 e2)
-            = traverseRight (ECAppR e1 ctx) e2
-        traverseRight ctx e
-            = (ctx, e)
-
-        untraverse ECDot = EBuiltin BId
-        untraverse (ECAppR e1 ECDot)
-            = e1
-        untraverse (ECAppR e1 ctx)
-            = EApp (EApp (EVarOp FR 9 ".") (untraverse ctx)) e1
-        tryCurrying'' [] e
-            = Just e
-        tryCurrying'' ((v,t):vts) e
-            = tryCurrying'' vts (ThForall v t e)
-
-tryCurrying p
-    = applySimplifierTheorem tryCurrying p
-
-theoremSimplify :: Theorem -> Theorem
-theoremSimplify
-    = iterateUntilFixpoint
-        (foldEquality
-        . iterateUntilFixpoint peephole
-        . tryCurrying
-        . iterateUntilFixpoint peephole
-        )
-    where
-        iterateUntilFixpoint s t
-            = findFixpoint (iterate s t)
-
-        peephole t = findFixpoint (iterate peepholeSimplifyTheorem t)
-
-        findFixpoint (x1:xs@(x2:_))
-            | x1 == x2  = x2
-            | otherwise = findFixpoint xs
-
-theoremSubst :: Var -> Expr -> Theorem -> Theorem
-theoremSubst v e (ThForall f t p)
-    = ThForall f t (theoremSubst v e p)
-theoremSubst v e (ThImplies p1 p2)
-    = ThImplies (theoremSubst v e p1) (theoremSubst v e p2)
-theoremSubst v e (ThEqual e1 e2)
-    = ThEqual (exprSubst v e e1) (exprSubst v e e2)
-theoremSubst v e (ThAnd p1 p2)
-    = ThAnd (theoremSubst v e p1) (theoremSubst v e p2)
-
--- vim: ts=4:sts=4:expandtab:ai
− Plugin/Free/Type.hs 
@@ -1,222 +0,0 @@-{-# OPTIONS -w #-}
-
-module Plugin.Free.Type where
-
-import Control.Monad
-import Plugin.Free.Parse
-import Data.List
-import Plugin.Free.Util
-
-type TyVar = String
-type TyName = String
-
-data Type
-    = TyForall TyVar Type
-    | TyArr Type Type
-    | TyTuple [Type]
-    | TyCons TyName [Type]
-    | TyVar TyVar
-        deriving (Eq, Show)
-
-precTYAPP, precARROW :: Int
-precTYAPP = 11
-precARROW = 10
-
-instance Pretty Type where
-    prettyP p (TyForall v t)
-        = prettyParen (p > 0) (
-            text "forall" <+> text v <> text "." <+> prettyP 0 t
-        )
-    prettyP p (TyArr t1 t2)
-        = prettyParen (p > precARROW) (
-            prettyP (precARROW+1) t1 <+> text "->" <+> prettyP precARROW t2
-        )
-    prettyP _ (TyTuple [])
-        = parens empty
-    prettyP _ (TyTuple (t:ts))
-        = parens (prettyP 0 t <> prettyTs 0 (text ",") ts)
-    prettyP _ (TyCons "[]" [t])
-        = lbrack <> prettyP 0 t <> rbrack
-    prettyP p (TyCons cons ts)
-        = prettyParen (p > precTYAPP) (
-            text cons <> prettyTs (precTYAPP+1) empty ts
-        )
-    prettyP _ (TyVar v)
-        = text v
-
-prettyTs :: Int -> Doc -> [Type] -> Doc
-prettyTs p c [] = empty
-prettyTs p c (t:ts) = c <+> prettyP p t <> prettyTs p c ts
-
-
-parseType :: ParseS Type
-parseType
-    = parseType' >>= return . normaliseType
-
-parseType' :: ParseS Type
-parseType'
-    = do
-        t <- peekToken
-        case t of
-            Just IdForall -> getToken >> parseForall
-            _             -> parseArrType
-    where
-        parseForall
-            = do
-                t <- getToken
-                case t of
-                    Just (QVarId v)
-                        -> parseForall >>= \t -> return (TyForall v t)
-                    Just (QVarSym ".")
-                        -> parseType'
-                    _   -> fail "Expected variable or '.'"
-
-        parseArrType
-            = do
-                t1 <- parseBType
-                t <- peekToken
-                case t of
-                    Just OpArrow
-                        -> getToken >> parseType' >>= \t2 ->
-                            return (TyArr t1 t2)
-                    _   -> return t1
-
-        parseBType
-            = do
-                t1 <- parseAType
-                case t1 of
-                    TyCons c ts
-                        -> do
-                            ts' <- parseBTypes
-                            return (TyCons c (ts++ts'))
-                    _   -> return t1
-
-        parseBTypes
-            = (parseBType >>= \t -> parseBTypes >>= \ts -> return (t:ts))
-                `mplus` return []
-
-        parseAType
-            = parseQTyCon `mplus` parseOtherAType
-
-        parseQTyCon
-            = do
-                t <- getToken
-                case t of
-                    Just OpenParen
-                        -> do
-                            t <- getToken
-                            case t of
-                                Just CloseParen
-                                    -> return (TyCons "()" [])
-                                Just OpArrow
-                                    -> match CloseParen
-                                        >> return (TyCons "->" [])
-                                Just Comma
-                                    -> parseQTyConTuple 1
-                                _   -> fail "Badly formed type constructor"
-                    Just OpenBracket
-                        -> match CloseBracket >> return (TyCons "[]" [])
-                    Just (QConId v)
-                        -> return (TyCons v [])
-                    _   -> fail "Badly formed type constructor"
-
-        parseQTyConTuple :: Int -> ParseS Type
-        parseQTyConTuple i
-            = do
-                t <- getToken
-                case t of
-                    Just Comma
-                        -> parseQTyConTuple (i+1)
-                    Just CloseParen
-                        -> return (TyCons ("(" ++ take i (repeat ',') ++ ")") [])
-                    _   -> fail "Badly formed type constructor"
-
-        parseOtherAType
-            = do
-                t1 <- getToken
-                case t1 of
-                    Just OpenParen
-                        -> do
-                            t <- parseType'
-                            parseTuple [t]
-                    Just OpenBracket
-                        -> parseType' >>= \t -> match CloseBracket
-                                        >> return (TyCons "[]" [t])
-                    Just (QVarId v)
-                        -> return (TyVar v)
-                    _   -> fail "Badly formed type"
-
-        parseTuple ts
-            = do
-                t1 <- getToken
-                case t1 of
-                    Just CloseParen
-                        -> case ts of
-                                [t] -> return t
-                                _   -> return (TyTuple (reverse ts))
-                    Just Comma
-                        -> do
-                            t <- parseType'
-                            parseTuple (t:ts)
-
-normaliseType :: Type -> Type
-normaliseType t
-    = let (fvs,nt) = normaliseType' t
-      in foldr TyForall nt (nub fvs)
-    where
-        normaliseType' t@(TyVar v)
-            = ([v],t)
-        normaliseType' (TyForall v t')
-            = let (fvs,t) = normaliseType' t'
-              in (filter (/=v) fvs, TyForall v t)
-        normaliseType' (TyArr t1 t2)
-            = let
-                (fvs1,t1') = normaliseType' t1
-                (fvs2,t2') = normaliseType' t2
-              in
-                (fvs1++fvs2, TyArr t1' t2')
-        normaliseType' (TyTuple ts)
-            = let
-                fvsts = map normaliseType' ts
-                fvs = concat (map fst fvsts)
-                ts' = map snd fvsts
-              in (fvs, TyTuple ts')
-        normaliseType' (TyCons c ts)
-            = let
-                fvsts = map normaliseType' ts
-                fvs = concat (map fst fvsts)
-                ts' = map snd fvsts
-              in case c of
-                    "->" -> case ts' of
-                        [t1,t2] -> (fvs, TyArr t1 t2)
-                        _ -> error "Arrow type should have 2 arguments"
-                    _ -> case checkTuple c of
-                        Just i
-                            -> if i == length ts'
-                                then (fvs, TyTuple ts')
-                                else error "Tuple type has the wrong number of arguments"
-                        Nothing
-                            -> (fvs, TyCons c ts')
-
-        checkTuple ('(':')':cs)
-            = Just 0
-        checkTuple ('(':cs)
-            = checkTuple' 1 cs
-        checkTuple _
-            = Nothing
-
-        checkTuple' k ")"
-            = Just k
-        checkTuple' k (',':cs)
-            = checkTuple' (k+1) cs
-        checkTuple' _ _
-            = Nothing
-
-readType :: String -> Type
-readType s
-    = case parse parseType (lexer s) of
-        ParseSuccess t [] -> t
-        ParseSuccess t _  -> error "Extra stuff at end of type"
-        ParseError msg    -> error msg
-
--- vim: ts=4:sts=4:expandtab:ai
− Plugin/Free/Util.hs 
@@ -1,30 +0,0 @@-module Plugin.Free.Util (
-    Pretty(..),
-    prettyParen,
-    prettyParenIndent,
-    module Text.PrettyPrint.HughesPJ
-) where
-
-
-import Text.PrettyPrint.HughesPJ
-
-
-class Pretty a where
-    prettyP :: Int -> a -> Doc
-
-    pretty :: a -> Doc
-    pretty x = prettyP 0 x
-
-
-prettyParen :: Bool -> Doc -> Doc
-prettyParen b doc
-    = if b then parens doc else doc
-
-prettyParenIndent :: Bool -> Doc -> Doc
-prettyParenIndent b doc
-    = if b
-      then vcat [lparen, nest 2 doc, rparen]
-      else doc
-
-
--- vim: ts=4:sts=4:expandtab
− Plugin/Fresh.hs 
@@ -1,26 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}---- | Haskell project name generation--- semi-joke-module Plugin.Fresh (theModule) where--import Plugin--$(plugin "Fresh")--instance Module FreshModule Integer where-    moduleCmds      _ = ["freshname"]-    moduleHelp    _ _ = "freshname. Return a unique Haskell project name."-    moduleDefState  _ = return 0-    moduleSerialize _ = Just stdSerial-    process_ _ _ _    = withMS $ \n f -> do-                            f (n+1)-                            return ["Ha" ++ reverse (freshname n)]--freshname :: Integer -> String-freshname i-    | i == 0    = [chr (ord 'a')]-    | r == 0    = [chr (ord 'a' + (fromIntegral a))]-    | otherwise =  chr (ord 'a' + (fromIntegral a)) : freshname r-    where-      (r,a) = i `quotRem` 26
− Plugin/Haddock.hs 
@@ -1,29 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeSynonymInstances #-}--- | Hackish Haddock module.-module Plugin.Haddock (theModule) where--import Plugin--import qualified Data.Map as M-import qualified Data.ByteString.Char8 as P-import Data.ByteString.Char8 (ByteString,pack)--$(plugin "Haddock")--type HaddockState = M.Map ByteString [ByteString]--instance Module HaddockModule HaddockState where-    moduleCmds      _ = ["index"]-    moduleHelp    _ _ = "index <ident>. Returns the Haskell modules in which <ident> is defined"-    moduleDefState  _ = return M.empty-    moduleSerialize _ = Just (readOnly readPacked)-    fprocess_ _ _ k = readMS >>= \m -> box $ maybe-        (pack "bzzt")-        (P.intercalate (pack ", "))-        (M.lookup (stripPs k) m)--        where-          -- make \@index ($) work.-          stripPs :: ByteString -> ByteString-          stripPs = fst . P.spanEnd (==')') . snd . P.span (=='(')-
− Plugin/Hello.hs 
@@ -1,12 +0,0 @@------ | Hello world plugin----module Plugin.Hello where--$(plugin "Hello")--instance Module Hello () where-    moduleCmds _  = ["hello","goodbye"]-    moduleHelp _  = "hello/goodbye <arg>. Simplest possible plugin"-    process_ _ xs = return ["Hello world. " ++ xs]-
− Plugin/Help.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}--- | Provide help for plugins-module Plugin.Help (theModule) where--import Plugin-import Control.OldException (Exception(..), evaluate)--$(plugin "Help")--instance Module HelpModule () where-    moduleHelp _ _ = "help <command>. Ask for help for <command>. Try 'list' for all commands"-    moduleCmds   _ = ["help"]-    process_ _ cmd rest = lift $ doHelp cmd rest--doHelp :: String -> [Char] -> LB [String]-doHelp cmd [] = doHelp cmd "help"------- If a target is a command, find the associated help, otherwise if it's--- a module, return a list of commands that module implements.----doHelp cmd rest =-    withModule ircCommands arg                  -- see if it is a command-        (withModule ircModules arg              -- else maybe it's a module name-            (doHelp cmd "help")                 -- else give up-            (\md -> do -- its a module-                let ss = moduleCmds md-                let s | null ss   = arg ++ " is a module."-                      | otherwise = arg ++ " provides: " ++ showClean ss-                return [s]))--        -- so it's a valid command, try to find its help-        (\md -> do-            s <- catchError (liftIO $ evaluate $ moduleHelp md arg) $ \e ->-                case e of-                    IRCRaised (NoMethodError _) -> return "This command is unknown."-                    _                           -> throwError e-            return [s])--    where (arg:_) = words rest
− Plugin/Hoogle.hs 
@@ -1,62 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeSynonymInstances #-}---- 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 Plugin.Hoogle (theModule) where--import Plugin--$(plugin "Hoogle")--type HoogleState = [String]--instance Module HoogleModule HoogleState where-    moduleDefState _ = return []-    moduleCmds   _ = ["hoogle", "hoogle+"]-    moduleHelp _ _ = "hoogle <expr>. Haskell API Search for either names, or types."--    process_ _ "hoogle" s = do-        o <- io (hoogle s)-        let (this,that) = splitAt 3 o-        writeMS that-        return [unlines this]--    process_ _ "hoogle+" _ = do-        this <- withMS $ \st write -> do-                        let (this,that) = splitAt 3 st-                        write that-                        return this-        return [unlines this]----------------------------------------------------------------------------hoogleBinary :: FilePath-hoogleBinary = "hoogle"---- arbitrary cutoff point-cutoff :: Int-cutoff = -10---- | Actually run the hoogle binary-hoogle :: String -> IO [String]-hoogle s = do-        let args = ["--count=20", s]-        (out,err,_) <- popen hoogleBinary args (Just "")-        return $ result out err--    where result [] [] = ["A Hoogle error occurred."]-          result [] ys = [ys]-          result xs _  =-                let xs' = map toPair $ lines xs-                    res = map snd $ filter ((>=cutoff) . fst) xs'-                in if null res-                   then ["No matches, try a more general search"]-                   else res--          toPair s' = let (res, meta)  = break (=='@') s'-                          rank = takeWhile (/=' ') . drop 2 $ meta-                      in case readM rank :: Maybe Int of-                         Just n  -> (n,res)-                         Nothing -> (0,res)
− Plugin/IRC.hs 
@@ -1,136 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}--- | The plugin-level IRC interface.--module Plugin.IRC (theModule) where--import Control.Concurrent( forkIO, newQSem, waitQSem, threadDelay, signalQSem,-                           newEmptyMVar, putMVar, takeMVar, MVar )-import Control.OldException-import IRCBase-import LMain( received )-import Message-import Network( connectTo, PortID(..) )-import Plugin-import System.IO (hGetLine, hPutStr, hPutStrLn, hSetBuffering, BufferMode(NoBuffering), stderr, hClose)-import qualified Data.ByteString.Char8 as P--$(plugin "IRC")--instance Module IRCModule () where-    modulePrivs  _         = ["irc-connect"]-    moduleHelp _ _         = "irc-connect tag host portnum nickname userinfo.  connect to an irc server"-    process_ _ "irc-connect" rest =-        case (split " " rest) of-          tag:hostn:portn:nickn:uix -> do pn <- (PortNumber . fromInteger) `fmap` readM portn-                                          online tag hostn pn nickn (concatWith " " uix)-                                          return []-          _                         -> return ["Not enough parameters!"]--------------------------------------------------------------------------- Encoding and decoding of messages---- | 'encodeMessage' takes a message and converts it to a function.---   giving this function a string will attach the string to the message---   and output a string containing IRC protocol commands ready for writing---   on the outgoing stream socket.-encodeMessage :: IrcMessage -> String -> String-encodeMessage msg-  = encodePrefix (msgPrefix msg) . encodeCommand (msgCommand msg)-          . encodeParams (msgParams msg)-  where-    encodePrefix [] = id-    encodePrefix prefix = showChar ':' . showString prefix . showChar ' '--    encodeCommand cmd = showString cmd--    encodeParams [] = id-    encodeParams (p:ps) = showChar ' ' . showString p . encodeParams ps---- | 'decodeMessage' Takes an input line from the IRC protocol stream---   and decodes it into a message.  FIXME: this has too many parameters.-decodeMessage :: String -> String -> String -> IrcMessage-decodeMessage svr lbn line =-    let (prefix, rest1) = decodePrefix (,) line-        (cmd, rest2)    = decodeCmd (,) rest1-        params          = decodeParams rest2-    in IrcMessage { msgServer = svr, msgLBName = lbn, msgPrefix = prefix,-                    msgCommand = cmd, msgParams = params }-  where-    decodePrefix k (':':cs) = decodePrefix' k cs-      where decodePrefix' j ""       = j "" ""-            decodePrefix' j (' ':ds) = j "" ds-            decodePrefix' j (c:ds)   = decodePrefix' (j . (c:)) ds--    decodePrefix k cs = k "" cs--    decodeCmd k []       = k "" ""-    decodeCmd k (' ':cs) = k "" cs-    decodeCmd k (c:cs)   = decodeCmd (k . (c:)) cs--    decodeParams :: String -> [String]-    decodeParams xs = decodeParams' [] [] xs-      where-        decodeParams' param params []-          | null param = reverse params-          | otherwise  = reverse (reverse param : params)-        decodeParams' param params (' ' : cs)-          | null param = decodeParams' [] params cs-          | otherwise  = decodeParams' [] (reverse param : params) cs-        decodeParams' param params rest@(c@':' : cs)-          | null param = reverse (rest : params)-          | otherwise  = decodeParams' (c:param) params cs-        decodeParams' param params (c:cs) = decodeParams' (c:param) params cs--ircSignOn :: String -> Nick -> String -> LB ()-ircSignOn svr nickn ircname = do-    send $ user (nTag nickn) (nName nickn) svr ircname-    send $ setNick nickn-------------------------------------------------------------------------------- Lambdabot is mostly synchronous.  We have a main loop, which reads--- messages and forks threads to execute commands (which write responces).--- OR--- We have a main loop which reads offline commands, and synchronously--- interprets them.--online :: String -> String -> PortID -> String -> String -> ModuleT () LB ()-online tag hostn portnum nickn ui = do-  sock <- io $ connectTo hostn portnum-  io $ hSetBuffering sock NoBuffering-  -- Implements flood control: RFC 2813, section 5.8-  sem1 <- io $ newQSem 0-  sem2 <- io $ newQSem 4 -- one extra token stays in the MVar-  sendmv <- io $ newEmptyMVar-  io $ forkIO $ sequence_ $ repeat $ do-    waitQSem sem1-    threadDelay 2000000-    signalQSem sem2-  io $ forkIO $ sequence_ $ repeat $ do-    waitQSem sem2-    putMVar sendmv ()-    signalQSem sem1-  catchError (addServer tag $ io . sendMsg tag sock sendmv)-             (\err -> io (hClose sock) >> throwError err)-  lift $ ircSignOn hostn (Nick tag nickn) ui-  lift $ liftLB forkIO $ catchError (readerLoop tag nickn sock)-                                   (\e -> do io $ hPutStrLn stderr $ "irc[" ++ tag ++ "] error: " ++ show e-                                             remServer tag)-  return ()--readerLoop :: String -> String -> Handle -> LB ()-readerLoop tag nickn sock = do-  line <- io $ hGetLine sock-  let line' = filter (\c -> c /= '\n' && c /= '\r') line-  if "PING " `isPrefixOf` line'-      then io $ hPutStr sock ("PONG " ++ drop 5 line' ++ "\r\n")-      else do forkLB $ received (decodeMessage tag nickn line')-              return ()-  readerLoop tag nickn sock--sendMsg :: String -> Handle -> MVar () -> IrcMessage -> IO ()-sendMsg tag sock mv msg =-    catchJust ioErrors (do takeMVar mv-                           P.hPut sock $ P.pack $ encodeMessage msg "\r\n")-                  (\err -> do hPutStrLn stderr $ "irc[" ++ tag ++ "] error: " ++ show err-                              hClose sock)
− Plugin/Instances.hs 
@@ -1,136 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}-{- | 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 Plugin.Instances where--import Text.ParserCombinators.Parsec--import Plugin--type Instance   = String-type ClassName  = String-type ModuleName = String--$(plugin "Instances")--instance Module InstancesModule () where-    moduleCmds _ = map fst help-    moduleHelp _ = fromJust . flip lookup help-    process_ _ "instances"           cls  = lift $ fetchInstances cls-    process_ _ "instances-importing" args = lift $ fetchInstancesImporting args---- | Lookup table for the help for this module-help :: [(String, String)]-help = [("instances",-          "instances <typeclass>. Fetch the instances of a typeclass."),-        ("instances-importing",-          "instances-importing [<module> [<module> [<module...]]] <typeclass>. " ++-          "Fetch the instances of a typeclass, importing specified modules first.")]---- | 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 = do string "instance "-                   try constrained <|> unconstrained-                   skipMany space-                   -- break on the "imported from" comment or a newline. use-                   -- return so it typechecks.-                   let end = try (string "--") <|> (eof >> return " ")-                   anyChar `manyTill` end-    where constrained   = noneOf "=" `manyTill` string ("=> " ++ cls)-          unconstrained = string cls---- | Wrapper for the instance parser.-parseInstance :: ClassName -> String -> Maybe Instance-parseInstance cls = fmap dropSpace . 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   = matches' (regex' $ "class.*" ++ cls ++ ".*where") s-          splut        = split "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 :: ClassName -> LB [String]-fetchInstances cls =  do-    ios (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 :: String -> LB [String]-fetchInstancesImporting args = ios (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' :: String -> [ModuleName] -> IO String-fetchInstances' cls mdls = do-  let s = unlines [cxt, command]-  (out, err, _) <- popen (ghci config) ["-ignore-dot-ghci","-fglasgow-exts"] $-                   Just s-  let is = getInstances out cls-  return $ if null is-             then err-             else concatWith ", " is-  where cxt     = ":m " ++ unwords mdls-        command = ":i " ++ cls
− Plugin/Karma.hs 
@@ -1,89 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeSynonymInstances #-}--- | Karma-module Plugin.Karma (theModule) where--import Plugin-import qualified Message as Msg (nick, Nick, Message, showNick, readNick, lambdabotName, nName)-import qualified NickEq as E-import qualified Data.Map as M-import Text.Printf--$(plugin "Karma")--type KarmaState = M.Map Msg.Nick Integer-type Karma m a = ModuleT KarmaState m a--instance Module KarmaModule KarmaState where--    moduleCmds _ = ["karma", "karma+", "karma-", "karma-all"]-    moduleHelp _ "karma"     = "karma <polynick>. Return a person's karma value"-    moduleHelp _ "karma+"    = "karma+ <nick>. Increment someone's karma"-    moduleHelp _ "karma-"    = "karma- <nick>. Decrement someone's karma"-    moduleHelp _ "karma-all" = "karma-all. List all karma"--    moduleDefState  _ = return $ M.empty-    moduleSerialize _ = Just mapSerial--    process      _ _ _ "karma-all" _ = listKarma-    process      _ msg _ "karma" rest = tellKarma msg sender nick'-        where sender = Msg.nick msg-              nick' = case words rest of-                        []       -> E.mononickToPolynick sender-                        (nick:_) -> E.readPolynick msg nick-    process      _ msg _ cmd rest =-        case words rest of-          []       -> return [ "usage @karma(+|-) nick" ]-          (nick:_) -> do-              let nick' = Msg.readNick msg nick-              case cmd of-                 "karma+"    -> changeKarma msg 1    sender nick'-                 "karma-"    -> changeKarma msg (-1) sender nick'-                 _        -> error "KarmaModule: can't happen"-        where sender = Msg.nick msg--    -- ^nick++($| )-    contextual   _ msg _ text = do-        mapM_ (changeKarma msg (-1) sender) decs-        mapM_ (changeKarma msg   1  sender) incs-        return []-      where-        sender      = Msg.nick msg-        ws          = words text-        decs        = match "--"-        incs        = match "++"-        match m     = map (Msg.readNick msg) . filter okay . map (reverse . drop 2)-                    . filter (isPrefixOf m) . map reverse $ ws-        okay x      = not (elem x badNicks || any (`isPrefixOf` x) badPrefixes)-        -- Special cases.  Ignore the null nick.  C must also be ignored-        -- because C++ and C-- are languages.-        badNicks    = ["", "C", "c", "notepad"]-        -- More special cases, to ignore Perl code.-        badPrefixes = ["$", "@", "%"]----------------------------------------------------------------------------tellKarma :: Msg.Message m => m -> Msg.Nick -> E.Polynick -> Karma LB [String]-tellKarma msg sender nick = do-    lookup' <- lift E.lookupMononickMap-    karma <- (sum . map snd . lookup' nick) `fmap` readMS-    return [concat [if E.mononickToPolynick sender == nick then "You have" else E.showPolynick msg nick ++ " has"-                   ," a karma of "-                   ,show karma]]--listKarma :: Karma LB [String]-listKarma = do-    ks <- M.toList `fmap` readMS-    let ks' = sortBy (\(_,e) (_,e') -> e' `compare` e) ks-    return $ (:[]) . unlines $ map (\(k,e) -> printf " %-20s %4d" (show k) e :: String) ks'--changeKarma :: Msg.Message m => m -> Integer -> Msg.Nick -> Msg.Nick -> Karma LB [String]-changeKarma msg km sender nick-  | map toLower (Msg.nName nick) == "java" && km == 1 = changeKarma msg (-km) (Msg.lambdabotName msg) sender-  | sender == nick = return ["You can't change your own karma, silly."]-  | otherwise      = withMS $ \fm write -> do-      let fm' = M.insertWith (+) nick km fm-      let karma = fromMaybe 0 $ M.lookup nick fm'-      write fm'-      return [fmt (Msg.showNick msg nick) km (show karma)]-          where fmt n v k | v < 0     = n ++ "'s karma lowered to " ++ k ++ "."-                          | otherwise = n ++ "'s karma raised to " ++ k ++ "."
− Plugin/Localtime.hs 
@@ -1,53 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeSynonymInstances #-}--- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons--- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)---- | Simple wrapper over privmsg to get time information via the CTCP-module Plugin.Localtime (theModule) where--import Plugin-import qualified Data.Map as M-import qualified Message as Msg--$(plugin "Localtime")--type TimeMap = M.Map Msg.Nick  -- the person who's time we requested-                    [Msg.Nick] -- a list of targets waiting on this time--instance Module LocaltimeModule TimeMap where--  moduleHelp _ _      = "time <user>. Print a user's local time. User's client must support ctcp pings."-  moduleCmds   _      = ["time", "localtime", "localtime-reply"]-  moduleDefState _    = return M.empty--  -- synonym-  process x y z "time" a = process x y z "localtime" a--  -- record this person as a callback, for when we (asynchronously) get a result-  process m msg whoAsked "localtime" []     = do-    let n = Msg.nName (Msg.nick msg)-    process m msg whoAsked "localtime" n--  process _ msg whoAsked "localtime" rawWho = do-    let whoToPing = Msg.readNick msg $ fst $ break (== ' ') rawWho-    if whoToPing /= Msg.lambdabotName msg-        then do modifyMS $ \st -> M.insertWith (++) whoToPing [whoAsked] st-            -- this is a CTCP time call, which returns a NOTICE-                lift $ ircPrivmsg' whoToPing ("\^ATIME\^A")     -- has to be raw-                return []-        else return ["I live on the internet, do you expect me to have a local time?"]--  -- the Base module caught the NOTICE TIME, mapped it to a PRIVMGS, and here it is :)-  process _ msg _ "localtime-reply" text = do-    let (whoGotPinged', time') = break (== ':') text-        whoGotPinged = Msg.readNick msg whoGotPinged'-        time = drop 1 time'--    targets <- withMS $ \st set -> do-        case M.lookup whoGotPinged st of-            Nothing -> return []-            Just xs -> do set (M.insert whoGotPinged [] st) -- clear the callback state-                          return xs-    let txt = "Local time for " ++ Msg.showNick msg whoGotPinged ++ " is " ++ time-    lift $ flip mapM_ targets $ flip ircPrivmsg' txt-    return []
− Plugin/Log.hs 
@@ -1,236 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-binds #-}-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeSynonymInstances #-}---- Copyright (c) 2004 Thomas Jaeger--- Copyright (c) 2005 Simon Winwood--- Copyright (c) 2005 Don Stewart--- Copyright (c) 2005 David House <dmouse@gmail.com>------ | Logging an IRC channel..----module Plugin.Log (theModule) where--import Plugin-import qualified Message as Msg--import Control.Monad (when)-import qualified Data.Map as M-import System.Time-import Lambdabot.Util ( timeStamp )-import System.Directory (createDirectoryIfMissing)---- --------------------------------------------------------------------------type Channel = Msg.Nick--newtype LogModule = LogModule ()--type DateStamp = (Int, Month, Int)-data ChanState = CS { chanHandle  :: Handle,-                      chanDate    :: DateStamp }-               deriving (Show, Eq)-type LogState = M.Map Channel ChanState--type Log a = ModuleT LogState LB a--data Event =-    Said Msg.Nick ClockTime String-    | Joined Msg.Nick String ClockTime-    | Parted Msg.Nick String ClockTime -- covers quitting as well-    | Renick Msg.Nick String ClockTime Msg.Nick-    deriving (Eq)--theModule :: MODULE-theModule = MODULE $ LogModule ()--instance Show Event where-    show (Said nick ct what)       = timeStamp ct ++ " <" ++ Msg.nName nick ++ "> " ++ what-    show (Joined nick user ct)     = timeStamp ct ++ " " ++ show nick-                                     ++ " (" ++ user ++ ") joined."-    show (Parted nick user ct)     = timeStamp ct ++ " " ++ show nick-                                     ++ " (" ++ user ++ ") left."-    show (Renick nick user ct new) = timeStamp ct ++ " " ++ show  nick-                                     ++ " (" ++ user ++ ") is now " ++ show new ++ "."---- * Dispatchers and Module instance declaration------- | Default number of lines to show with @last.-numLastLines :: Int-numLastLines = 10---- | Command -> Help lookup-commands :: [(String,String)]-commands = []--{--commands = [("last",-             "@last <channel> [<count>] [<user>] The last <count> (default 10) "-               ++ "posts to channel <channel>."),-            ("log-email",-             "@log-email <email> [<start-date>] Email the log to the given "-               ++ "address (default to todays)"),-            ("print-logs",-             "print the current internal state")]--}---- | CTCP command -> logger function lookup-loggers :: Msg.Message m => [(String, m -> ClockTime -> Event)]-loggers = [("PRIVMSG", msgCB ),-           ("JOIN",    joinCB),-           ("PART",    partCB),-           ("NICK",    nickCB)]--instance Module LogModule LogState where-   moduleHelp   _ s = fromJust $ lookup s commands-   moduleCmds     _ = map fst commands-   moduleDefState _ = return M.empty-   moduleExit     _ = cleanLogState--   contextual _ msg _ _ = do-     case lookup (Msg.command msg) loggers of-       Just f -> do-         now <- io getClockTime-         -- map over the channels this message was directed to, adding to each-         -- of their log files.-         mapM_ (withValidLog (doLog f msg) now) (Msg.channels msg)-       Nothing -> return ()-     return []--     where -- notMe m = (lowerCaseString $ name config)-           --             /= (lowerCaseString . head $ Msg.channels m)-           --             -- We don't log /msgs to the lambdabot--           doLog f m hdl ct = do-             let event = f m ct-             logString hdl (show event)---- process _ _ _ "last" rest = showHistory rest--- process _ _ _ "print-logs" _ = fmap ((:[]) . show) readMS---- * The @last command------- | Filter all the nicks by one person--- FIXME --- maybe we should take into consideration nick changes?-filterNick :: Msg.Nick -> [Event] -> [Event]-filterNick who = filter filterOneNick-    where-    filterOneNick (Said who' _ _)      = who == who'-    filterOneNick (Joined who' _ _)    = who == who'-    filterOneNick (Parted who' _ _)    = who == who'-    filterOneNick (Renick old _ _ new) = who == old || who == new---- * Event -> String helpers------- * Logging helpers------- | Show a DateStamp.-dateToString :: DateStamp -> String-dateToString (d, m, y) = (showWidth 2 y) ++ "-" ++-                         (showWidth 2 $ fromEnum m + 1) ++ "-" ++-                         (showWidth 2 d)---- | ClockTime -> DateStamp conversion-dateStamp :: ClockTime -> DateStamp-dateStamp ct = let cal = toUTCTime ct in (ctDay cal, ctMonth cal, ctYear cal)---- * State manipulation functions------- | Cleans up after the module (closes files)-cleanLogState :: Log ()-cleanLogState =-    withMS $ \state writer -> do-      io $ M.fold (\cs iom -> iom >> hClose (chanHandle cs)) (return ()) state-      writer M.empty---- | Fetch a channel from the internal map. Uses LB's fail if not found.-getChannel :: Channel -> Log ChanState-getChannel c = (readMS >>=) . M.lookup $ c--getDate :: Channel -> Log DateStamp-getDate c = fmap chanDate . getChannel $ c--getHandle :: Channel -> Log Handle-getHandle c = fmap chanHandle . getChannel $ c-    -- add points. otherwise:-    -- Unbound implicit parameters (?ref::GHC.IOBase.MVar LogState, ?name::String)-    --  arising from instantiating a type signature at-    -- Plugin/Log.hs:187:30-39-    -- Probable cause: `getChannel' is applied to too few arguments---- | Put a DateStamp and a Handle. Used by 'openChannelFile' and---  'reopenChannelMaybe'.-putHdlAndDS :: Channel -> Handle -> DateStamp -> Log ()-putHdlAndDS c hdl ds =-        modifyMS (M.adjust (\cs -> cs {chanHandle = hdl, chanDate = ds}) c)----- * Logging IO------- | Open a file to write the log to.-openChannelFile :: Channel -> ClockTime -> Log Handle-openChannelFile chan ct =-    io $ createDirectoryIfMissing True dir >> openFile file AppendMode-    where dir  = outputDir config </> "Log" </> Msg.nTag chan </> Msg.nName chan-          date = dateStamp ct-          file = dir </> (dateToString date) <.> "txt"---- | Close and re-open a log file, and update the state.-reopenChannelMaybe :: Channel -> ClockTime -> Log ()-reopenChannelMaybe chan ct = do-  date <- getDate chan-  when (date /= dateStamp ct) $ do-    hdl <- getHandle chan-    io $ hClose hdl-    hdl' <- openChannelFile chan ct-    putHdlAndDS chan hdl' (dateStamp ct)---- | Initialise the channel state (if it not already inited)-initChannelMaybe :: Msg.Nick -> ClockTime -> Log ()-initChannelMaybe chan ct = do-  chanp <- liftM (M.member chan) readMS-  unless chanp $ do-    hdl <- openChannelFile chan ct-    modifyMS (M.insert chan $ CS hdl (dateStamp ct))---- | Ensure that the log is correctly initialised etc.-withValidLog :: (Handle -> ClockTime -> Log a) -> ClockTime -> Channel -> Log a-withValidLog f ct chan = do-  initChannelMaybe chan ct-  reopenChannelMaybe chan ct-  hdl <- getHandle chan-  rv <- f hdl ct-  return rv---- | Log a string. Main logging workhorse.-logString :: Handle -> String -> Log ()-logString hdl str = io $ hPutStrLn hdl str >> hFlush hdl-  -- We flush on each operation to ensure logs are up to date.---- * The event loggers themselves------- | When somebody joins.-joinCB :: Msg.Message a => a -> ClockTime -> Event-joinCB msg ct = Joined (Msg.nick msg) (Msg.fullName msg) ct---- | When somebody quits.-partCB :: Msg.Message a => a -> ClockTime -> Event-partCB msg ct = Parted (Msg.nick msg) (Msg.fullName msg) ct---- | When somebody changes his\/her name.--- FIXME:  We should only do this for channels that the user is currently on.-nickCB :: Msg.Message a => a -> ClockTime -> Event-nickCB msg ct = Renick (Msg.nick msg) (Msg.fullName msg) ct-                       (Msg.readNick msg $ drop 1 $ head $ Msg.body msg)---- | When somebody speaks.-msgCB :: Msg.Message a => a -> ClockTime -> Event-msgCB msg ct = Said (Msg.nick msg) ct-                    (tail . concat . tail $ Msg.body msg)-                      -- each lines is :foo
− Plugin/More.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeSynonymInstances #-}--- | Support for more(1) buffering-module Plugin.More (theModule) where--import Plugin--import Message( Nick )--$(plugin "More")--type MoreState = GlobalPrivate () [String]---- the @more state is handled centrally-instance Module MoreModule MoreState where-    moduleHelp _ _              = "@more. Return more output from the bot buffer."-    moduleCmds   _              = ["more"]-    moduleDefState _            = return $ mkGlobalPrivate 20 ()-    moduleInit   _              = bindModule2 moreFilter >>=-                                      ircInstallOutputFilter-    process      _ _ target _ _ = do-        morestate <- readPS target-        case morestate of-            Nothing -> return []-            Just ls -> do mapM_ (lift . ircPrivmsg' target) =<< moreFilter target ls-                          return []       -- special--moreFilter :: Nick -> [String] -> ModuleLB MoreState-moreFilter target msglines = do-    let (morelines, thislines) = case drop (maxLines+2) msglines of-          [] -> ([],msglines)-          _  -> (drop maxLines msglines, take maxLines msglines)-    writePS target $ if null morelines then Nothing else Just morelines-    return $ thislines ++ if null morelines-                          then []-                          else ['[':shows (length morelines) " @more lines]"]--    where maxLines = 5 -- arbitrary, really
− Plugin/OEIS.hs 
@@ -1,17 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}--- | Look up sequences in the Online Encyclopedia of Integer Sequences---   Based on the Math.OEIS library-module Plugin.OEIS (theModule) where--import Plugin--import Math.OEIS--$(plugin "OEIS")--instance Module OEISModule () where-    moduleCmds   _     = ["oeis"]-    moduleHelp _ _     = "oeis <sequence>. Look up a sequence in the Online Encyclopedia of Integer Sequences"-    process _ _ to _ a = do s <- liftIO $ lookupOEIS a-                            out <- mapM (ios80 to) (map return s)-                            return $ concat out
− Plugin/OfflineRC.hs 
@@ -1,108 +0,0 @@-{-# LANGUAGE TemplateHaskell, CPP, MultiParamTypeClasses #-}--- | Offline mode / RC file / -e support module.  Handles spooling lists--- of commands (from readline, files, or the command line) into the vchat--- layer.-module Plugin.OfflineRC (theModule) where--import Plugin-import System.IO( hPutStrLn, hFlush, stdout )--import LMain( received )-import IRCBase-import Control.Monad.Reader( asks )-import Control.Monad.State( get, gets, put )-import Control.Concurrent( forkIO )-import Control.Concurrent.MVar( readMVar )-import Lambdabot.Error( finallyError )-import Control.OldException ( evaluate )--import Config--#ifdef mingw32_HOST_OS--- Work around the lack of readline on windows-readline :: String -> IO (Maybe String)-readline p = do-    putStr p-    hFlush stdout-    liftM Just getLine--addHistory :: String -> IO ()-addHistory _ = return ()--#else-import System.Console.Readline( readline, addHistory )-#endif---$(plugin "OfflineRC")---- We need to track the number of active sourcings so that we can--- unregister the server (-> allow the bot to quit) when it is not--- being used.-type OfflineRC = ModuleT Integer LB--instance Module OfflineRCModule Integer where-    modulePrivs  _         = ["offline", "rc"]-    moduleHelp _ "offline" = "offline. Start a repl"-    moduleHelp _ "rc"      = "rc name. Read a file of commands (asynchonously). FIXME: better name."-    moduleInit      _      = do act <- bindModule0 onInit-                                lift $ liftLB forkIO $ do mv <- asks ircInitDoneMVar-                                                          io $ readMVar mv-                                                          act-                                return ()-    moduleDefState _       = return 0-    process_ _ "offline" _ = do act <- bindModule0 $ finallyError replLoop unlockRC-                                lockRC-                                lift $ liftLB forkIO act-                                return []-    process_ _ "rc" fn     = do txt <- io $ readFile fn-                                io $ evaluate $ foldr seq () txt-                                act <- bindModule0 $ finallyError (mapM_ feed $ lines txt) unlockRC-                                lockRC-                                lift $ liftLB forkIO act-                                return []--onInit :: ModuleT Integer LB ()-onInit = do st <- get-            put (st { ircOnStartupCmds = [] })-            let cmds = ircOnStartupCmds st-            lockRC >> finallyError (mapM_ feed cmds) unlockRC--feed :: String -> ModuleT Integer LB ()-feed msg = let msg' = case msg of '>':xs -> cmdPrefix ++ "run " ++ xs-                                  '!':xs -> xs-                                  _      -> cmdPrefix ++ dropWhile (== ' ') msg-           in lift . (>> return ()) . liftLB (timeout (15 * 1000 * 1000)) . received $-              IrcMessage { msgServer = "offlinerc"-                         , msgLBName = "offline"-                         , msgPrefix = "null!n=user@null"-                         , msgCommand = "PRIVMSG"-                         , msgParams = ["offline", ":" ++ msg' ] }-   where cmdPrefix = head (commandPrefixes config)--handleMsg :: IrcMessage -> LB ()-handleMsg msg = liftIO $ do-                  let str = case (tail . msgParams) msg of-                              []    -> []-                              (x:_) -> tail x-                  hPutStrLn stdout str-                  hFlush stdout--replLoop :: OfflineRC ()-replLoop = do line <- io $ readline "lambdabot> "-              s' <- case line of Nothing -> fail "<eof>"-                                 Just x -> return $ dropWhile isSpace x-              when (not $ null s') (do io (addHistory s')-                                       feed s')-              continue <- gets ircStayConnected-              when continue replLoop---lockRC :: OfflineRC ()-lockRC = do add <- bindModule0 $ addServer "offlinerc" handleMsg-            withMS $ \ cur writ -> do when (cur == 0) $ add-                                      writ (cur + 1)--unlockRC :: OfflineRC ()-unlockRC = withMS $ \ cur writ -> do when (cur == 1) $ remServer "offlinerc"-                                     writ (cur - 1)
− Plugin/Pl.hs 
@@ -1,95 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeSynonymInstances #-}---- | Pointfree programming fun------ A catalogue of refactorings is at:---      http://www.cs.kent.ac.uk/projects/refactor-fp/catalogue/---      http://www.cs.kent.ac.uk/projects/refactor-fp/catalogue/RefacIdeasAug03.html------ Use more Arrow stuff------ TODO would be to plug into HaRe and use some of their refactorings.-module Plugin.Pl (theModule) where--import Plugin--import Plugin.Pl.Common          (TopLevel, mapTopLevel, getExpr)-import Plugin.Pl.Parser          (parsePF)-import Plugin.Pl.PrettyPrinter   (Expr)-import Plugin.Pl.Transform       (transform)-import Plugin.Pl.Optimize        (optimize)--import Message( Nick )--import Control.Concurrent.Chan    (Chan, newChan, isEmptyChan, readChan, writeList2Chan)-import Control.Exception (unblock)--- firstTimeout is the timeout when the expression is simplified for the first--- time. After each unsuccessful attempt, this number is doubled until it hits--- maxTimeout.-firstTimeout, maxTimeout :: Int-firstTimeout =  3000000 --  3 seconds-maxTimeout   = 15000000 -- 15 seconds--type PlState = GlobalPrivate () (Int, TopLevel)--$(plugin "Pl")--type Pl = ModuleLB PlState--instance Module PlModule PlState where--    moduleCmds _   = ["pointless","pl-resume","pl"]--    moduleHelp _ "pl-resume" = "pl-resume. Resume a suspended pointless transformation."-    moduleHelp _ _           = "pointless <expr>. Play with pointfree code."--    moduleDefState _ = return $ mkGlobalPrivate 15 ()--    process _ _ target "pointless" rest = pf target rest-    process _ _ target "pl"        rest = pf target rest-    process _ _ target "pl-resume" _    = res target----------------------------------------------------------------------------res :: Nick -> Pl-res target = do-  d <- readPS target-  case d of-    Nothing -> return ["pointless: sorry, nothing to resume."]-    Just d' -> optimizeTopLevel target d'---- | Convert a string to pointfree form-pf :: Nick -> String -> Pl-pf target inp = case parsePF inp of-  Right d  -> optimizeTopLevel target (firstTimeout, mapTopLevel transform d)-  Left err -> return [err]--optimizeTopLevel :: Nick -> (Int, TopLevel) -> Pl-optimizeTopLevel target (to, d) = do-  let (e,decl) = getExpr d-  (e', finished) <- io $ optimizeIO to e-  extra <- if finished-           then do writePS target Nothing-                   return []-           else do writePS target $ Just (min (2*to) maxTimeout, decl e')-                   return ["optimization suspended, use @pl-resume to continue."]-  return $ (show $ decl e') : extra----------------------------------------------------------------------------optimizeIO :: Int -> Expr -> IO (Expr, Bool)-optimizeIO to e = do-  chan <- newChan-  -- We need "unblock" here because "timeout" will terminate the thread-  -- with an async exception and the current thread is in blocked-  -- mode for reasons that still aren't clear to me.-  result <- timeout to $ unblock (writeList2Chan chan $ optimize e)-  e' <- getChanLast chan e-  return $ case result of-    Nothing -> (e', False)-    Just _  -> (e', True)--getChanLast :: Chan a -> a -> IO a-getChanLast c x = do-  b <- isEmptyChan c-  if b then return x else getChanLast c =<< readChan c
− Plugin/Pl/Common.hs 
@@ -1,139 +0,0 @@-{-# OPTIONS -fvia-C #-}--module Plugin.Pl.Common (-        Fixity(..), Expr(..), Pattern(..), Decl(..), TopLevel(..),-        bt, sizeExpr, mapTopLevel, getExpr,-        operators, opchars, reservedOps, lookupOp, lookupFix, minPrec, maxPrec,-        comp, flip', id', const', scomb, cons, nil, fix', if',-        makeList, getList,-        Assoc(..),-        module Data.Maybe,-        module Control.Arrow,-        module Data.List,-        module Control.Monad,-        module GHC.Base-    ) where--import Data.Maybe (isJust, fromJust)-import Data.List (intersperse, minimumBy)-import qualified Data.Map as M--import Control.Monad-import Control.Arrow (first, second, (***), (&&&), (|||), (+++))--import Text.ParserCombinators.Parsec.Expr (Assoc(..))--import GHC.Base (assert)----- The rewrite rules can be found at the end of the file Rules.hs---- Not sure if passing the information if it was used as infix or prefix--- is worth threading through the whole thing is worth the effort,--- but it stays that way until the prettyprinting algorithm gets more--- sophisticated.-data Fixity = Pref | Inf deriving Show--instance Eq Fixity where-  _ == _ = True--instance Ord Fixity where-  compare _ _ = EQ--data Expr-  = Var Fixity String-  | Lambda Pattern Expr-  | App Expr Expr-  | Let [Decl] Expr-  deriving (Eq, Ord)--data Pattern-  = PVar String -  | PCons Pattern Pattern-  | PTuple Pattern Pattern-  deriving (Eq, Ord)--data Decl = Define { -  declName :: String, -  declExpr :: Expr-} deriving (Eq, Ord)--data TopLevel = TLD Bool Decl | TLE Expr deriving (Eq, Ord)--mapTopLevel :: (Expr -> Expr) -> TopLevel -> TopLevel-mapTopLevel f tl = case getExpr tl of (e, c) -> c $ f e--getExpr :: TopLevel -> (Expr, Expr -> TopLevel)-getExpr (TLD True (Define foo e)) = (Let [Define foo e] (Var Pref foo), -                                     \e' -> TLD False $ Define foo e')-getExpr (TLD False (Define foo e)) = (e, \e' -> TLD False $ Define foo e')-getExpr (TLE e)      = (e, TLE)--sizeExpr :: Expr -> Int-sizeExpr (Var _ _) = 1-sizeExpr (App e1 e2) = sizeExpr e1 + sizeExpr e2 + 1-sizeExpr (Lambda _ e) = 1 + sizeExpr e-sizeExpr (Let ds e) = 1 + sum (map sizeDecl ds) + sizeExpr e where-  sizeDecl (Define _ e') = 1 + sizeExpr e'--comp, flip', id', const', scomb, cons, nil, fix', if' :: Expr-comp   = Var Inf  "."-flip'  = Var Pref "flip"-id'    = Var Pref "id"-const' = Var Pref "const"-scomb  = Var Pref "ap"-cons   = Var Inf  ":"-nil    = Var Pref "[]"-fix'   = Var Pref "fix"-if'    = Var Pref "if'"--makeList :: [Expr] -> Expr-makeList = foldr (\e1 e2 -> cons `App` e1 `App` e2) nil---- Modularity is a drag-getList :: Expr -> ([Expr], Expr)-getList (c `App` x `App` tl) | c == cons = first (x:) $ getList tl-getList e = ([],e)--bt :: a-bt = undefined--shift, minPrec, maxPrec :: Int-shift = 0-maxPrec = shift + 10-minPrec = 0---- operator precedences are needed both for parsing and prettyprinting-operators :: [[(String, (Assoc, Int))]]-operators = (map . map . second . second $ (+shift))-  [[inf "." AssocRight 9, inf "!!" AssocLeft 9],-   [inf name AssocRight 8 | name <- ["^", "^^", "**"]],-   [inf name AssocLeft 7-     | name <- ["*", "/", "`quot`", "`rem`", "`div`", "`mod`", ":%", "%"]],-   [inf name AssocLeft 6  | name <- ["+", "-"]],-   [inf name AssocRight 5 | name <- [":", "++", "<+>"]],-   [inf name AssocNone 4-     | name <- ["==", "/=", "<", "<=", ">=", ">", "`elem`", "`notElem`"]] ++[inf name AssocLeft 4 | name <- ["<*","*>","<$>","<$","<**>"]],-   [inf "&&" AssocRight 3, inf "***" AssocRight 3, inf "&&&" AssocRight 3, inf "<|>" AssocLeft 3],-   [inf "||" AssocRight 2, inf "+++" AssocRight 2, inf "|||" AssocRight 2],-   [inf ">>" AssocLeft 1, inf ">>=" AssocLeft 1, inf "=<<" AssocRight 1, inf ">>>" AssocRight 1, inf "^>>" AssocRight 1, inf "^<<" AssocRight 1],-   [inf name AssocRight 0 | name <- ["$", "$!", "`seq`"]]-  ] where-  inf name assoc fx = (name, (assoc, fx))--opchars :: [Char]-opchars = "!@#$%^*./|=-+:?<>&"--reservedOps :: [String]-reservedOps = ["->", "..", "="]--opFM :: M.Map String (Assoc, Int)-opFM = (M.fromList $ concat operators)--lookupOp :: String -> Maybe (Assoc, Int)-lookupOp k = M.lookup k opFM--lookupFix :: String -> (Assoc, Int)-lookupFix str = case lookupOp $ str of-  Nothing -> (AssocLeft, 9 + shift)-  Just x  -> x
− Plugin/Pl/Names.hs 
@@ -1,89 +0,0 @@------- | Names of haskell functions used in the Pl code----module Plugin.Pl.Names where--import Plugin.Pl.Common----- | Expressions with holes--- No MLambda here because we only consider closed Terms (no alpha-renaming!).--- Has to be in this module, otherwise we get recursion-data MExpr-  = MApp  !MExpr !MExpr  -- ^ Application-  | Hole  !Int           -- ^ Hole/argument where another expression could go-  | Quote !Expr-  deriving Eq----- Names-idE, flipE, bindE, extE, returnE, consE, appendE, nilE, foldrE, foldlE, fstE,-  sndE, dollarE, constE, uncurryE, curryE, compE, headE, tailE, sE, commaE, -  fixE, foldl1E, notE, equalsE, nequalsE, plusE, multE, zeroE, oneE, lengthE, -  sumE, productE, concatE, concatMapE, joinE, mapE, fmapE, fmapIE, subtractE, -  minusE, liftME, apE, liftM2E, seqME, zipE, zipWithE, -  crossE, firstE, secondE, andE, orE, allE, anyE :: MExpr-idE        = Quote $ Var Pref "id"-flipE      = Quote $ Var Pref "flip"-constE     = Quote $ Var Pref "const"-compE      = Quote $ Var Inf  "."-sE         = Quote $ Var Pref "ap"-fixE       = Quote $ Var Pref "fix"-bindE      = Quote $ Var Inf  ">>="-extE       = Quote $ Var Inf  "=<<"-returnE    = Quote $ Var Pref "return"-consE      = Quote $ Var Inf  ":"-nilE       = Quote $ Var Pref "[]"-appendE    = Quote $ Var Inf  "++"-foldrE     = Quote $ Var Pref "foldr"-foldlE     = Quote $ Var Pref "foldl"-fstE       = Quote $ Var Pref "fst"-sndE       = Quote $ Var Pref "snd"-dollarE    = Quote $ Var Inf  "$"-uncurryE   = Quote $ Var Pref "uncurry"-curryE     = Quote $ Var Pref "curry"-headE      = Quote $ Var Pref "head"-tailE      = Quote $ Var Pref "tail"-commaE     = Quote $ Var Inf  ","-foldl1E    = Quote $ Var Pref "foldl1"-equalsE    = Quote $ Var Inf  "=="-nequalsE   = Quote $ Var Inf  "/="-notE       = Quote $ Var Pref "not"-plusE      = Quote $ Var Inf  "+"-multE      = Quote $ Var Inf  "*"-zeroE      = Quote $ Var Pref "0"-oneE       = Quote $ Var Pref "1"-lengthE    = Quote $ Var Pref "length"-sumE       = Quote $ Var Pref "sum"-productE   = Quote $ Var Pref "product"-concatE    = Quote $ Var Pref "concat"-concatMapE = Quote $ Var Pref "concatMap"-joinE      = Quote $ Var Pref "join"-mapE       = Quote $ Var Pref "map"-fmapE      = Quote $ Var Pref "fmap"-fmapIE     = Quote $ Var Inf  "fmap"-subtractE  = Quote $ Var Pref "subtract"-minusE     = Quote $ Var Inf  "-"-liftME     = Quote $ Var Pref "liftM"-liftM2E    = Quote $ Var Pref "liftM2"-apE        = Quote $ Var Inf  "ap"-seqME      = Quote $ Var Inf  ">>"-zipE       = Quote $ Var Pref "zip"-zipWithE   = Quote $ Var Pref "zipWith"-crossE     = Quote $ Var Inf  "***"-firstE     = Quote $ Var Pref "first"-secondE    = Quote $ Var Pref "second"-andE       = Quote $ Var Pref "and"-orE        = Quote $ Var Pref "or"-allE       = Quote $ Var Pref "all"-anyE       = Quote $ Var Pref "any"----a, c :: MExpr -> MExpr -> MExpr-a       = MApp-c e1 e2 = compE `a` e1 `a` e2-infixl 9 `a`-infixr 8 `c`-
− Plugin/Pl/Optimize.hs 
@@ -1,113 +0,0 @@-{-# LANGUAGE ImplicitParams #-}-module Plugin.Pl.Optimize (-    optimize,-  ) where--import Plugin.Pl.Common-import Plugin.Pl.Rules-import Plugin.Pl.PrettyPrinter--import Data.List (nub)-import Data.Maybe (listToMaybe)-import Control.Monad.State--cut :: [a] -> [a]-cut = take 1--toMonadPlus :: MonadPlus m => Maybe a -> m a-toMonadPlus Nothing = mzero-toMonadPlus (Just x)= return x--type Size = Double--- | The 'size' of an expression, lower is better------ This seems to be a better size for our purposes,--- despite being "a little" slower because of the wasteful uglyprinting-sizeExpr' :: Expr -> Size-sizeExpr' e = fromIntegral (length $ show e) + adjust e where-  -- hackish thing to favor some expressions if the length is the same:-  -- (+ x) --> (x +)-  -- x >>= f --> f =<< x-  -- f $ g x --> f (g x)-  adjust :: Expr -> Size-  adjust (Var _ str) -- Just n <- readM str = log (n*n+1) / 4-                     | str == "uncurry"    = -4---                     | str == "s"          = 5-                     | str == "flip"       = 0.1-                     | str == ">>="        = 0.05-                     | str == "$"          = 0.01-                     | str == "subtract"   = 0.01-                     | str == "ap"         = 2-                     | str == "liftM2"     = 1.01-                     | str == "return"     = -2-                     | str == "zipWith"    = -4-                     | str == "const"      = 0 -- -2-                     | str == "fmap"       = -1-  adjust (Lambda _ e') = adjust e'-  adjust (App e1 e2)  = adjust e1 + adjust e2-  adjust _ = 0---- | Optimize an expression-optimize :: Expr -> [Expr]-optimize e = result where-  result :: [Expr]-  result = map (snd . fromJust) . takeWhile isJust .-    iterate (>>= simpleStep) $ Just (sizeExpr' e, e)--  simpleStep :: (Size, Expr) -> Maybe (Size, Expr)-  simpleStep t = do-    let chn  = let ?first = True  in step (snd t)-        chnn = let ?first = False in step =<< chn-        new  = filter (\(x,_) -> x < fst t) . map (sizeExpr' &&& id) $-                snd t: chn ++ chnn-    listToMaybe new---- | Apply all rewrite rules once-step :: (?first :: Bool) => Expr -> [Expr]-step e = nub $ rewrite rules e---- | Apply a single rewrite rule----rewrite :: (?first :: Bool) => RewriteRule -> Expr -> [Expr]-rewrite rl e = case rl of-    Up r1 r2     -> let e'  = cut $ rewrite r1 e-                        e'' = rewrite r2 =<< e'-                    in if null e'' then e' else e''-    OrElse r1 r2 -> let e'  = rewrite r1 e-                    in if null e' then rewrite r2 e else e'-    Then r1 r2   -> rewrite r2 =<< nub (rewrite r1 e)-    Opt  r       -> e: rewrite r e-    If   p  r    -> if null (rewrite p e) then mzero else rewrite r e-    Hard r       -> if ?first then rewrite r e else mzero-    Or rs        -> (\x -> rewrite x e) =<< rs-    RR {}        -> rewDeep rl e-    CRR {}       -> rewDeep rl e-    Down {}      -> rewDeep rl e--  where -- rew = ...; rewDeep = ...---- Apply a 'deep' reqrite rule-rewDeep :: (?first :: Bool) => RewriteRule -> Expr -> [Expr]-rewDeep rule e = rew rule e `mplus` case e of-    Var _ _    -> mzero-    Lambda _ _ -> error "lambda: optimizer only works for closed expressions"-    Let _ _    -> error "let: optimizer only works for closed expressions"-    App e1 e2  -> ((`App` e2) `map` rewDeep rule e1) `mplus`-                  ((e1 `App`) `map` rewDeep rule e2)---- | Apply a rewrite rule to an expression---   in a 'deep' position, i.e. from inside a RR,CRR or Down-rew :: (?first :: Bool) => RewriteRule -> Expr -> [Expr]-rew (RR r1 r2)   e = toMonadPlus $ fire r1 r2 e-rew (CRR r)      e = toMonadPlus $ r e-rew (Or rs)      e = (\x -> rew x e) =<< rs-rew (Down r1 r2) e = if null e'' then e' else e''-  where-    e'  = cut $ rew r1 e-    e'' = rewDeep r2 =<< e'-rew r@(Then   {}) e = rewrite r e-rew r@(OrElse {}) e = rewrite r e-rew r@(Up     {}) e = rewrite r e-rew r@(Opt    {}) e = rewrite r e-rew r@(If     {}) e = rewrite r e-rew r@(Hard   {}) e = rewrite r e
− Plugin/Pl/Parser.hs 
@@ -1,234 +0,0 @@-{-# LANGUAGE PatternGuards #-}---- TODO, use Language.Haskell--- Doesn't handle string literals?--module Plugin.Pl.Parser (parsePF) where--import Plugin.Pl.Common--import Text.ParserCombinators.Parsec-import Text.ParserCombinators.Parsec.Expr-import Text.ParserCombinators.Parsec.Language-import qualified Text.ParserCombinators.Parsec.Token as T---- is that supposed to be done that way?-tp :: T.TokenParser ()-tp = T.makeTokenParser $ haskellStyle {-  reservedNames = ["if","then","else","let","in"]-}--parens :: Parser a -> Parser a-parens = T.parens tp--brackets :: Parser a -> Parser a-brackets = T.brackets tp--symbol :: String -> Parser String-symbol = T.symbol tp--modIdentifier :: Parser String-modIdentifier = T.lexeme tp $ do-  c <- oneOf ['A'..'Z']-  cs <- many ( alphaNum <|> oneOf "_'.")-  return (c:cs)--atomic :: Parser String-atomic = try (string "()") <|> try (show `fmap` T.natural tp) <|> modIdentifier <|> T.identifier tp--reserved :: String -> Parser ()-reserved = T.reserved tp--charLiteral :: Parser Char-charLiteral = T.charLiteral tp--stringLiteral :: Parser String-stringLiteral = T.stringLiteral tp--table :: [[Operator Char st Expr]]-table = addToFirst def $ map (map inf) operators where-  addToFirst y (x:xs) = ((y:x):xs)-  addToFirst _ _ = assert False bt--  def :: Operator Char st Expr-  def = Infix (try $ do-      name <- parseOp-      guard $ not $ isJust $ lookupOp name-      spaces-      return $ \e1 e2 -> App (Var Inf name) e1 `App` e2-    ) AssocLeft--  inf :: (String, (Assoc, Int)) -> Operator Char st Expr-  inf (name, (assoc, _)) = Infix (try $ do-      string name-      notFollowedBy $ oneOf opchars-      spaces-      let name' = if head name == '`'-                  then tail . reverse . tail . reverse $ name-                  else name-      return $ \e1 e2 -> App (Var Inf name') e1 `App` e2-    ) assoc---parseOp :: CharParser st String-parseOp = (between (char '`') (char '`') $ many1 (letter <|> digit))-  <|> try (do-    op <- many1 $ oneOf opchars-    guard $ not $ op `elem` reservedOps-    return op)--pattern :: Parser Pattern-pattern = buildExpressionParser ptable ((PVar `fmap`-                       (    atomic-                        <|> (symbol "_" >> return "")))-                        <|> parens pattern)-    <?> "pattern" where-  ptable = [[Infix (symbol ":" >> return PCons) AssocRight],-            [Infix (symbol "," >> return PTuple) AssocNone]]--lambda :: Parser Expr-lambda = do-    symbol "\\"-    vs <- many1 pattern-    symbol "->"-    e <- myParser False-    return $ foldr Lambda e vs-  <?> "lambda abstraction"--var :: Parser Expr-var = try (makeVar `fmap` atomic <|>-           parens (try unaryNegation <|> try rightSection-                   <|> try (makeVar `fmap` many1 (char ','))-                   <|> tuple) <|> list <|> (Var Pref . show) `fmap` charLiteral-                   <|> stringVar `fmap` stringLiteral)-        <?> "variable" where-  makeVar v | Just _ <- lookupOp v = Var Inf v -- operators always want to-                                               -- be infixed-            | otherwise            = Var Pref v-  stringVar :: String -> Expr-  stringVar str = makeList $ (Var Pref . show) `map` str--list :: Parser Expr-list = msum (map (try . brackets) plist) <?> "list" where-  plist = [-    foldr (\e1 e2 -> cons `App` e1 `App` e2) nil `fmap`-      (myParser False `sepBy` symbol ","),-    do e <- myParser False-       symbol ".."-       return $ Var Pref "enumFrom" `App` e,-    do e <- myParser False-       symbol ","-       e' <- myParser False-       symbol ".."-       return $ Var Pref "enumFromThen" `App` e `App` e',-    do e <- myParser False-       symbol ".."-       e' <- myParser False-       return $ Var Pref "enumFromTo" `App` e `App` e',-    do e <- myParser False-       symbol ","-       e' <- myParser False-       symbol ".."-       e'' <- myParser False-       return $ Var Pref "enumFromThenTo" `App` e `App` e' `App` e''-    ]--tuple :: Parser Expr-tuple = do-    elts <- myParser False `sepBy` symbol ","-    guard $ length elts /= 1-    let name = Var Pref $ replicate (length elts - 1) ','-    return $ foldl App name elts-  <?> "tuple"--unaryNegation :: Parser Expr-unaryNegation = do-    symbol "-"-    e <- myParser False-    return $ Var Pref "negate" `App` e-  <?> "unary negation"--rightSection :: Parser Expr-rightSection = do-    v <- Var Inf `fmap` parseOp-    spaces-    let rs e = flip' `App` v `App` e-    option v (rs `fmap` myParser False)-  <?> "right section"---myParser :: Bool -> Parser Expr-myParser b = lambda <|> expr b--expr :: Bool -> Parser Expr-expr b = buildExpressionParser table (term b) <?> "expression"--decl :: Parser Decl-decl = do-  f <- atomic-  args <- pattern `endsIn` symbol "="-  e <- myParser False-  return $ Define f (foldr Lambda e args)--letbind :: Parser Expr-letbind = do-  reserved "let"-  ds <- decl `sepBy` symbol ";"-  reserved "in"-  e <- myParser False-  return $ Let ds e--ifexpr :: Parser Expr-ifexpr = do-  reserved "if"-  p <- myParser False-  reserved "then"-  e1 <- myParser False-  reserved "else"-  e2 <- myParser False-  return $ if' `App` p `App` e1 `App` e2--term :: Bool -> Parser Expr-term b = application <|> lambda <|> letbind <|> ifexpr <|>-    (guard b >> (notFollowedBy (noneOf ")") >> return (Var Pref "")))-  <?> "simple term"--application :: Parser Expr-application = do-    e:es <- many1 $ var <|> parens (myParser True)-    return $ foldl App e es-  <?> "application"--endsIn :: Parser a -> Parser b -> Parser [a]-endsIn p end = do-  xs <- many p-  end-  return $ xs--input :: Parser TopLevel-input = do-  spaces-  tl <- try (do-      f    <- atomic-      args <- pattern `endsIn` symbol "="-      e    <- myParser False-      return $ TLD True $ Define f (foldr Lambda e args)-    ) <|> TLE `fmap` myParser False-  eof-  return tl--parsePF :: String -> Either String TopLevel-parsePF inp = case runParser input () "" inp of-    Left err -> Left $ show err-    Right e  -> Right $ mapTopLevel postprocess e---postprocess :: Expr -> Expr-postprocess (Var f v) = (Var f v)-postprocess (App e1 (Var Pref "")) = postprocess e1-postprocess (App e1 e2) = App (postprocess e1) (postprocess e2)-postprocess (Lambda v e) = Lambda v (postprocess e)-postprocess (Let ds e) = Let (mapDecl postprocess `map` ds) $ postprocess e where-  mapDecl :: (Expr -> Expr) -> Decl -> Decl-  mapDecl f (Define foo e') = Define foo $ f e'-
− Plugin/Pl/PrettyPrinter.hs 
@@ -1,151 +0,0 @@-{-# LANGUAGE PatternGuards #-}-module Plugin.Pl.PrettyPrinter (Expr) where---- Dummy export to make ghc -Wall happy--import Lambdabot.Serial (readM)-import Plugin.Pl.Common--instance Show Decl where-  show (Define f e) = f ++ " = " ++ show e-  showList ds = (++) $ concat $ intersperse "; " $ map show ds--instance Show TopLevel where-  showsPrec p (TLE e) = showsPrec p e-  showsPrec p (TLD _ d) = showsPrec p d---- | Expression with syntactic sugar-data SExpr-  = SVar !String-  | SLambda ![Pattern] !SExpr-  | SLet ![Decl] !SExpr-  | SApp !SExpr !SExpr-  | SInfix !String !SExpr !SExpr-  | LeftSection !String !SExpr  -- (x +)-  | RightSection !String !SExpr -- (+ x)-  | List ![SExpr]-  | Tuple ![SExpr]-  | Enum !Expr !(Maybe Expr) !(Maybe Expr)--{-# INLINE toSExprHead #-}-toSExprHead :: String -> [Expr] -> Maybe SExpr-toSExprHead hd tl-  | all (==',') hd, length hd+1 == length tl-  = Just . Tuple . reverse $ map toSExpr tl-  | otherwise = case (hd,reverse tl) of-      ("enumFrom", [e])              -> Just $ Enum e Nothing   Nothing-      ("enumFromThen", [e,e'])       -> Just $ Enum e (Just e') Nothing-      ("enumFromTo", [e,e'])         -> Just $ Enum e Nothing   (Just e')-      ("enumFromThenTo", [e,e',e'']) -> Just $ Enum e (Just e') (Just e'')-      _                              -> Nothing--toSExpr :: Expr -> SExpr-toSExpr (Var _ v) = SVar v-toSExpr (Lambda v e) = case toSExpr e of-  (SLambda vs e') -> SLambda (v:vs) e'-  e'              -> SLambda [v] e'-toSExpr (Let ds e) = SLet ds $ toSExpr e-toSExpr e | Just (hd,tl) <- getHead e, Just se <- toSExprHead hd tl = se-toSExpr e | (ls, tl) <- getList e, tl == nil-  = List $ map toSExpr ls-toSExpr (App e1 e2) = case e1 of-  App (Var Inf v) e0-    -> SInfix v (toSExpr e0) (toSExpr e2)-  Var Inf v | v /= "-"-    -> LeftSection v (toSExpr e2)--  Var _ "flip" | Var Inf v <- e2, v == "-" -> toSExpr $ Var Pref "subtract"--  App (Var _ "flip") (Var pr v)-    | v == "-"  -> toSExpr $ Var Pref "subtract" `App` e2-    | v == "id" -> RightSection "$" (toSExpr e2)-    | Inf <- pr -> RightSection v (toSExpr e2)-  _ -> SApp (toSExpr e1) (toSExpr e2)--getHead :: Expr -> Maybe (String, [Expr])-getHead (Var _ v) = Just (v, [])-getHead (App e1 e2) = second (e2:) `fmap` getHead e1-getHead _ = Nothing--instance Show Expr where-  showsPrec p = showsPrec p . toSExpr--instance Show SExpr where-  showsPrec _ (SVar v) = (getPrefName v ++)-  showsPrec p (SLambda vs e) = showParen (p > minPrec) $ ('\\':) .-    foldr (.) id (intersperse (' ':) (map (showsPrec $ maxPrec+1) vs)) .-    (" -> "++) . showsPrec minPrec e-  showsPrec p (SApp e1 e2) = showParen (p > maxPrec) $-    showsPrec maxPrec e1 . (' ':) . showsPrec (maxPrec+1) e2-  showsPrec _ (LeftSection fx e) = showParen True $-    showsPrec (snd (lookupFix fx) + 1) e . (' ':) . (getInfName fx++)-  showsPrec _ (RightSection fx e) = showParen True $-    (getInfName fx++) . (' ':) . showsPrec (snd (lookupFix fx) + 1) e-  showsPrec _ (Tuple es) = showParen True $-    (concat `id` intersperse ", " (map show es) ++)--  showsPrec _ (List es)-    | Just cs <- mapM ((=<<) readM . fromSVar) es = shows (cs::String)-    | otherwise = ('[':) .-      (concat `id` intersperse ", " (map show es) ++) . (']':)-    where fromSVar (SVar str) = Just str-          fromSVar _          = Nothing-  showsPrec _ (Enum fr tn to) = ('[':) . shows fr .-    showsMaybe (((',':) . show) `fmap` tn) . (".."++) .-    showsMaybe (show `fmap` to) . (']':)-      where showsMaybe = maybe id (++)-  showsPrec _ (SLet ds e) = ("let "++) . shows ds . (" in "++) . shows e---  showsPrec p (SInfix fx e1 e2) = showParen (p > fixity) $-    showsPrec f1 e1 . (' ':) . (getInfName fx++) . (' ':) .-    showsPrec f2 e2 where-      fixity = snd $ lookupFix fx-      (f1, f2) = case fst $ lookupFix fx of-        AssocRight -> (fixity+1, fixity + infixSafe e2 AssocLeft fixity)-        AssocLeft  -> (fixity + infixSafe e1 AssocRight fixity, fixity+1)-        AssocNone  -> (fixity+1, fixity+1)--      -- This is a little bit awkward, but at least seems to produce no false-      -- results anymore-      infixSafe :: SExpr -> Assoc -> Int -> Int-      infixSafe (SInfix fx'' _ _) assoc fx'-        | lookupFix fx'' == (assoc, fx') = 1-        | otherwise = 0-      infixSafe _ _ _ = 0 -- doesn't matter--instance Show Pattern where-  showsPrec _ (PVar v) = (v++)-  showsPrec _ (PTuple p1 p2) = showParen True $-    showsPrec 0 p1 . (", "++) . showsPrec 0 p2-  showsPrec p (PCons p1 p2) = showParen (p>5) $-    showsPrec 6 p1 . (':':) . showsPrec 5 p2--isOperator :: String -> Bool-isOperator = all (`elem` opchars)--getInfName :: String -> String-getInfName str = if isOperator str then str else "`"++str++"`"--getPrefName :: String -> String-getPrefName str = if isOperator str || ',' `elem` str then "("++str++")" else str--instance Eq Assoc where-  AssocLeft  == AssocLeft  = True-  AssocRight == AssocRight = True-  AssocNone  == AssocNone  = True-  _          == _          = False--{--instance Show Assoc where-  show AssocLeft  = "AssocLeft"-  show AssocRight = "AssocRight"-  show AssocNone  = "AssocNone"--instance Ord Assoc where-  AssocNone <= _ = True-  _ <= AssocNone = False-  AssocLeft <= _ = True-  _ <= AssocLeft = False-  _ <= _ = True--}
− Plugin/Pl/RuleLib.hs 
@@ -1,174 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-} -- fix this later-{-# LANGUAGE FlexibleInstances, PatternGuards #-}---- | This marvellous module contributed by Thomas J\344ger-module Plugin.Pl.RuleLib-       (  -- Using rules-          RewriteRule(..), fire-       ,  -- Defining rules-          rr,rr0,rr1,rr2,up,down-       ) where--import Plugin.Pl.Common-import Plugin.Pl.Names--import Data.Array-import qualified Data.Set as S--import Control.Monad.Fix (fix)---- Next time I do somthing like this, I'll actually think about the combinator--- language before, instead of producing something ad-hoc like this:-data RewriteRule-  = RR     Rewrite Rewrite           -- ^ A 'Rewrite' rule, rewrite the first to the second-                                     --   'Rewrite's can contain 'Hole's-  | CRR    (Expr -> Maybe Expr)      -- ^ Haskell function as a rule, applied to subexpressions-  | Down   RewriteRule RewriteRule   -- ^ Like Up, but applied to subexpressions-  | Up     RewriteRule RewriteRule   -- ^ Apply the first rule, then try the second rule on the first result-                                     --   if it fails, returns the result of the first rule-  | Or     [RewriteRule]             -- ^ Use all rules-  | OrElse RewriteRule RewriteRule   -- ^ Try the first rule, if it fails use the second rule-  | Then   RewriteRule RewriteRule   -- ^ Apply the first rule, apply the second rule to the result-  | Opt    RewriteRule               -- ^ Optionally apply the rewrite rule, Opt x == Or [identity,x]-  | If     RewriteRule RewriteRule   -- ^ Apply the second rule only if the first rule has some results-  | Hard   RewriteRule               -- ^ Apply the rule only in the first pass---- | An expression with holes to match or replace-data Rewrite = Rewrite {-  holes :: MExpr,  -- ^ Expression with holes-  rid   :: Int     -- ^ Number of holes-}---- What are you gonna do when no recursive modules are possible?-class RewriteC a where-  getRewrite :: a -> Rewrite--instance RewriteC MExpr where-  getRewrite rule = Rewrite {-    holes = rule,-    rid   = 0-  }---- lift functions to rewrite rules-instance RewriteC a => RewriteC (MExpr -> a) where-  getRewrite rule = Rewrite {-    holes = holes . getRewrite . rule . Hole $ pid,-    rid   = pid + 1-  } where-     pid = rid $ getRewrite (undefined :: a)---------------------------------------------------------------------------------------------- Applying/matching Rewrites--type ExprArr = Array Int Expr---- | Fill in the holes in a 'MExpr'-myFire :: ExprArr -> MExpr -> MExpr-myFire xs (MApp e1 e2) = MApp (myFire xs e1) (myFire xs e2)-myFire xs (Hole h) = Quote $ xs ! h-myFire _ me = me--nub' :: Ord a => [a] -> [a]-nub' = S.toList . S.fromList---- | Create an array, only if the keys in 'lst' are unique and all keys [0..n-1] are given-uniqueArray :: Ord v => Int -> [(Int, v)] -> Maybe (Array Int v)-uniqueArray n lst-  | length (nub' lst) == n = Just $ array (0,n-1) lst-  | otherwise = Nothing---- | Try to match a Rewrite to an expression,---   if there is a match, returns the expressions in the holes-match :: Rewrite -> Expr -> Maybe ExprArr-match (Rewrite hl rid') e  = uniqueArray rid' =<< matchWith hl e---- | Fill in the holes in a 'Rewrite'-fire' :: Rewrite -> ExprArr -> MExpr-fire' (Rewrite hl _)   = (`myFire` hl)--fire :: Rewrite -> Rewrite -> Expr -> Maybe Expr-fire r1 r2 e = (fromMExpr . fire' r2) `fmap` match r1 e---- | Match an Expr to a MExpr template, return the values used in the holes-matchWith :: MExpr -> Expr -> Maybe [(Int, Expr)]-matchWith (MApp e1 e2) (App e1' e2') =-  liftM2 (++) (matchWith e1 e1') (matchWith e2 e2')-matchWith (Quote e) e' = if e == e' then Just [] else Nothing-matchWith (Hole k) e = Just [(k,e)]-matchWith _ _ = Nothing--fromMExpr :: MExpr -> Expr-fromMExpr (MApp e1 e2)  = App (fromMExpr e1) (fromMExpr e2)-fromMExpr (Hole _)      = Var Pref "Hole" -- error "Hole in MExpr"-fromMExpr (Quote e)     = e--------------------------------------------------------------------------------------------- Difining rules---- | Yet another pointless transformation:---   Bring an MExpr to (more pointless) form by seeing it as a function---     \hole_n -> ...---   and writing that in pointless form-transformM :: Int -> MExpr -> MExpr-transformM _ (Quote e) = constE `a` Quote e-transformM n (Hole n') = if n == n' then idE else constE `a` Hole n'-transformM n (Quote (Var _ ".") `MApp` e1 `MApp` e2)-  | e1 `hasHole` n && not (e2 `hasHole` n)-  = flipE `a` compE `a` e2 `c` transformM n e1-transformM n e@(MApp e1 e2)-  | fr1 && fr2 = sE `a` transformM n e1 `a` transformM n e2-  | fr1        = flipE `a` transformM n e1 `a` e2-  | fr2, Hole n' <- e2, n' == n = e1-  | fr2        = e1 `c` transformM n e2-  | otherwise  = constE `a` e-  where-    fr1 = e1 `hasHole` n-    fr2 = e2 `hasHole` n---- | Is there a (Hole n) in an expression?-hasHole :: MExpr -> Int -> Bool-hasHole (MApp e1 e2) n = e1 `hasHole` n || e2 `hasHole` n-hasHole (Quote _)    _ = False-hasHole (Hole n')    n = n == n'---- | Variants of a rewrite rule: fill in (some of) the holes------ haddock doesn't like n+k patterns, so rewrite them----getVariants, getVariants' :: Rewrite -> [Rewrite]-getVariants' r@(Rewrite _ 0)  = [r]-getVariants' r@(Rewrite e nk)-    | nk >= 1    = r : getVariants (Rewrite e' (nk-1))-    | otherwise  = error "getVariants' : nk went negative"-    where-        e' = decHoles $ transformM 0 e--        -- decrement all hole numbers-        decHoles (Hole n')    = Hole (n'-1)-        decHoles (MApp e1 e2) = decHoles e1 `MApp` decHoles e2-        decHoles me           = me--getVariants = getVariants' -- r = trace (show vs) vs where vs = getVariants' r---- | Use this rewrite rule and rewrite rules derived from it by iterated---   pointless transformation-rrList :: RewriteC a => a -> a -> [RewriteRule]-rrList r1 r2 = zipWith RR (getVariants r1') (getVariants r2') where-  r1' = getRewrite r1-  r2' = getRewrite r2---- | Construct a 'RR' rewrite rule-rr, rr0, rr1, rr2 :: RewriteC a => a -> a -> RewriteRule-rr  r1 r2 = Or          $ rrList r1 r2-rr1 r1 r2 = Or . take 2 $ rrList r1 r2-rr2 r1 r2 = Or . take 3 $ rrList r1 r2--- use only this rewrite rule, no variants-rr0 r1 r2 = RR r1' r2' where-  r1' = getRewrite r1-  r2' = getRewrite r2---- | Apply Down/Up repeatedly-down, up :: RewriteRule -> RewriteRule-down = fix . Down-up   = fix . Up
− Plugin/Pl/Rules.hs 
@@ -1,562 +0,0 @@-{-# LANGUAGE ExistentialQuantification, PatternGuards, Rank2Types #-}---- | This marvellous module contributed by Thomas J\344ger-module Plugin.Pl.Rules (RewriteRule(..), fire, rules) where--import Lambdabot.Serial (readM)--import Plugin.Pl.Common-import Plugin.Pl.RuleLib-import Plugin.Pl.Names---------------------------------------------------------------------------------------------- Operator rules--collapseLists :: Expr -> Maybe Expr-collapseLists (Var _ "++" `App` e1 `App` e2)-  | (xs,x) <- getList e1, x==nil,-    (ys,y) <- getList e2, y==nil = Just $ makeList $ xs ++ ys-collapseLists _ = Nothing--data Binary = forall a b c. (Read a, Show a, Read b, Show b, Read c, Show c) => BA (a -> b -> c)--evalBinary :: [(String, Binary)] -> Expr -> Maybe Expr-evalBinary fs (Var _ f' `App` Var _ x' `App` Var _ y')-  | Just (BA f) <- lookup f' fs = (Var Pref . show) `fmap` liftM2 f (readM x') (readM y')-evalBinary _ _ = Nothing--data Unary = forall a b. (Read a, Show a, Read b, Show b) => UA (a -> b)--evalUnary :: [(String, Unary)] -> Expr -> Maybe Expr-evalUnary fs (Var _ f' `App` Var _ x')-  | Just (UA f) <- lookup f' fs = (Var Pref . show . f) `fmap` readM x'-evalUnary _ _ = Nothing--assocR, assocL, assoc :: [String] -> Expr -> Maybe Expr--- (f `op` g) `op` h --> f `op` (g `op` h)-assocR ops (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2) `App` e3)-  | op1 == op2 && op1 `elem` ops-  = Just (Var f1 op1 `App` e1 `App` (Var f2 op2 `App` e2 `App` e3))-assocR _ _ = Nothing---- f `op` (g `op` h) --> (f `op` g) `op` h-assocL ops (Var f1 op1 `App` e1 `App` (Var f2 op2 `App` e2 `App` e3))-  | op1 == op2 && op1 `elem` ops-  = Just (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2) `App` e3)-assocL _ _ = Nothing---- op f . op g --> op (f `op` g)-assoc ops (Var _ "." `App` (Var f1 op1 `App` e1) `App` (Var f2 op2 `App` e2))-  | op1 == op2 && op1 `elem` ops-  = Just (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2))-assoc _ _ = Nothing--commutative :: [String] -> Expr -> Maybe Expr-commutative ops (Var f op `App` e1 `App` e2)-  | op `elem` ops = Just (Var f op `App` e2 `App` e1)-commutative ops (Var _ "flip" `App` e@(Var _ op)) | op `elem` ops = Just e-commutative _ _ = Nothing--------------------------------------------------------------------------------------------- Rewrite rules----- TODO: Move rules into a file.-{-# INLINE simplifies #-}-simplifies :: RewriteRule-simplifies = Or [-  -- (f . g) x --> f (g x)-  rr0 (\f g x -> (f `c` g) `a` x)-      (\f g x -> f `a` (g `a` x)),-  -- id x --> x-  rr0 (\x -> idE `a` x)-      (\x -> x),-  -- flip (flip x) --> x-  rr  (\x -> flipE `a` (flipE `a` x))-      (\x -> x),-  -- flip id x . f --> flip f x-  rr0 (\f x -> (flipE `a` idE `a` x) `c` f)-      (\f x -> flipE `a` f `a` x),-  -- id . f --> f-  rr0 (\f -> idE `c` f)-      (\f -> f),-  -- f . id --> f-  rr0 (\f -> f `c` idE)-      (\f -> f),-  -- const x y --> x-  rr0 (\x y -> constE `a` x `a` y)-      (\x _ -> x),-  -- not (not x) --> x-  rr  (\x -> notE `a` (notE `a` x))-      (\x -> x),-  -- fst (x,y) --> x-  rr  (\x y -> fstE `a` (commaE `a` x `a` y))-      (\x _ -> x),-  -- snd (x,y) --> y-  rr  (\x y -> sndE `a` (commaE `a` x `a` y))-      (\_ y -> y),-  -- head (x:xs) --> x-  rr  (\x xs -> headE `a` (consE `a` x `a` xs))-      (\x _  -> x),-  -- tail (x:xs) --> xs-  rr  (\x xs -> tailE `a` (consE `a` x `a` xs))-      (\_ xs -> xs),-  -- uncurry f (x,y) --> f x y-  rr1 (\f x y -> uncurryE `a` f `a` (commaE `a` x `a` y))-      (\f x y -> f `a` x `a` y),-  -- uncurry (,) --> id-  rr  (uncurryE `a` commaE)-      (idE),-  -- uncurry f . s (,) g --> s f g-  rr1 (\f g -> (uncurryE `a` f) `c` (sE `a` commaE `a` g))-      (\f g -> sE `a` f `a` g),-  -- curry fst --> const-  rr (curryE `a` fstE) (constE),-  -- curry snd --> const id-  rr (curryE `a` sndE) (constE `a` idE),-  -- s f g x --> f x (g x)-  rr0 (\f g x -> sE `a` f `a` g `a` x)-      (\f g x -> f `a` x `a` (g `a` x)),-  -- flip f x y --> f y x-  rr0 (\f x y -> flipE `a` f `a` x `a` y)-      (\f x y -> f `a` y `a` x),-  -- flip (=<<) --> (>>=)-  rr0 (flipE `a` extE)-      bindE,--  -- TODO: Think about map/fmap-  -- fmap id --> id-  rr (fmapE `a` idE)-     (idE),-  -- map id --> id-  rr (mapE `a` idE)-     (idE),-  -- (f . g) . h --> f . (g . h)-  rr0 (\f g h -> (f `c` g) `c` h)-      (\f g h -> f `c` (g `c` h)),-  -- fmap f . fmap g -> fmap (f . g)-  rr0 (\f g -> fmapE `a` f `c` fmapE `a` g)-      (\f g -> fmapE `a` (f `c` g)),-  -- map f . map g -> map (f . g)-  rr0 (\f g -> mapE `a` f `c` mapE `a` g)-      (\f g -> mapE `a` (f `c` g))--  ]--onceRewrites :: RewriteRule-onceRewrites = Hard $ Or [-  -- ($) --> id-  rr0 (dollarE)-      idE,-  -- concatMap --> (=<<)-  rr concatMapE extE,-  -- concat    --> join-  rr concatE joinE,-  -- liftM --> fmap-  rr liftME fmapE,-  -- map --> fmap-  rr mapE fmapE,-  -- subtract -> flip (-)-  rr  subtractE-      (flipE `a` minusE)-  ]---- Now we can state rewrite rules in a nice high level way--- Rewrite rules should be as pointful as possible since the pointless variants--- will be derived automatically.-rules :: RewriteRule-rules = Or [-  -- f (g x) --> (f . g) x-  Hard $-  rr  (\f g x -> f `a` (g `a` x))-      (\f g x -> (f `c` g) `a` x),-  -- (>>=) --> flip (=<<)-  Hard $-  rr  bindE-      (flipE `a` extE),-  -- (.) id --> id-  rr (compE `a` idE)-     idE,-  -- (++) [x] --> (:) x-  rr  (\x -> appendE `a` (consE `a` x `a` nilE))-      (\x -> consE `a` x),-  -- (=<<) return --> id-  rr  (extE `a` returnE)-      idE,-  -- (=<<) f (return x) -> f x-  rr  (\f x -> extE `a` f `a` (returnE `a` x))-      (\f x -> f `a` x),-  -- (=<<) ((=<<) f . g) --> (=<<) f . (=<<) g-  rr  (\f g -> extE `a` ((extE `a` f) `c` g))-      (\f g -> (extE `a` f) `c` (extE `a` g)),-  -- flip (f . g) --> flip (.) g . flip f-  Hard $-  rr  (\f g -> flipE `a` (f `c` g))-      (\f g -> (flipE `a` compE `a` g) `c` (flipE `a` f)),-  -- flip (.) f . flip id --> flip f-  rr  (\f -> (flipE `a` compE `a` f) `c` (flipE `a` idE))-      (\f -> flipE `a` f),-  -- flip (.) f . flip flip --> flip (flip . f)-  rr  (\f -> (flipE `a` compE `a` f) `c` (flipE `a` flipE))-      (\f -> flipE `a` (flipE `c` f)),-  -- flip (flip (flip . f) g) --> flip (flip . flip f) g-  rr1 (\f g -> flipE `a` (flipE `a` (flipE `c` f) `a` g))-      (\f g -> flipE `a` (flipE `c` flipE `a` f) `a` g),--  -- flip (.) id --> id-  rr (flipE `a` compE `a` idE)-     idE,-  -- (.) . flip id --> flip flip-  rr  (compE `c` (flipE `a` idE))-      (flipE `a` flipE),-  -- s const x y --> y-  rr  (\x y -> sE `a` constE `a` x `a` y)-      (\_ y -> y),-  -- s (const . f) g --> f-  rr1 (\f g -> sE `a` (constE `c` f) `a` g)-      (\f _ -> f),-  -- s (const f) --> (.) f-  rr  (\f -> sE `a` (constE `a` f))-      (\f -> compE `a` f),-  -- (`ap` f) . const . h --> (. f) . h-  rr  (\f g h -> (flipE `a` sE `a` f) `c` (flipE `a` compE `a` g) `c` constE `c` h)-      (\f _ h -> (flipE `a` compE `a` f) `c` h),-  -- s (f . fst) snd --> uncurry f-  rr  (\f -> sE `a` (f `c` fstE) `a` sndE)-      (\f -> uncurryE `a` f),-  -- fst (join (,) x) --> x-  rr (\x -> fstE `a` (joinE `a` commaE `a` x))-     (\x -> x),-  -- snd (join (,) x) --> x-  rr (\x -> sndE `a` (joinE `a` commaE `a` x))-     (\x -> x),-  -- The next two are `simplifies', strictly speaking, but invoked rarely.-  -- uncurry f (x,y) --> f x y---  rr  (\f x y -> uncurryE `a` f `a` (commaE `a` x `a` y))---      (\f x y -> f `a` x `a` y),-  -- curry (uncurry f) --> f-  rr (\f -> curryE `a` (uncurryE `a` f))-     (\f -> f),-  -- uncurry (curry f) --> f-  rr (\f -> uncurryE `a` (curryE `a` f))-     (\f -> f),-  -- (const id . f) --> const id-  rr  (\f -> (constE `a` idE) `c` f)-      (\_ -> constE `a` idE),-  -- const x . f --> const x-  rr (\x f -> constE `a` x `c` f)-     (\x _ -> constE `a` x),-  -- (. f) . const --> const-  rr (\f -> (flipE `a` compE `a` f) `c` constE)-     (\_ -> constE),-  -- (. f) . const . g --> const . g-  rr (\f g -> (flipE `a` compE `a` f) `c` constE `c` g)-     (\_ g -> constE `c` g),-  -- fix f --> f (fix x)-  Hard $-  rr0 (\f -> fixE `a` f)-      (\f -> f `a` (fixE `a` f)),-  -- f (fix f) --> fix x-  Hard $-  rr0 (\f -> f `a` (fixE `a` f))-      (\f -> fixE `a` f),-  -- fix f --> f (f (fix x))-  Hard $-  rr0 (\f -> fixE `a` f)-      (\f -> f `a` (f `a` (fixE `a` f))),-  -- fix (const f) --> f-  rr (\f -> fixE `a` (constE `a` f))-     (\f -> f),-  -- flip const x --> id-  rr  (\x -> flipE `a` constE `a` x)-      (\_ -> idE),-  -- const . f --> flip (const f)-  Hard $-  rr  (\f -> constE `c` f)-      (\f -> flipE `a` (constE `a` f)),-  -- not (x == y) -> x /= y-  rr2 (\x y -> notE `a` (equalsE `a` x `a` y))-      (\x y -> nequalsE `a` x `a` y),-  -- not (x /= y) -> x == y-  rr2 (\x y -> notE `a` (nequalsE `a` x `a` y))-      (\x y -> equalsE `a` x `a` y),-  If (Or [rr plusE plusE, rr minusE minusE, rr multE multE]) $ down $ Or [-    -- 0 + x --> x-    rr  (\x -> plusE `a` zeroE `a` x)-        (\x -> x),-    -- 0 * x --> 0-    rr  (\x -> multE `a` zeroE `a` x)-        (\_ -> zeroE),-    -- 1 * x --> x-    rr  (\x -> multE `a` oneE `a` x)-        (\x -> x),-    -- x - x --> 0-    rr  (\x -> minusE `a` x `a` x)-        (\_ -> zeroE),-    -- x - y + y --> x-    rr  (\y x -> plusE `a` (minusE `a` x `a` y) `a` y)-        (\_ x -> x),-    -- x + y - y --> x-    rr  (\y x -> minusE `a` (plusE `a` x `a` y) `a` y)-        (\_ x -> x),-    -- x + (y - z) --> x + y - z-    rr  (\x y z -> plusE `a` x `a` (minusE `a` y `a` z))-        (\x y z -> minusE `a` (plusE `a` x `a` y) `a` z),-    -- x - (y + z) --> x - y - z-    rr  (\x y z -> minusE `a` x `a` (plusE `a` y `a` z))-        (\x y z -> minusE `a` (minusE `a` x `a` y) `a` z),-    -- x - (y - z) --> x + y - z-    rr  (\x y z -> minusE `a` x `a` (minusE `a` y `a` z))-        (\x y z -> minusE `a` (plusE `a` x `a` y) `a` z)-  ],--  Hard onceRewrites,-  -- join (fmap f x) --> f =<< x-  rr (\f x -> joinE `a` (fmapE `a` f `a` x))-     (\f x -> extE `a` f `a` x),-  -- (=<<) id --> join-  rr (extE `a` idE) joinE,-  -- join --> (=<<) id-  Hard $-  rr joinE (extE `a` idE),-  -- join (return x) --> x-  rr (\x -> joinE `a` (returnE `a` x))-     (\x -> x),-  -- (return . f) =<< m --> fmap f m-  rr (\f m -> extE `a` (returnE `c` f) `a` m)-     (\f m -> fmapIE `a` f `a` m),-  -- (x >>=) . (return .) . f  --> flip (fmap . f) x-  rr (\f x -> bindE `a` x `c` (compE `a` returnE) `c` f)-     (\f x -> flipE `a` (fmapIE `c` f) `a` x),-  -- (>>=) (return f) --> flip id f-  rr (\f -> bindE `a` (returnE `a` f))-     (\f -> flipE `a` idE `a` f),-  -- liftM2 f x --> ap (f `fmap` x)-  Hard $-  rr (\f x -> liftM2E `a` f `a` x)-     (\f x -> apE `a` (fmapIE `a` f `a` x)),-  -- liftM2 f (return x) --> fmap (f x)-  rr (\f x -> liftM2E `a` f `a` (returnE `a` x))-     (\f x -> fmapIE `a` (f `a` x)),-  -- f `fmap` return x --> return (f x)-  rr (\f x -> fmapE `a` f `a` (returnE `a` x))-     (\f x -> returnE `a` (f `a` x)),-  -- (=<<) . flip (fmap . f) --> flip liftM2 f-  Hard $-  rr (\f -> extE `c` flipE `a` (fmapE `c` f))-     (\f -> flipE `a` liftM2E `a` f),--  -- (.) -> fmap-  Hard $-  rr compE fmapE,--  -- map f (zip xs ys) --> zipWith (curry f) xs ys-  Hard $-  rr (\f xs ys -> mapE `a` f `a` (zipE `a` xs `a` ys))-     (\f xs ys -> zipWithE `a` (curryE `a` f) `a` xs `a` ys),-  -- zipWith (,) --> zip (,)-  rr (zipWithE `a` commaE) zipE,--  -- all f --> and . map f-  Hard $-  rr (\f -> allE `a` f)-     (\f -> andE `c` mapE `a` f),-  -- and . map f --> all f-  rr (\f -> andE `c` mapE `a` f)-     (\f -> allE `a` f),-  -- any f --> or . map f-  Hard $-  rr (\f -> anyE `a` f)-     (\f -> orE `c` mapE `a` f),-  -- or . map f --> any f-  rr (\f -> orE `c` mapE `a` f)-     (\f -> anyE `a` f),--  -- return f `ap` x --> fmap f x-  rr (\f x -> apE `a` (returnE `a` f) `a` x)-     (\f x -> fmapIE `a` f `a` x),-  -- ap (f `fmap` x) --> liftM2 f x-  rr (\f x -> apE `a` (fmapIE `a` f `a` x))-     (\f x -> liftM2E `a` f `a` x),-  -- f `ap` x --> (`fmap` x) =<< f-  Hard $-  rr (\f x -> apE `a` f `a` x)-     (\f x -> extE `a` (flipE `a` fmapIE `a` x) `a` f),-  -- (`fmap` x) =<< f --> f `ap` x-  rr (\f x -> extE `a` (flipE `a` fmapIE `a` x) `a` f)-     (\f x -> apE `a` f `a` x),-  -- (x >>=) . flip (fmap . f) -> liftM2 f x-  rr (\f x -> bindE `a` x `c` flipE `a` (fmapE `c` f))-     (\f x -> liftM2E `a` f `a` x),--  -- (f =<< m) x --> f (m x) x-  rr0 (\f m x -> extE `a` f `a` m `a` x)-      (\f m x -> f `a` (m `a` x) `a` x),-  -- (fmap f g x) --> f (g x)-  rr0 (\f g x -> fmapE `a` f `a` g `a` x)-      (\f g x -> f `a` (g `a` x)),-  -- return x y --> y-  rr  (\y x -> returnE `a` x `a` y)-      (\y _ -> y),-  -- liftM2 f g h x --> g x `h` h x-  rr0 (\f g h x -> liftM2E `a` f `a` g `a` h `a` x)-      (\f g h x -> f `a` (g `a` x) `a` (h `a` x)),-  -- ap f id --> join f-  rr  (\f -> apE `a` f `a` idE)-      (\f -> joinE `a` f),--  -- (=<<) const q --> flip (>>) q-  Hard $ -- ??-  rr (\q p -> extE `a` (constE `a` q) `a` p)-     (\q p -> seqME `a` p `a` q),-  -- p >> q --> const q =<< p-  Hard $-  rr (\p q -> seqME `a` p `a` q)-     (\p q -> extE `a` (constE `a` q) `a` p),--  -- experimental support for Control.Arrow stuff-  -- (costs quite a bit of performace)-  -- uncurry ((. g) . (,) . f) --> f *** g-  rr (\f g -> uncurryE `a` ((flipE `a` compE `a` g) `c` commaE `c` f))-     (\f g -> crossE `a` f `a` g),-  -- uncurry ((,) . f) --> first f-  rr (\f -> uncurryE `a` (commaE `c` f))-     (\f -> firstE `a` f),-  -- uncurry ((. g) . (,)) --> second g-  rr (\g -> uncurryE `a` ((flipE `a` compE `a` g) `c` commaE))-     (\g -> secondE `a` g),-  -- I think we need all three of them:-  -- uncurry (const f) --> f . snd-  rr (\f -> uncurryE `a` (constE `a` f))-     (\f -> f `c` sndE),-  -- uncurry const --> fst-  rr (uncurryE `a` constE)-     (fstE),-  -- uncurry (const . f) --> f . fst-  rr (\f -> uncurryE `a` (constE `c` f))-     (\f -> f `c` fstE),--  -- TODO is this the right place?-  -- [x] --> return x-  Hard $-  rr (\x -> consE `a` x `a` nilE)-     (\x -> returnE `a` x),-  -- list destructors-  Hard $-  If (Or [rr consE consE, rr nilE nilE]) $ Or [-    down $ Or [-      -- length [] --> 0-      rr (lengthE `a` nilE)-         zeroE,-      -- length (x:xs) --> 1 + length xs-      rr (\x xs -> lengthE `a` (consE `a` x `a` xs))-         (\_ xs -> plusE `a` oneE `a` (lengthE `a` xs))-    ],-    -- map/fmap elimination-    down $ Or [-      -- map f (x:xs) --> f x: map f xs-      rr (\f x xs -> mapE `a` f `a` (consE `a` x `a` xs))-         (\f x xs -> consE `a` (f `a` x) `a` (mapE `a` f `a` xs)),-      -- fmap f (x:xs) --> f x: Fmap f xs-      rr (\f x xs -> fmapE `a` f `a` (consE `a` x `a` xs))-         (\f x xs -> consE `a` (f `a` x) `a` (fmapE `a` f `a` xs)),-      -- map f []     --> []-      rr (\f -> mapE `a` f `a` nilE)-         (\_ -> nilE),-      -- fmap f []     --> []-      rr (\f -> fmapE `a` f `a` nilE)-         (\_ -> nilE)-    ],-    -- foldr elimination-    down $ Or [-      -- foldr f z (x:xs) --> f x (foldr f z xs)-      rr (\f x xs z -> (foldrE `a` f `a` z) `a` (consE `a` x `a` xs))-         (\f x xs z -> (f `a` x) `a` (foldrE `a` f `a` z `a` xs)),-      -- foldr f z [] --> z-      rr (\f z -> foldrE `a` f `a` z `a` nilE)-         (\_ z -> z)-    ],-    -- foldl elimination-    down $ Opt (CRR $ assocL ["."]) `Then` Or [-      -- sum xs --> foldl (+) 0 xs-      rr (\xs -> sumE `a` xs)-         (\xs -> foldlE `a` plusE `a` zeroE `a` xs),-      -- product xs --> foldl (*) 1 xs-      rr (\xs -> productE `a` xs)-         (\xs -> foldlE `a` multE `a` oneE `a` xs),-      -- foldl1 f (x:xs) --> foldl f x xs-      rr (\f x xs -> foldl1E `a` f `a` (consE `a` x `a` xs))-         (\f x xs -> foldlE `a` f `a` x `a` xs),-      -- foldl f z (x:xs) --> foldl f (f z x) xs-      rr (\f z x xs -> (foldlE `a` f `a` z) `a` (consE `a` x `a` xs))-         (\f z x xs -> foldlE `a` f `a` (f `a` z `a` x) `a` xs),-      -- foldl f z [] --> z-      rr (\f z -> foldlE `a` f `a` z `a` nilE)-         (\_ z -> z),-      -- special rule:-      -- foldl f z [x] --> f z x-      rr (\f z x -> foldlE `a` f `a` z `a` (returnE `a` x))-         (\f z x -> f `a` z `a` x),-      rr (\f z x -> foldlE `a` f `a` z `a` (consE `a` x `a` nilE))-         (\f z x -> f `a` z `a` x)-    ] `OrElse` (-      -- (:) x --> (++) [x]-      Opt (rr0 (\x -> consE `a` x)-         (\x -> appendE `a` (consE `a` x `a` nilE))) `Then`-      -- More special rule: (:) x . (++) ys --> (++) (x:ys)-      up (rr0 (\x ys -> (consE `a` x) `c` (appendE `a` ys))-         (\x ys -> appendE `a` (consE `a` x `a` ys)))-      )-  ],--  -- Complicated Transformations-  CRR (collapseLists),-  up $ Or [CRR (evalUnary unaryBuiltins), CRR (evalBinary binaryBuiltins)],-  up $ CRR (assoc assocOps),-  up $ CRR (assocL assocOps),-  up $ CRR (assocR assocOps),-  Up (CRR (commutative commutativeOps)) $ down $ Or [CRR $ assocL assocLOps,-                                                     CRR $ assocR assocROps],--  Hard $ simplifies-  ] `Then` Opt (up simplifies)--------------------------------------------------------------------------------------------- Operator information--assocLOps, assocROps, assocOps :: [String]-assocLOps = ["+", "*", "&&", "||", "max", "min"]-assocROps = [".", "++"]-assocOps  = assocLOps ++ assocROps--commutativeOps :: [String]-commutativeOps = ["*", "+", "==", "/=", "max", "min"]--unaryBuiltins :: [(String,Unary)]-unaryBuiltins = [-    ("not",    UA (not    :: Bool -> Bool)),-    ("negate", UA (negate :: Integer -> Integer)),-    ("signum", UA (signum :: Integer -> Integer)),-    ("abs",    UA (abs    :: Integer -> Integer))-  ]--binaryBuiltins :: [(String,Binary)]-binaryBuiltins = [-    ("+",    BA ((+)  :: Integer -> Integer -> Integer)),-    ("-",    BA ((-)  :: Integer -> Integer -> Integer)),-    ("*",    BA ((*)  :: Integer -> Integer -> Integer)),-    ("^",    BA ((^)  :: Integer -> Integer -> Integer)),-    ("<",    BA ((<)  :: Integer -> Integer -> Bool)),-    (">",    BA ((>)  :: Integer -> Integer -> Bool)),-    ("==",   BA ((==) :: Integer -> Integer -> Bool)),-    ("/=",   BA ((/=) :: Integer -> Integer -> Bool)),-    ("<=",   BA ((<=) :: Integer -> Integer -> Bool)),-    (">=",   BA ((>=) :: Integer -> Integer -> Bool)),-    ("div",  BA (div  :: Integer -> Integer -> Integer)),-    ("mod",  BA (mod  :: Integer -> Integer -> Integer)),-    ("max",  BA (max  :: Integer -> Integer -> Integer)),-    ("min",  BA (min  :: Integer -> Integer -> Integer)),-    ("&&",   BA ((&&) :: Bool -> Bool -> Bool)),-    ("||",   BA ((||) :: Bool -> Bool -> Bool))-  ]
− Plugin/Pl/Transform.hs 
@@ -1,121 +0,0 @@-{-# LANGUAGE PatternGuards #-}-module Plugin.Pl.Transform (-    transform,-  ) where--import Plugin.Pl.Common-import Plugin.Pl.PrettyPrinter--import qualified Data.Map as M--import Data.Graph (stronglyConnComp, flattenSCC, flattenSCCs)-import Control.Monad.State---- | Does a name occur in a pattern?-occursP :: String -> Pattern -> Bool-occursP v (PVar v') = v == v'-occursP v (PTuple p1 p2) = v `occursP` p1 || v `occursP` p2-occursP v (PCons  p1 p2) = v `occursP` p1 || v `occursP` p2---- | How often does the given name occur free in an expression?-freeIn :: String -> Expr -> Int-freeIn v (Var _ v') = fromEnum $ v == v'-freeIn v (Lambda pat e) = if v `occursP` pat then 0 else freeIn v e-freeIn v (App e1 e2) = freeIn v e1 + freeIn v e2-freeIn v (Let ds e') = if v `elem` map declName ds then 0-  else freeIn v e' + sum [freeIn v e | Define _ e <- ds]---- | Does a name occur free in an expression?-isFreeIn :: String -> Expr -> Bool-isFreeIn v e = freeIn v e > 0--tuple :: [Expr] -> Expr-tuple es  = foldr1 (\x y -> Var Inf "," `App` x `App` y) es--tupleP :: [String] -> Pattern-tupleP vs = foldr1 PTuple $ PVar `map` vs---- | The subset of ds that d depends on-dependsOn :: [Decl] -> Decl -> [Decl]-dependsOn ds d = [d' | d' <- ds, declName d' `isFreeIn` declExpr d]---- | Convert recursive lets to lambdas with tuple patterns and fix calls-unLet :: Expr -> Expr-unLet (App e1 e2) = App (unLet e1) (unLet e2)-unLet (Let [] e) = unLet e-unLet (Let ds e) = unLet $-  (Lambda (tupleP $ declName `map` dsYes) (Let dsNo e)) `App`-    (fix' `App` (Lambda (tupleP $ declName `map` dsYes)-                        (tuple  $ declExpr `map` dsYes)))-    where-  comps = stronglyConnComp [(d',d',dependsOn ds d') | d' <- ds]-  dsYes = flattenSCC $ head comps-  dsNo = flattenSCCs $ tail comps--unLet (Lambda v e) = Lambda v (unLet e)-unLet (Var f x) = Var f x--type Env = M.Map String String---- | Rename all variables to (locally) unqiue fresh ones------ It's a pity we still need that for the pointless transformation.--- Otherwise a newly created id/const/... could be bound by a lambda--- e.g. transform' (\id x -> x) ==> transform' (\id -> id) ==> id-alphaRename :: Expr -> Expr-alphaRename e = alpha e `evalState` M.empty where-  alpha :: Expr -> State Env Expr-  alpha (Var f v)     = do fm <- get; return $ Var f $ maybe v id (M.lookup v fm)-  alpha (App e1 e2)   = liftM2 App (alpha e1) (alpha e2)-  alpha (Let _ _)     = assert False undefined-  alpha (Lambda v e') = inEnv $ liftM2 Lambda (alphaPat v) (alpha e')--  -- act like a reader monad-  inEnv :: State s a -> State s a-  inEnv f = state $ \s -> (fst $ runState f s, s)--  alphaPat (PVar v) = do-    fm <- get-    let v' = "$" ++ show (M.size fm)-    put $ M.insert v v' fm-    return $ PVar v'-  alphaPat (PTuple p1 p2) = liftM2 PTuple (alphaPat p1) (alphaPat p2)-  alphaPat (PCons  p1 p2) = liftM2 PCons  (alphaPat p1) (alphaPat p2)---- | Make an expression points free-transform :: Expr -> Expr-transform = transform' . alphaRename . unLet---- | Transform patterns to:---     fst/snd for tuple patterns---     head/tail for cons patterns---     id/const/flip/. for variable paterns-transform' :: Expr -> Expr-transform' (Let {}) = assert False undefined-transform' (Var f v) = Var f v-transform' (App e1 e2) = App (transform' e1) (transform' e2)-transform' (Lambda (PTuple p1 p2) e)-  = transform' $ Lambda (PVar "z") $-      (Lambda p1 $ Lambda p2 $ e) `App` f `App` s where-    f = Var Pref "fst" `App` Var Pref "z"-    s = Var Pref "snd" `App` Var Pref "z"-transform' (Lambda (PCons p1 p2) e)-  = transform' $ Lambda (PVar "z") $-      (Lambda p1 $ Lambda p2 $ e) `App` f `App` s where-    f = Var Pref "head" `App` Var Pref "z"-    s = Var Pref "tail" `App` Var Pref "z"-transform' (Lambda (PVar v) e) = transform' $ getRidOfV e where-  getRidOfV (Var f v') | v == v'   = id'-                       | otherwise = const' `App` Var f v'-  getRidOfV l@(Lambda pat _) = assert (not $ v `occursP` pat) $-    getRidOfV $ transform' l-  getRidOfV (Let {}) = assert False bt-  getRidOfV e'@(App e1 e2)-    | fr1 && fr2 = scomb `App` getRidOfV e1 `App` getRidOfV e2-    | fr1 = flip' `App` getRidOfV e1 `App` e2-    | Var _ v' <- e2, v' == v = e1-    | fr2 = comp `App` e1 `App` getRidOfV e2-    | True = const' `App` e'-    where-      fr1 = v `isFreeIn` e1-      fr2 = v `isFreeIn` e2
− Plugin/Pointful.hs 
@@ -1,23 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeSynonymInstances #-}--- Undo pointfree transformations. Plugin code derived from Pl.hs.-module Plugin.Pointful (theModule) where--import Plugin--import Lambdabot.Pointful--type PfState = ()--$(plugin "Pointful")----type Pf = ModuleLB PfState--instance Module PointfulModule PfState where--    moduleCmds _ = ["pointful","pointy","repoint","unpointless","unpl","unpf"]--    moduleHelp _ _ = "pointful <expr>. Make code pointier."--    moduleDefState _ = return $ ()--    process _ _ _ _ rest = return (lines $ pointful rest)
− Plugin/Poll.hs 
@@ -1,180 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeSynonymInstances #-}--- | Module: Vote--- | Support for voting--- |--- | License: lGPL--- |--- | added by Kenneth Hoste (boegel), 22/11/2005--- |  inspiration: Where plugin (thanks shapr,dons)-module Plugin.Poll (theModule) where--import Plugin hiding (choice)-import qualified Data.ByteString.Char8 as P-import qualified Data.Map as M--$(plugin "Vote")--newPoll :: Poll-newPoll = (True,[])--appendPoll :: String -> Poll -> (Maybe Poll)-appendPoll choice (o,ls) = Just (o,(choice,0):ls)--voteOnPoll :: Poll -> String -> (Poll,String)-voteOnPoll (o,poll) choice =-    if any (\(x,_) -> x == choice) poll-        then ((o,map (\(c,n) ->-                    if c == choice then (c,n+1)-                                   else (c,n)) poll)-                                        ,"voted on " ++ show choice)-        else ((o,poll),show choice ++ " is not currently a candidate in this poll")----------------------------------------------------------------------------type Count             = Int-type Candidate         = String-type PollName          = P.ByteString-type Poll              = (Bool, [(Candidate, Count)])-type VoteState         = M.Map PollName Poll-type VoteWriter        = VoteState -> LB ()--- type Vote m a          = ModuleT VoteState m a----------------------------------------------------------------------------- Define a serialiser--voteSerial :: Serial VoteState-voteSerial = Serial (Just . showPacked) (Just . readPacked)----------------------------------------------------------------------------instance Module VoteModule VoteState where-    moduleCmds     _ = ["poll-list"-                       ,"poll-show"-                       ,"poll-add"-                       ,"choice-add"-                       ,"vote"-                       ,"poll-result"-                       ,"poll-close"-                       ,"poll-remove"]----   -- todo, should @vote foo automagically add foo as a possibility?-    moduleHelp   _ s = case s of-        "poll-list"     -> "poll-list                   Shows all current polls"-        "poll-show"     -> "poll-show <poll>            Shows all choices for some poll"-        "poll-add"      -> "poll-add <name>             Adds a new poll, with no candidates"-        "choice-add"    -> "choice-add <poll> <choice>  Adds a new choice to the given poll"-        "vote"          -> "vote <poll> <choice>        Vote for <choice> in <poll>"-        "poll-result"   -> "poll-result <poll>          Show result for given poll"-        "poll-close"    -> "poll-close <poll>           Closes a poll"-        "poll-remove"   -> "poll-remove <poll>          Removes a poll"--    moduleDefState _  = return M.empty-    moduleSerialize _ = Just voteSerial--    process_ _ "poll-list" _ = do-        result <- withMS $ \factFM writer -> processCommand factFM writer "poll-list" []-        return [result]--    process_ _ _ [] = return ["Missing argument. Check @help <vote-cmd> for info."]--    process_ _ cmd dat = do-        result <- withMS $ \factFM writer -> processCommand factFM writer cmd (words dat)-        return [result]----------------------------------------------------------------------------processCommand :: VoteState -> VoteWriter -> String -> [String] -> LB String-processCommand fm writer cmd dat = case cmd of--    -- show all current polls-    "poll-list"  -> return $ listPolls fm--    -- show candidates-    "poll-show"    -> return $ case length dat of-                        1 -> showPoll fm (head dat)-                        _ -> "usage: @poll-show <poll>"--    -- declare a new poll-    "poll-add"     -> case length dat of-                        1 -> addPoll fm writer (head dat)-                        _ -> return "usage: @poll-add <poll>   with \"ThisTopic\" style names"--    "choice-add"   -> case length dat of-                        2 -> addChoice fm writer (head dat) (last dat)-                        _ -> return "usage: @choice-add <poll> <choice>"--    "vote"          -> case length dat of-                        2 -> vote fm writer (head dat) (last dat)-                        _ -> return "usage: @vote <poll> <choice>"--    "poll-result"   -> return $ case length dat of-                        1 -> showResult fm (head dat)-                        _ -> "usage: @poll-result <poll>"--    "poll-close"    -> case length dat of-                        1 -> closePoll fm writer (head dat)-                        _ -> return "usage: @poll-close <poll>"--    "poll-remove"   -> case length dat of-                        1 -> removePoll fm writer (head dat)-                        _ -> return "usage: @poll-remove <poll>"--    _ -> return "Unknown command."----------------------------------------------------------------------------listPolls :: VoteState -> String-listPolls fm = show $ map fst (M.toList fm)--showPoll :: VoteState -> String -> String-showPoll fm poll =-    case M.lookup (P.pack poll) fm of-        Nothing -> "No such poll: " ++ show poll ++ " Use @poll-list to see the available polls."-        Just p  -> show $ map fst (snd p)--addPoll :: VoteState -> VoteWriter -> String -> LB String-addPoll fm writer poll =-    case M.lookup (P.pack poll) fm of-        Nothing -> do writer $ M.insert (P.pack poll) newPoll fm-                      return $ "Added new poll: " ++ show poll-        Just _  -> return $ "Poll " ++ show poll ++-                            " already exists, choose another name for your poll"--addChoice :: VoteState -> VoteWriter -> String -> String -> LB String-addChoice fm writer poll choice = case M.lookup (P.pack poll) fm of-    Nothing -> return $ "No such poll: " ++ show poll-    Just _  -> do writer $ M.update (appendPoll choice) (P.pack poll) fm-                  return $ "New candidate " ++ show choice ++-                           ", added to poll " ++ show poll ++ "."--vote :: VoteState -> VoteWriter -> String -> String -> LB String-vote fm writer poll choice = case M.lookup (P.pack poll) fm of-    Nothing          -> return $ "No such poll:" ++ show poll-    Just (False,_)   -> return $ "The "++ show poll ++ " poll is closed, sorry !"-    Just p@(True,_)  -> do let (np,msg) = voteOnPoll p choice-                           writer $ M.update (const (Just np)) (P.pack poll) fm-                           return msg--showResult :: VoteState -> String -> String-showResult fm poll = case M.lookup (P.pack poll) fm of-    Nothing     -> "No such poll: "  ++ show poll-    Just (o,p)  -> "Poll results for " ++ poll ++ " (" ++ (status o) ++ "): "-                   ++ (concat $ intersperse ", " $ map ppr p)-        where-            status s | s         = "Open"-                     | otherwise = "Closed"-            ppr (x,y) = x ++ "=" ++ show y--removePoll :: VoteState -> VoteWriter -> String -> LB String-removePoll fm writer poll = case M.lookup (P.pack poll) fm of-    Just (True,_)  -> return "Poll should be closed before you can remove it."-    Just (False,_) -> do writer $ M.delete (P.pack poll) fm-                         return $ "poll " ++ show poll ++ " removed."-    Nothing        -> return $ "No such poll: " ++ show poll--closePoll :: VoteState -> VoteWriter -> String -> LB String-closePoll fm writer poll = case M.lookup (P.pack poll) fm of-    Nothing     -> return $ "No such poll: " ++ show poll-    Just (_,p)  -> do writer $ M.update (const (Just (False,p))) (P.pack poll) fm-                      return $ "Poll " ++ show poll ++ " closed."-
− Plugin/Pretty.hs 
@@ -1,80 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses #-}--{- | Pretty-Printing echo--example:--> @pretty fun x = case x of {3 -> "hello" ; 5 -> "world" ; _ -> "else"}--> fun x->  = case x of->   3 -> "hello"->   5 -> "world"->   _ -> "else"--(c) Johannes Ahlmann, 2005-12-13, released under GPL 2 -}--module Plugin.Pretty where--import Plugin--import Language.Haskell.Parser-import Language.Haskell.Syntax hiding (Module)-import Language.Haskell.Pretty--$(plugin "Pretty")--instance Module PrettyModule (String -> IO String) where-    moduleCmds _   = ["pretty"]-    moduleHelp _ _ = "pretty <expr>. Display haskell code in a pretty-printed manner"-    process_ _ _ r = prettyCmd r----------------------------------------------------------------------------prettyCmd :: String -> ModuleLB (String -> IO String)-prettyCmd rest =-    let code = dropWhile (`elem` " \t>") rest-        modPrefix1 = "module Main where "-        modPrefix2 = "module Main where __expr__ = "-        prefLen1 = length modPrefix1-        result = case (parseModule (modPrefix1 ++ code ++ "\n"), parseModule (modPrefix2 ++ code ++ "\n"))  of-            (ParseOk a, _)          -> doPretty a-            (_, ParseOk a)          -> doPretty a-            (ParseFailed loc msg,_) -> let (SrcLoc _ _ col) = loc in-                   (show msg ++ " at column " ++ show (col - prefLen1)) : []-    in return result -- XXX will this work? No, spaces are compressed.---- | calculates "desired" indentation and return pretty-printed declarations--- the indentation calculations are still pretty much rough guesswork.--- i'll have to figure out a way to do some _reliable_ pretty-printing!-doPretty :: HsModule -> [String]-doPretty (HsModule _ _ _ _ decls) =-    let defaultLen = 4-        declLen (HsFunBind mtches)   = maximum $ map matchLen mtches-        declLen (HsPatBind _ pat _ _) = patLen pat-        declLen _  = defaultLen-        patLen (HsPVar nm) = nameLen nm-        patLen  _  = defaultLen-        nameLen (HsIdent s)  = length s + 1-        nameLen _  = defaultLen-        matchLen (HsMatch _ nm pats _ _) =-            let l = (nameLen nm + sum (map patLen pats) + 1)-            in if l > 16 then defaultLen else l-        makeMode decl = defaultMode {-            doIndent     = 3,-            caseIndent   = 4,-            onsideIndent = declLen decl-        }-        makeModeExp _ = defaultMode {-            doIndent     = 3,-            caseIndent   = 4,-            onsideIndent = 0-        }-        prettyDecl (HsPatBind _ (HsPVar (HsIdent "__expr__")) (HsUnGuardedRhs e) []) -- pretty printing an expression-                     = prettyPrintWithMode (makeModeExp e) e-        prettyDecl d = prettyPrintWithMode (makeMode d) d-    -- FIXME: prefixing with hashes is done, because i didn't find a way-    --   to disable the indentation filter of lambdabot only for this module...-    in map (" "++) . lines . concat . intersperse "\n"-       -- . map show $ decls-       . map prettyDecl $ decls
− Plugin/Quote.hs 
@@ -1,166 +0,0 @@-{-# LANGUAGE TemplateHaskell, CPP, MultiParamTypeClasses, PatternGuards, TypeSynonymInstances #-}--- | Support for quotes-module Plugin.Quote (theModule) where--import Plugin-import Plugin.Quote.Fortune      (randFortune)-import Plugin.Quote.Text--import qualified Data.Map as M-import qualified Data.ByteString.Char8 as P--$(plugin "Quote")--type Key    = P.ByteString-type Quotes = M.Map Key [P.ByteString]--instance Module QuoteModule Quotes where-    moduleCmds           _ = ["quote", "remember", "forget", "ghc", "fortune"-                             ,"yow","arr","yarr","keal","b52s","brain","palomer"-                             ,"girl19", "v", "yhjulwwiefzojcbxybbruweejw"-                             , "protontorpedo", "nixon", "farber"]--    moduleHelp _ "forget"  = "forget nick quote.  Delete a quote"-    moduleHelp _ "fortune" = "fortune. Provide a random fortune"-    moduleHelp _ "yow"     = "yow. The zippy man."-    moduleHelp _ "arr"     = "arr. Talk to a pirate"-    moduleHelp _ "yarr"    = "yarr. Talk to a pirate"-    moduleHelp _ "keal"    = "keal. Talk like Keal"-    moduleHelp _ "ghc"     = "ghc. Choice quotes from GHC."-    moduleHelp _ "b52s"    = "b52s. Anyone noticed the b52s sound a lot like zippy?"-    moduleHelp _ "brain"   = "brain. Pinky and the Brain"-    moduleHelp _ "palomer" = "palomer. Sound a bit like palomer on a good day."-    moduleHelp _ "protontorpedo" = "protontorpedo is silly"-    moduleHelp _ "girl19"  = "girl19 wonders what \"discriminating hackers\" are."-    moduleHelp _ "v"       = "let v = show v in v"-    moduleHelp _ "yhjulwwiefzojcbxybbruweejw"-                           = "V RETURNS!"-    moduleHelp _ "farber"  = "Farberisms in the style of David Farber."-    moduleHelp _ "nixon"   = "Richad Nixon's finest."--    moduleHelp _ _         = help -- required--    moduleSerialize _       = Just mapListPackedSerial-    moduleDefState  _       = return M.empty--    process_ _ cmd s = case cmd of-          "forget"        -> runForget   (dropSpace s)-          "remember"      -> runRemember (dropSpace s)-          "quote"         -> runQuote    (dropSpace s)-          "ghc"           -> runQuote    ("ghc " ++ dropSpace s)-          "fortune"       -> runit (randFortune Nothing)-          "yow"           -> runit (randFortune (Just "zippy"))--          "keal"          -> rand kealList-          "b52s"          -> rand b52s-          "brain"         -> rand (if "pondering" `isInfixOf` s then brainPondering else brain)-          "palomer"       -> rand palomer-          "girl19"        -> rand girl19-          "protontorpedo" -> rand protontorpedo-          "v"             -> rand notoriousV-          "yhjulwwiefzojcbxybbruweejw"-                          -> rand notoriousV--          -- See, you've got to understand the subtle distinction in pirate-          -- talk between arr and yarr! arr is something you say as an-          -- afermative where as yarr! is more like a greeting. (Or something)-          "arr"           -> rand arrList-          "yarr"          -> rand yarrList-          "farber"        -> rand farberList-          "nixon"         -> rand nixonList--        where-           runit k = return `fmap` io k-           rand = runit . randomElem--help :: String-help = "quote <nick>\nremember <nick> <quote>\n" ++-       "Quote somebody, a random person, or save a memorable quote"------------------------------------------------------------------------------ the @remember command stores away a quotation by a user, for future--- use by @quote---- error handling!-runRemember :: String -> ModuleLB Quotes-runRemember str-    | null rest = return ["Incorrect arguments to quote"]-    | otherwise = withMS $ \fm writer -> do-        let ss  = fromMaybe [] (M.lookup (P.pack nm) fm)-            fm' = M.insert (P.pack nm) (P.pack q : ss) fm-        writer fm'-        r <- random confirmation-        box r-    where-        (nm,rest) = break isSpace str-        q         = tail rest---- @forget, to remove a quote-runForget :: String -> ModuleLB Quotes-runForget str-    | null rest = return ["Incorrect arguments to quote"]-    | otherwise = withMS $ \fm writer -> do-        let ss  = fromMaybe [] (M.lookup (P.pack nm) fm)-            fm' = M.insert (P.pack nm) (delete (P.pack q) ss) fm-        writer fm'-        if P.pack q `elem` ss-            then return ["Done."]-            else return ["No match."]-    where-        (nm,rest) = break isSpace str-        q         = tail rest-------  the @quote command, takes a user nm to choose a random quote from----runQuote :: String -> ModuleLB Quotes-runQuote str = do-    st <- readMS-    io (search (P.pack nm) (P.pack pat) st)-  where (nm, p) = break isSpace str-        pat     = if null p then p else tail p--search :: Key -> P.ByteString -> Quotes -> IO [String]-search key pat db-    | M.null db          = box "No quotes yet."--    | P.null key         = do-        (key', qs) <- random (M.toList db) -- quote a random person-        box . display key' =<< random qs--    | P.null pat, Just qs <- mquotes =-        box . display key  =<< random qs--    | P.null pat         = match key allquotes--    | Just qs <- mquotes = match pat (zip (repeat key) qs)--    | otherwise          = do-        r <- random insult-        box $ "No quotes for this person. " ++ r--  where-    mquotes   = M.lookup key db-    allquotes = concat [ zip (repeat who) qs | (who, qs) <- M.assocs db ]--    match p ss = do-#if __GLASGOW_HASKELL__ >= 606-        re <- do res <- compile (compExtended + compIgnoreCase + compNoSub) 0 p-                 case res of-                    Left  err -> error $ "regex failed: " ++ show err-                    Right r   -> return r-#else-        let re = mkRegexWithOpts (P.unpack p) True True-#endif--        let rs = filter (matches re . snd) ss-        if null rs-            then do r <- random insult-                    box $ "No quotes match. " ++ r-            else do (who, saying) <- random rs-                    box $ P.unpack who ++ " says: " ++ P.unpack saying--    display k msg = (if P.null k then "  " else who ++ " says: ") ++ saying-          where saying = P.unpack msg-                who    = P.unpack k
− Plugin/Quote/Fortune.hs 
@@ -1,62 +0,0 @@-{-# LANGUAGE CPP #-}---- | Fortune.hs, quote the fortune file-module Plugin.Quote.Fortune where--import Config-import Lambdabot.Util (stdGetRandItem, split)-import qualified Lambdabot.Util hiding (stdGetRandItem)--import Data.List-import Control.Monad-import System.Directory-import qualified Control.OldException as C (catch)--#ifndef mingw32_HOST_OS------ No good for win32----import System.Posix (isRegularFile, getFileStatus)-#endif---- | The 'filelist' function returns a List of fortune files from the---   configured 'fortunePath' directory.-filelist :: IO [String]-filelist = do-    filelist'<- C.catch (getDirectoryContents $ fortunePath config)-                        (\_ -> return [])-    let files = filter (not . isSuffixOf ".dat") filelist'-    join (return (filterM isFile (map (fortunePath config ++) files)))---- | Select a random fortune file-fileRandom :: IO FilePath-fileRandom = filelist >>= stdGetRandItem---- | Parse a file of fortunes into a list of the fortunes in the file.-fortunesParse :: FilePath -> IO [String]-fortunesParse filename = do-    rawfs <- C.catch (readFile filename)-                     (\_ -> return "Couldn't find fortune file")-    return $ split "%\n" rawfs---- | Given a FilePath of a fortune file, select and return a random fortune from---   it.-fortuneRandom :: FilePath -> IO String-fortuneRandom = (stdGetRandItem =<<) . fortunesParse---- | Given an optional fortune section, return a random fortune. If Nothing,---   then a random fortune from all fortune files is returned. If Just section,---   then a random fortune from the given section is returned.-randFortune :: (Maybe FilePath) -> IO String-randFortune section = case section of-    Nothing    -> fortuneRandom =<< fileRandom-    Just fname -> fortuneRandom =<< (return (fortunePath config ++ fname))---- | 'isFile' is a predicate wheter or not a given FilePath is a file.-#ifdef mingw32_HOST_OS-isFile :: FilePath -> IO Bool-isFile = doesFileExist-#else-isFile :: FilePath -> IO Bool-isFile = (isRegularFile `fmap`) . getFileStatus-#endif
− Plugin/Quote/Text.hs 
@@ -1,2339 +0,0 @@--- | Some quote text-module Plugin.Quote.Text where---- | Some funny palomer-isms-palomer :: [String]-palomer =-    ["Blargh!"-    ,"Hrmph"-    ,"They're telling you lies!"-    ,"Scalliwags!"-    ,"Pfft"-    ,"Pfft, my type inference algorithm takes hours on a 2 line program"-    ,"Hrmph, looks like I killed the channel"-    ,"As someone who's studied GADTs, I've never found a use for them."-    ,"Category theory is the Paris Hilton of mathematics"-    ,"That's nuts!"-    ,"Brump!"-    ,"I think you're all nuts"-    ,"That's a lie"-    ,"Learning vim is pointless"-    ,"I think vim is good for the rubbish bin"-    ,"xml stands for \"xtremely mild lullaby\""-    ,"woof"-    ,"(_|_)"-    ,"I have news for you, it's pointless"-    ,"You're all nuts"-    ]---- | Some pirate quotes-arrList :: [String]-arrList =-    ["Avast!"-    ,"Shiver me timbers!"-    ,"Yeh scurvy dog..."-    ,"I'll keel haul ya fer that!"-    ,"I want me grog!"-    ,"Drink up, me 'earties"-    ,"Smartly me lass"-    ,"Arrr!"-    ,"Ahoy mateys"-    ,"Aye"-    ,"Aye Aye Cap'n"-    ,"Swab the deck!"-    ,"Keelhaul the swabs!"-    ,"Yo ho ho, and a bottle of rum!"-    ,"I'll crush ye barnacles!"-    ,"Har de har har!"-    ]---- | More pirate quotes-yarrList :: [String]-yarrList =-    arrList ++-    ["I heard andersca is a pirate"-    ,"I'd like to drop me anchor in her lagoon"-    ,"Well me 'earties, let's see what crawled out of the bung hole..."-    ,"Is that a hornpipe in yer pocket, or arr ya just happy ta see me?"-    ,"Get out o' me way, yeh landlubber"-    ,"Yarrr!"-    ,"This is the END for you, you gutter-crawling cur!"-    ,"May the clap make ye incapable of Cracking Jenny's Tea Cup."-    ,"Eat maggoty hardtack, ye unkempt, jenny frequentin', son of a gun."-    ,"What be a priate's favourite cheese?\nYarrlsburg!"-    ,"Where d' all t' pirates come from?\nGreat Yarrmouth!"-    ,"Prepare to be boarded!"-    ,"Gangway!"-    ,"Splice the Mainbrace!"-    ,"Arr! Me ship be the biggest brig in the port!"-    ,"Well Ahoy! thar."-    ]------- Stewie Griffin is great----stewieList :: [String]-stewieList =-    ["You. Fetch me my copy of the Wall Street Journal. You two, fight to the death."-    ,"Yes, I rather like this God fellow. He's very theatrical, you know, a pestilence here, a plague there. Omnipotence. Gotta get me some of that"-    ,"I've got a better idea. Let's go play \"swallow the stuff under the sink.\""-    ,"I've got an army to raise and I must get to Nicaragua. I require a window seat and an in-flight Happy Meal AND NO PICKLES. OH, GOD HELP YOU IF I FIND PICKLES"-    ,"Damn you, vile woman! Blast! What the deuce!"-    ,"Forecast for tomorrow; A few sprinkles of genius with a chance of doom."-    ]------- Actual quotes from an asshat called Keal over Jan 12-14 2006.------ Reappared as OrangeKid,--- 06.10.18:19:44:00 --- join: OrangeKid -- (n=TRK@unaffiliated/Keal) joined #haskell----kealList :: [String]-kealList =-    ["endian mirrors the decimal"-    ,"primary elemental assumption of integer coefficients to roots in counting sytem is wrong"-    ,"actually it bug in math"-    ,"b*(Floor[v/b^p]/b-Floor[Floor[v/b^p]/b])"-    ,"proofs are no longer sound"-    ,"my proof show math is broken right now"-    ,"doctor just give meds not fix prollem"-    ,"Keal was so happy with T, coded in basic so run on anything, and does lot"-    ,"one prollem. T broke confines of the visual basic langage and would not compile"-    ,"perhaps i just genius and never tested"-    ,"and yes that was with zero formal training in all realms"-    ,"somone would expect that trees 500gb hdds of expressions as if they were floppy dicks"-    ,"can you make a macro that builds the expression accoridng to a genetic algorithm where you decide what is good and what is bad?"-    ,"T could perform expressions 600mb and bigger"-    ,"what is the max amount of operands haskell can handle in a single expression?"-    ,"T seems to be haskell, except with a decent interface at this point"-    ,"love a black and white lower 128 from 32 up of ascii glyphs?"-    ,"evaluating expressions is ALL haskell does?????"-    ,"you think i am one of them persnipity uppity men are pig lesbian mathematicians?"-    ,"how bout i say ick no unicorn and daisy loving girl mathematician will ever enjoy this"-    ,"better be atleast 16x16 color with extended ascii set"-    ,"what the hell does Prelude > mean?"-    ,"how do i search for someone saying 'Keal' in mirc"-    ,"i have basically written a proof that shows an assumption is wrong"-    ,"they dumbified you"-    ,"antiparsimony were 100% correct..."-    ,"its because the timeline diverges and past events themselves unhappen"-    ,"all i know is i have experienced my own death unhappening..."-    ," what have you been smoking? you narrow minded Haskell user?"-    ,"i use an 8088"-    ,"are there full body recognition files for sorting art?"-    ,"my very first computer was an 80-0840"-    ,"it is very easy to go off topic"-    ,"someone needs to write a boids for haskell that emulates humans going on and off topic"-    ,"i just got banned from math because i not have good ability to convey thoughts"-    ,"i lack in verbal and social expression"-    ,"i try make program called Glyph to do it but my script lang called T too slow. i invent T"-    ,"can GMP support KealDigit? I invent KealDigit"-    ,"with KealDigit quantum crackproof encryption possible"-    ,"i show how spell triangle in less than three corners using darkmanifold"-    ,"can haskell pipe the raw irrational megaequation into an analog device"-    ,"the fractal is 5 irrationals"-    ,"99% of my book has been erased by faulty hdd's"-    ,"last day i was in my lab i had a diagram which might have removed pi"-    ,"i only trust opensource tools. where can i download haskell for windows?"-    ,"obviously you never heard of Tier. theoretically it would work using nanobots"-    ,"you need a Zh function in Haskell"-    ,"can haskell compile flash animations and java apps?"-    ,"i need math friendly compiler to compile for jvm or flash"-    ,"Cale etc already pointed out Haskell is puny to nothing to emulate using my barrage of mathematic theories"-    ,"i prove infinity never ends in both directions"-    ,"are you saying i am MegaMonad?"-    ,"Keal angry @ dons"-    ,"i can explain why something is without knowing what the rules decided by man are"-    ,"making a bot of me is highly offensive"-    ,"just seeing how offtopic i could get everyone"-    ,"intuitive != imperative"-    ,"doubles and floats cause b*(Floor[v/b^p]/b-Floor[Floor[v/b^p]/b) to fuck up"-    ,"what are epsilons?"-    ,"haskell always said undefined"-    ,"bot seems useless"-    ,"when i put what i dat recoved from that tile into a ti92. the damn thing blew up"-    ,"i think it because mathematics damage you cpu"-    ,"ithink has to do with hardcased government failsafe in chip"-    ,"i suggest you tear apart a 20q and plug it with the alg"-    ,"nsa has all the profiling info you need to come up with the correct survey answers"-    ,"write an algorthim that generates the correct responses for a phone survey based on number of rings whether answered how quickly hung up on and the mood of the receiver"-    ,"where can i find opensource schematics of Linus Torvalds' x86 clone?"-    ,"need to plan a fieldtrip to Frederick B. Mancoff of Freescale Semiconductor"-    ,"ghc need to have plugin that allow copy paste in xp"-    ,"know you know this 24 periods Keal SecretTM"-    ,"tomorrow i share next mathematical secrety"-    ,"nsa prevent me from returning to math on efnet"-    ,"nsa try kill me numerous times"-    ,"#haskell needs to take its meds"-    ,"i think i know what code does but code looks to simple to actually do it"-    ,"need 1 to do a while 0 does !a. need 1 to do a while 0 does !a"-    ,"will it return [] if map gives fpu infinite list?"-    ,"today's 24hour project was supposed to be logical overloading using plegm method"-    ,"there is no way to prove the failsafe exists"-    ,"oh btw my fpu is blown due to a hardcased failsafe i have 3 year warranty right. and then they call fads"-    ,"i aint running that on my puter"-    ,"lamadabot took 5 to 8 whole seconds to return []"-    ,"bot defective"-    ,"i changed my user od"-    ,"i cant think anymore"-    ,"i want to invent white dye"-    ,"pork steaks taste like dick"-    ,"i dont really eat vegetables unless cheese is a vegetable"-    ,"the [nsa] even make light green both ways once"-    ,"i still dont understand how gci is supposed to do anything other than mathematics"-    ]------- Quotes from the lyrics of B52s songs. They remind me (dons) of zippy.----b52s :: [String]-b52s =-    [ "His ear lobe fell in the deep. Someone reached in and grabbed it. It was a rock lobster!"-    , "Watch out for that piranha. There goes a narwhale. HERE COMES A BIKINI WHALE!"-    , "She drove a Plymouth Satellite faster than the speed of light!"-    , "Some say she's from Mars, or one of the seven stars that shine after 3:30 in the morning. WELL SHE ISN'T."-    , "It's a dreary downtown day, but at the end of my 40 foot leash is my little friend quiche."-    , "Girl from Ipanema, she goes to Greenland"-    , "Hot pants explosion at the factory!"-    , "You belong in Ripley's Believe It Or Not"-    ]------- Quotes from the pinky and the brain cartoon----brain :: [String]-brain =-    [("Gee, Brain, what are we going to do tonight?\n"  ++-      "The same thing we do every night, Pinky. Try to take over the world!")-    , "Narf!"-    , "Zort!"-    , "Poit!"-    , "Troz!"-    , "It must be inordinately taxing to be such a boob."-    , "Promise me something, Pinky. Never breed."-    , "Pinky, I am in considerable pain."-    , "Here we are, Pinky--at the dawn of time!"-    ,("Now, Pinky, if by any chance you are captured during this mission, \n" ++-      "remember you are Gunther Heindriksen from Appenzell. You moved to Grindelwald\n" ++-      "to drive the cog train to Murren.  Can you repeat that?")-    ,("Brain! Brain! You aren't going to leave me!!!???" ++-      "You know what happened to Jerry Lewis after Dean Martin left him!!!")-    , "They've turned into giant Swiss leaderhosen-clad dancing yodelers. Talk about unpredictable!"-    , "Be quiet Pinky, or I shall have to hurt you."-    , "If I could reach you I would hurt you."-    ,("What can I do for fun, Pinky? That's it! I'll send several\n" ++-      "bills to Senate for ratification, then veto them all!")-    , "There's only one ride that interests me - the incredible thrill ride of taking over the world!"-    ,("It is here that my cheap workforce of trained iguanas will work\n" ++-      "night and day to make our shoes to my exacting specifications!")-    ,("Has it ever occurred to you, Pinklet, that your scarf is\n" ++-      "constricting the bloodflow to your head?")-    , "Are you pondering what I'm pondering?"-    ] ++ brainPondering-brainPondering :: [String]-brainPondering =-    [ "But where are we going to find a duck and a hose at this hour?"-    , "But where will we find an open tattoo parlor at this time of night?"-    , "Uh... yeah, Brain, but where are we going to find rubber pants our size?"-    , "Uh, I think so, Brain, but balancing a family and a career ... ooh, it's all too much for me."-    , "Wuh, I think so, Brain, but isn't Regis Philbin already married?"-    , "Wuh, I think so, Brain, but burlap chafes me so."-    , "Uh, I think so, Brain, but we'll never get a monkey to use dental floss."-    , "Uh, I think so Brain, but this time, you wear the tutu."-    , "I think so, Brain, but culottes have a tendency to ride up so."-    , "I think so, Brain, but if they called them 'Sad Meals', kids wouldn't buy them!"-    , "I think so, Brain, but me and Pippi Longstocking -- I mean, what would the children look like?"-    , "Well, I think so, Brain, but I can't memorize a whole opera in Yiddish."-    , "I think so, Brain, but there's still a bug stuck in here from last time."-    , "Uh, I think so, Brain, but I get all clammy inside the tent."-    , "I think so, Brain, but I don't think Kaye Ballard's in the union."-    , "I think so, Brain, but, the Rockettes? I mean, it's mostly girls, isn't it?"-    , "I think so, Brain, but pants with horizontal stripes make me look chubby."-    , "Well, I think so, Brain, but pantyhose are so uncomfortable in the summertime."-    , "Well, I think so, Brain, but it's a miracle that this one grew back."-    , "Well, I think so, Brain, but first you'd have to take that whole bridge apart, wouldn't you?"-    , "Well, I think so, Brain, but 'apply North Pole' to what?"-    , "Umm, I think so, Brain, but what if the chicken won't wear the nylons?"-    , "I think so, Brain, but isn't that why they invented tube socks?"-    , "Well, I think so Brain, but what if we stick to the seat covers?"-    , "Oooh, I think so Brain, but I think I'd rather eat the Macarena."-    , "Well, I think so, but Kevin Costner with an English accent?"-    , "I think so, Brain, but don't you need a swimming pool to play Marco Polo?"-    , "Well, I think so, Brain, but do I really need two tongues?"-    , "I think so, Brain, but we're already naked."-    , "I think so, Brain, but Lederhosen won't stretch that far."-    , "Yeah, but I thought Madonna already had a steady bloke!"-    , "I think so, Brain, but how would we ever determine Sandra Bullock's shoe size?"-    , "I think so, Brain, but a codpiece made from a real fish would get smelly after a while, wouldn?t it?"-    , "I think so, Commander Brain from Outer Space! But do we have time to grease the rockets?"-    , "I think so, Doctor. But are these really the legs of a show girl?"-    , "Whuu... I think so, BrainPan! But if running shoes had little feet, wouldn't they need their own shoes?"-    , "I think so, Brain! But ruby-studded stockings would be mighty uncomfortable wouldn't they?"-    , "I think so, Brain! How much deeper would the ocean be if there weren't sponges down there?"-    , "I think so, Brain! But do I have what it take to be the 'Lord of the Dance'?"-    , "I think so, Brain, but I didn't know 90210 was a real zip code! Will Tori be there?"-    , "The game does not conclude until the woman with the eating disorder ululates."-    ]------- Girl 19, Apr 11, 2006----girl19 :: [[Char]]-girl19 =-    ["is this a help channel for hackers-beginners?"-    ,"I have been into not actually hacking, but social engineering"-    ,"I have stolen about 50 msn and yahoo accounts"-    ,"I'm in Moscow, Russia"-    ,"nobody can catch me"-    ,"well.. I never hacked Russians"-    ,"am I supposed to be frantic with terror and anxiety?"-    ,"LOL"-    ,"I've always found myself unequal to the intellectual pressure of programming"-    ]------- v used to be a bug in @eval.  See the logs from April 9, 2006.----notoriousV :: [[Char]]-notoriousV =-    [show "\"\\\"\\\\\\\"\\\\\\"-    ,show "\"\\\"\\\\\\\"\\\\\\\\\\\\\\\"\\\\\\\\\\"-    ,show "\""-    ,show "\"#$%&'()*+,\""-    ,"Exception: <<loop>>"-    ,"Just 'J'"-    ]--protontorpedo :: [String]-protontorpedo =-    [--- comparing haskell-    "wil haskell make mroe more money?",-    "wil I make mroe $$ than learning java or APL or smalltalk or plt scheme or ruby or perl or clisp?",-    "why is haskell bette than java? java has a shitload of frameworks. its xrazy",-    "is haskell doomed to be a mysql driver?",-    "and haskell is not a lisp. correct? holy shit then m learning haskell",-    "is haskell better than APL or perl or clisp?",-    "ok is haskell a type of lisp?",-    "hakell is not lisp or ml right?",-    "how deos haskell differ from ml or lisp?",-    "what makes haskell more fun than say clisp?",-    "here is the big one: is it mroe prctical than say python?",-    "so can haskell do what perl does but simpler?",-    "so haskell is new and improved c?",-    "how does haskell compare to j2ee?",-    "how does j2ee compare to haskell?",-    "can haskell do same stuff as J2EE but nicer?",-    "is haskell able to outdo perl or python for web?",-    "how is smalltalk different from haskell?",-    "how does haskell compare to say java?",-    "can haskell outdo java and jboss n stuff?",-    "how does haskell compare to c++?",-    "how is haskell different than java?",-    "so haskell is different from lisp?",-    "how abut vs APL",-    "what is haskell?",-    "is it nicer than APL?",-    "is haskell nicer than clisp?",-    "what does haskell do better than java perl or ruby?",-    "is it a form of lisp?",-    "why haskell over lisp?",-    "why haskell over say clsip or smalltalk?",-    "so why would one prefer haskell to say clisp or smalltalk?",-    "why haskell over say smalltalk",-    "is haskell more powerful than perl? or scheme?",-    "is haskella lisp?",-    "so haskells better than smalltalk and clsip?",---- more questions-    "what is the best absolute beginner utorial for haskell?",-    "Im wondering if there are uncharted business waters that haskell can enable, even if it is simply by not accepting norms",-    "so is haskell going to redo x windows and make it better?",-    "is haskell going to rewite linux and make it better?",-    "is there going to be a better dns server in haskell?",-    "can haskell be used to develop databases?",-    "evaluation seems ideal for banks who want to know global balances etc.",-    "what is so good about continuations/",-    "is it fun to program in haskell?",-    "paul graham said static typing and ML types fo lisp hurt exploratory progrmaming",-    "why did someone create haskell?",-    "can u build things fast in haskell?",-    "is functional progrmaming the same as object oriented?",-    "I read somewhere that large systms get confusing and haskell ends up a s a bunch of functions",-    "is haskell more powerful than any jedii?",-    "lazy makes macro not needed?",-    "wat is lazy evaluation?",-    "so this java guy I know says that java is the best when things get really complex and u need your apps do do real work",-    "how does haskell do with large systems?",-    "so with 100s of users adn different daabases haskell does fine?",-    "so if I learn haskell i can make cool interactive websites and get rich right?",-    "what echniques can be used to scael application in haskell?",-    "whera re the end user apps?",-    "why would u write a interpreter for perl in haskell?",-    "what Is writen in haskell that gets work done?",-    "so there is no database, monitoring system, web browser, webserver, or scheduling ssytem in haskell?",-    "is there a decent scheduler in haskell? how about a netwrok monitor?",-    "is functional ebtter than oo?",-    "cant u just have data in arrays and do operations using you prog lang?",-    "troll?",-    "cmon Im asking cool questions",-    "Im not a loser",-    "so given that how does haskell let one turn business calcualtion anreocrding of info into somethng liek a big spreadsheet?",-    " and is haskell ez to debug?",-    "am I cracked?",-    "hey guys can haskeel be used to produce fast webapps?",-    "does haskell sclae up to programming in the large?",-    "or does it become a mishmash of code?",-    "as u scale and complexity grows?",-    "so how do you use haskell tools to build large programs?",-    "whats a module?",-    "and haskell is general purpose?",-    "can I build a sales database with it?",-    "can I build something that lets laptop users sync contacts and client dta over the net?",-    "are you wealthy concultants?",-    "does haskel work one windows?",-    "is there an oo db in haskell?",-    "oleg?",-    "please expalin pure and lazy a little (im igonorant i know)?",-    "so haskell is free?",-    "how fast is the haskell web serve for dynamic content? siriam from scheme says the scheme one si FAT AS HEK",-    "how can haskell automate ftp?",-    "how do we automate ftp file transfers with haskell?",-    "what is a good way to handle the ftp transfer and reading of files to mysql?",-    "some dude called topmind says that oo is bs",-    "are objects kina just subroutines",-    "smalltalk is oo",-    "hu me/",-    "its bs dude",-    "that dude is selling u  a book",-    "look at smalltalk. they invented oo proramming",-    "The things I dotn get about relatinal databases is that they take wrok to maintain",-    "I got some info b 4 about how lazy eval makes macros not needed please expand...",-    "waht is this D&D",-    "syntax ur runing my high",-    "on the haskell site they compare haskell to a spreadsheet",-    "how would haskell solve the following gnarley problem: many client distributed accross the usa, transfers must take palce in the form of file transfer, and data must be read from files, and recorded, then other partners who apply taxes to this data and then give abck new files with taxes aded, then last transers to 4th parties who get us paid for the phone calls that are the product",-    "where was haskell during th internet boom?",-    "no I cant read online for long my eyes get fuzzy",-    "help please",-    "treid comon lisp. ansi common lisp bok by graham. it sucked",-    "I dont know any programming yet at 33 dream of learning ti and gettign rich",-    "windows is validating itelf a lot during ownloads altely",-    "why haskell over smalltalk? I thought smalltalked rocked",-    "can haskell do data transfer from box to box over sockets?",-    "is ghc bad for learning?",-    "does huge or ghc have more stuff?",-    "is it hard to set up n ready my pc for programming?",---- statements-    "im such an asshole",-    "I hear from an essay by E raymod that perl is shitty for large projects",-    "ok so say I ftp files from some 50 remote servers now, and then read them inot mysql, then ftp back to an ohter 50 servers some info they read into thier informix db",-    "I personally emailed paul graham the lisp guy today after reading about python in E raymonds essay he metions ruby n python is u cant use lisp",-    "I had one guy tell me he was 16x as fast to develop something in smalltalk",-    "check otu squeak seems dope",-    "I have perl bok but saw haskell and am woner hey this is new and improved and seems powerful because MIT guy philip green says haskell adn lisp are only langs where u spend more tie thinking than coding",-    "paul graham said static typing is a problem for macros building",-    "I dont think tcl cn do that",-    "I am banned from like 6 rooms",-    "scheme, lisp, php, python, perl, tcl, al banned",-    "Im really only a bash person and even then Im tin",-    "i have a win xp box"-    ]---- farberisms from http://www.cs.arizona.edu/icon/oddsends/farber.htm-farberList :: [String]-farberList =-    [-    "We need to rein in our horns.",-    "A problem swept under the table occasionally comes home to roost.",-    "From here on up, it's down hill all the way.",-    "Don't look a charlie horse in the mouth.",-    "He's cornered on all sides.",-    "I don't trust him farther than you can bat an eye.",-    "Don't talk to me with your clothes on.",-    "Put yourself in his boat.",-    "If that happened to me, I'd clean my ears out with a pistol.",-    "It's a white elephant around my neck.",-    "What can we do to shore up these problems?",-    "I have a green thumb up to my elbow.",-    "Let's bend a few lapels.",-    "I'm over the hilt.",-    "The viewpoints run from hot to cold.",-    "Don't look for your balls in someone else's court.",-    "We've taken our eyes off the wrong ball.",-    "That's the way the cookie bounces.",-    "He's sawing his limb off.",-    "Nobody's going to put his neck out on a limb.",-    "Now he's sweating in his own pool.",-    "We have a difference of agreement.",-    "I want to go into that at short length.",-    "The sword works two ways.",-    "Better to toil in anonymity than to have that happen.",-    "Please come here ipso pronto.",-    "I just pulled those out of the seat of my pants.",-    "He's leading down the path to the chicken coup.",-    "I'm gaining weight hand over fist.",-    "I'll fight him hand and nail.",-    "Don't roll up your nostrils at me.",-    "It's wrought with problems.",-    "It's your ball of wax, you unravel it.",-    "Let them fry in their socks.",-    "I'm not a lily-livered sea horse.",-    "It's the vilest smell I ever heard.",-    "It goes in one era and out the other.",-    "It's a lot of passed water under the bridge.",-    "Just remember, this too will come to pass.",-    "Eventually, I want it now.",-    "You're bonking up the wrong tree.",-    "My socks are all bent out of shape.",-    "It's a monkey wrench in your ointment.",-    "He's being pruned for the job.",-    "One doesn't swallow the whole cake at the first sitting.",-    "Let's not cook the goose until it's hatched.",-    "People in glass houses shouldn't call the kettle black.",-    "Familiarity breed strange bed linen.",-    "They're cooking on all cylinders.",-    "We can dig ourselves out of this hole.",-    "It's like the flood of the Hesperis.",-    "It hit the epitome of it.",-    "My mind slipped into another cog.",-    "That would throw a monkey wrench into their ointment.",-    "I'm going to feel it out by the ear.",-    "He's taking the bark off the wrong tree.",-    "He waxed incensive.",-    "I just got my car fixed and it's runnin' like a dime.",-    "Clean up your own can of worms!",-    "We just have to take the grit in our teeth and do it.",-    "It's enough to curl your socks.",-    "Be careful not to throw out the bath water with the baby.",-    "We're biting the foot the feeds us.",-    "He's got a tough axe to hoe.",-    "Don't rattle the cage that feeds you.",-    "Fade out in a blaze of glory.",-    "When in doubt, tread on oily water.",-    "That may cool some socks.",-    "They've reached a new level of lowness.",-    "Take this time line with a large grain of salt.",-    "He's taking his half out of our middle.",-    "He's a little clog in a big wheel.",-    "Float off into several individual conferees.",-    "I've been bitten by the hand that feeds me.",-    "Those guys are as independent as hogs on ice.",-    "Don't bite the hand that stabs you in the back.",-    "I'm going to resolve it by ear.",-    "You can't get more out of a turnip than you put in.",-    "Shoot it up the flag pole.",-    "It's just another coffin nail driven into the morality of the United States.",-    "If I'm going to suffer, I might as well suffer in comfort.",-    "I've got to get my ass together.",-    "Don't look a gift horse in the pocketbook.",-    "I don't want to put all my monkeys in one barrel.",-    "It is better to have tried and failed than never to have failed at all.",-    "Hindsight is 50-50.",-    "I'm smarting at the seams.",-    "Keep the water as firm as possible until a fellow has his feet on the ground.",-    "I won't do it if it's the last thing I do!",-    "Omens are made to be broken.",-    "He came in on my own volition.",-    "His foot is in his mouth up to his ear.",-    "I had to throw some feathers on the troubled water.",-    "It's bouncing like a greased pig.",-    "That's when I first opened an eyelash.",-    "They're arriving like flies.",-    "As a token of my unfliching love ... .",-    "They keep petering in.",-    "They don't stand a tea bag's chance in hell.",-    "I'm your frontface in this matter.",-    "Why put off today what you can do tomorrow?",-    "That's a camel's eye strained through a gnat's tooth.",-    "We know a lot more than we're not telling.",-    "Mother's a little slow around the gills.",-    "You're barking up a tree with no branches.",-    "It's a future idea of the past.",-    "I'd like to put another foot into the pot.",-    "It's sloppy mismanagement.",-    "It was a maelstrom around his neck.",-    "I'm as happy as a pig in a blanket.",-    "They've dumped you in the briar patch and told you to sink or swim.",-    "Conceptual things are in the eye of the beholder.",-    "An enigma is only as good as it's bottom line.",-    "Let's all corrugate over here to view the artist's contraception of our new building.",-    "That was a mere peanut in the bucket.",-    "Sometimes I don't have both sails in the water.",-    "One pig must be the guinea.",-    "Let's skin another can of worms.",-    "It rolls off like a boulder on a duck's back.",-    "If the shoe fits, lie in it.",-    "It's been ubiquitously absent.",-    "That took the edge off the pumpkin.",-    "I'm talking up a dead alley.",-    "Give him enough rope and he will run away with it.",-    "Fry him by his bootstraps.",-    "Does he think he walks on water any differently than anyone else?",-    "Don't lead them down the garden path and cut them off at the knees.",-    "He's got his intentions crossed.",-    "She makes Raquel Welch look like Twiggy standing backwards.",-    "This is a land-breaking case.",-    "He's so far above me I can't reach his bootstraps.",-    "We need to screw our noses to the grindstone.",-    "It's not his bag of tea.",-    "It's like trying to squeeze blood out of a stone.",-    "All our feathers came home to roost.",-    "I'm going to litigate it to the eyeballs.",-    "Don't twiddle your kneecaps at me!",-    "My marbles went over the wall.",-    "She attracted men like flypaper.",-    "He puts on his shirt one leg at a time like everyone else.",-    "It has the potential to peel away a curious can of worms.",-    "He's one of the world's greatest flamingo dancers.",-    "Judge him by his actions, not his deeds.",-    "People who live in ivory towers shouldn't throw glass bricks.",-    "We'll cross that bridge after we've burned it behind us.",-    "You really can't compare us -- our similarities are different.",-    "It's something you're all dying to wait for.",-    "I don't feel any older than I used to be.",-    "That took the starch out of my sails.",-    "Too many cooks upset the apple cart.",-    "No Californian will walk a mile if possible.",-    "The aggressor is on the wrong foot.",-    "Don't throw out the bath water with the baby.",-    "Put that in your pocket and smoke it!",-    "That didn't amount to a hill of worms.",-    "Half a worm is better than none.",-    "I shot my ass in the foot.",-    "She stepped full-face on it.",-    "You're barking up the wrong totem pole.",-    "It rolls off her back like a duck.",-    "I guess I'd better get my duff on the road.",-    "It was a heart-rendering decision.",-    "I'm not sure it's my bag of tea.",-    "Look before you turn the other cheek.",-    "We're willing to throw away the baby with the bath water.",-    "I don't want to be the pie that upset the apple cart.",-    "Nostalgia just isn't what it used to be.",-    "It's just a small kink in the ointment.",-    "I came within a hair's breathe of it.",-    "Don't talk to me while I'm interrupting.",-    "He's just a big bullyrag.",-    "Is he an Amazon!",-    "I'll take it one bird at a time.",-    "It's not an easy thing to get your teeth wet on.",-    "I hear the handwriting on the wall.",-    "Pandora's cat is out of the bag.",-    "Rome wasn't built on good intentions alone.",-    "I have no personal bones to grind about it.",-    "Our company is like a living orgasm.",-    "We've got a cash cow that's turning into a dog that needs milking.",-    "You're about as observant as a wet hen.",-    "It's like Goliath and Gomorrah.",-    "Her enthusiasm got carried away.",-    "A rocky road is easier to travel than a stone wall.",-    "Let me flame your fan.",-    "The bloom is off the pumpkin.",-    "I'm going right over the bend.",-    "They'll carve that spectrum any way we desire it.",-    "Don't pour oil on muddy water.",-    "You saw right through my transparency.",-    "He grates me the wrong way.",-    "Let's shoot holes at it.",-    "Don't put all your chickens in one basket.",-    "I did it sitting flat on my back.",-    "I have ears like a hawk.",-    "He won't last. He's just a flash in the pants.",-    "That really throws a monkey into their wrench.",-    "You bet your bottom bootie I don't!",-    "I don't want to open up a red herring here.",-    "They are just prostituting the ills of the world.",-    "I'm walking on cloud nine.",-    "I wouldn't take him on a ten foot pole.",-    "Run it up the flag pole and see if it salutes.",-    "It flows like water over the stream.",-    "If I've told you a hundred times, I've told you twice.",-    "99% of this game is half mental.",-    "I'm as happy as a clam in a fritter.",-    "He's as deaf as a bat.",-    "Any night in a storm.",-    "I'm bored out of my tree.",-    "Today's forecast is for wildly scattered showers.",-    "He's out of his shallow.",-    "Good riddance aforethought.",-    "If I could drop dead right now, I'd be the happiest man alive.",-    "Don't put all your ducks in one basket.",-    "There are no easy bullets.",-    "Try thinking outside the egg carton for a change.",-    "I'm up to my earballs in confusion.",-    "The grocer's son always has shoes.",-    "It runs the full width of the totem pole.",-    "We'll have to sandwich everything we do under this one umbrella.",-    "I don't toe to any cow.",-    "He's a shirking violet.",-    "Don't jump off the gun.",-    "Let's not reinvent a dead horse.",-    "He has a marvelous way of extruding you.",-    "Don't count your fleas before they find dogs.",-    "That's worse than running chalk up and down your back.",-    "They run across the gamut.",-    "I'm as happy as cheese at high tide.",-    "It went over like a thud.",-    "My off-the-head reaction is negative.",-    "Make hash while time flies.",-    "Those words were very carefully weasled.",-    "She's steel wool and a yard wide.",-    "I wouldn't give it to a wet dog.",-    "The future is not what it used to be.",-    "I case my ground very well before I jump into it.",-    "A shoe in time saves nine.",-    "All the hills of beans in China don't matter.",-    "You're barking down the wrong well.",-    "It has more punch to the unch.",-    "I'm not much for tooting my own galoot.",-    "This ivory tower we're living in is a glass house.",-    "Clean up or fly right.",-    "Hold on real quick.",-    "Beggars can't look a gift horse in the mouth.",-    "He got up on his high heels.",-    "There's no point in spilling milk on a barn door that has hatched.",-    "It's like trying to light a fire under a lead camel.",-    "He should be gracious for small favors.",-    "It's as flat as a door knob.",-    "That's a kettle of different fish.",-    "Let sleeping uncertainties lie.",-    "There's a wart in the ointment.",-    "Fish or get off the pot!",-    "Boy, he sure gandered her.",-    "It's milk under the dam.",-    "That's a whole different ball of wax.",-    "At the end of every pot of gold, there's a rainbow.",-    "It goes out one ear and in the other.",-    "No sooner said, the better.",-    "I'm keeping me ear to the grindstone.",-    "Go fly your little red wagon somewhere else.",-    "Dig yourself a hole and bury it.",-    "Erase that indelibly from your memory.",-    "He's as loony as a fruitcake.",-    "He was walking along with his head in the sand.",-    "Everyone has a monkey on their back; you just have to spank your monkey.",-    "Our backs are up the wall.",-    "He's as happy as a stuffed pig.",-    "It's the Achilles' heel of the Trojan Horse.",-    "I'm close to the edge of my rope.",-    "To write a really good letter of recommendation, use all the best expletives.",-    "That just muddles the water.",-    "I'm up a wrong alley.",-    "I've worked my shins to the bone.",-    "Don't make a molehill out of a can of beans.",-    "I need to get on my Little Red Riding Horse.",-    "He has the character of navel lint.",-    "Give him a project to get his teeth wet on.",-    "Any storm in a port.",-    "Put the onus on the other foot.",-    "Do not fumble with a woman's logic.",-    "Don't bite the hand of the goose that lays the golden eggs.",-    "The project is going down the toilet in flames.",-    "I run to my own drummer.",-    "Roll out the Ouija ball.",-    "My impasse hit a roadblock.",-    "It always looks the worst after the water is under the bridge.",-    "I need to rein in my horns.",-    "If you see loose strings that have to be tied down that are not nailed up, see me about it.",-    "It got left out in the lurch.",-    "I've got a real beef to grind with that guy.",-    "He hit the nose right on the head.",-    "I'm not going to get side tracked onto a tangent.",-    "He was left out on the lurch.",-    "I'll stay away from that like a 10-foot pole.",-    "The groundwork is thoroughly broken.",-    "I have a rot-gut feeling about that.",-    "Hey, let's not go off half-crocked.",-    "Don't do anything I wouldn't do standing up in a hammock.",-    "A chain is only as strong as its missing link.",-    "Let's not open the skeleton in that closet.",-    "That's no sweat off my back.",-    "He popped out of nowhere like a jack-in-the-bean-box.",-    "I've got a card in my hole.",-    "Trying to get a doctor on Wednesday is like trying to shoot a horse on Sunday.",-    "There's going to be hell and high water to pay.",-    "It's a sight for sore ears.",-    "It's like harnessing a hare to a tortoise.",-    "There aren't any worms in his backyard.",-    "I'm going to cast my rocks to the wind.",-    "I was really impressed by the mask of Two Ton Carmen.",-    "It's a hot issue that dried up.",-    "Man cannot eat by bread alone.",-    "That's the other end of the coin.",-    "There's a dark cloud on every rainbow's horizon.",-    "I sit corrected.",-    "The atmosphere militates against a solution.",-    "What could help might work in retrospect.",-    "He's paying through the neck.",-    "The ball is in our lap.",-    "There hasn't been much of a peep about it.",-    "He's the pineapple of my eye.",-    "Mind your own petard!",-    "We didn't know which facts were incorrect.",-    "They don't like to dictate themselves to the problem.",-    "He was a living legend while he was alive.",-    "I know what we have to do to get our feet off the ground.",-    "Don't just stand there like a sitting duck.",-    "Sometimes you can learn a lot by watching.",-    "He smokes like a fish.",-    "I'm out of my bloomin' loon.",-    "Indiscretion is the better part of valor.",-    "One man's curiosity is another man's Pandora's box.",-    "His feet have come home to roost.",-    "Let's not drag out dead ghosts.",-    "She had an aurora of goodness about her.",-    "French-fried hairballs!",-    "I must stop beating my head against a dead horse.",-    "She has eyes like two holes in a burnt blanket.",-    "Never the twixt should change.",-    "It's a mare's nest in sheep's clothing.",-    "I'll let it circulate around to my post-frontal lobes.",-    "The yard arm is in your court.",-    "Don't push the flap on the envelope.",-    "I'll descend on them to the bone.",-    "Don't upset the apple sauce.",-    "The pipeline has ramped up.",-    "They're be chick peas in every pot.",-    "Don't hang you dirty linen on my caboose.",-    "I'm as happy as a stuck pig.",-    "Keep your ear peeled!",-    "I have my oars in too many boats.",-    "He's a fruit-ball.",-    "In this period of time, its getting very short.",-    "Not me, I didn't open my peep.",-    "Don't muddle the waters.",-    "I pulled my feet out from under my rug.",-    "She looks like she's been dead for several years, lately.",-    "He's feathering his own empire.",-    "If you can't do it at all, don't do it well.",-    "To sweeten the pie, I'll add some cash.",-    "There's some noise afoot about the problem.",-    "He keeps his ear to the vine.",-    "A buck in the hand is worth two on the books.",-    "He's procrastinating like a bandit.",-    "I's as finished as I'm going to take.",-    "They should goose up their technical support.",-    "It's no chip off my clock.",-    "Nobody marches with the same drummer.",-    "We shoot ourselves in the wrong feet sometimes.",-    "That's a two-edged circle.",-    "Don't look a dead horse in the mouth.",-    "A two-pawn approach is necessary.",-    "We have all passed a lot of water since then.",-    "Three hands make for lighter work.",-    "I want quality, not quantity, but lots of it.",-    "Now the laugh is on the other foot!",-    "Somebody's flubbing his dub.",-    "I need to get my ass on.",-    "He bought his own limb and crawled out on it.",-    "That's a bird of a different color.",-    "This office requires a president who will work right up to the hilt.",-    "You are never going to fail unless you try.",-    "He's reached the crescent of his success.",-    "There's no point in grasping at straws when you're barking up the wrong tree.",-    "It's the screws of progress.",-    "My head is closing in on me.",-    "You can just take your hand basket to hell!",-    "Why procrastinate now when you can wait until tomorrow?",-    "He pulled himself up on top of his own bootstraps.",-    "It's all water under the dam.",-    "My ebb is running low.",-    "Uneasy sits the head ... .",-    "They were made up to the gills.",-    "I've got to put my duff to the grindstone.",-    "Don't look a mixed bag in the mouth.",-    "It's going to knock his socks right off his kneecaps.",-    "It's a catch 20-20.",-    "Like the shoemaker's children, we have computers running out of our ears.",-    "It scared him off his pants.",-    "It might have been a figment of my illusion.",-    "I'm listening with baited ears.",-    "A stitch in time saves oil on troubled waters.",-    "He's got the guts to be courageous.",-    "It's a fluid thing that can swing on a dime.",-    "We're up to our armpits in frozen alligators.",-    "We have some outstanding gray areas.",-    "It's the straw that broke the ice.",-    "He's working like a banshee.",-    "I can't get a straight thought in edgewise.",-    "Have we been cast a strange eye at?",-    "Let a sleeping dog call the kettle black.",-    "That's the way the old ball game bounces.",-    "I have people crawling out of my ears.",-    "We got the story post hoc.",-    "I've got the fort nailed down.",-    "Cheapness doesn't come free.",-    "He disappeared from nowhere.",-    "Boy, is that decapitated.",-    "Don't stick your oar in muddy waters.",-    "When in Rome, do as the Romans do: stay away from the place.",-    "It's a fiat accompli.",-    "We'd better jump under the bandwagon before the train leaves the station.",-    "A bachelor's life is no life for a single man.",-    "This is a farbarbarism!",-    "My foot is going out of its mind.",-    "Don't pull a panic button.",-    "I'm the top dog lion.",-    "No one can predict the wheel of fortune as it falls.",-    "You're treading on thin water.",-    "You've always been the bone of human kindness.",-    "He's salivating at the chops.",-    "We're caught between a rock and a wet spot.",-    "Let's look at it from the other side of the view.",-    "I don't want to throw a wrench in the ointment.",-    "Don't cut off your ass to spite your face.",-    "In one nose, out the other.",-    "He's seething at the teeth.",-    "This will shock you nude.",-    "It's a new high in lows.",-    "They just want to chew the bull.",-    "He's a splitting image of the candidate.",-    "His eyeballs perked up.",-    "He's stone blind.",-    "Get the hot poop right off the vine.",-    "Keep this under your vest.",-    "It may seem incredulous, but it's true.",-    "It's your turn in the apple cart.",-    "It goes from one gamut to another.",-    "I'm not trying to grind anybody's axes.",-    "HE doesn't look like he has a scruple in his head.",-    "He's a key cog in the ointment.",-    "He's a real squash buckler.",-    "There's a strong over current here.",-    "I'm signing my own death knell.",-    "You're barking  up the wrong tree stump.",-    "My ears are ringing off the wall.",-    "They're breathing down our nose.",-    "I'm losing pens like they were dishwater.",-    "They fell all over their faces.",-    "I need to get my ass together.",-    "Any golden parachute in a storm.",-    "She's greasing her own spoon.",-    "Don't rattle the cage that bites you.",-    "Let's go outside and commiserate with nature.",-    "He reminds me of Zorba the Geek.",-    "It's a tempest in a teacup.",-    "This is for your FYI.",-    "If you're waiting for Hell to freeze over, you're skating on thin ice.",-    "That was almost half done unconsciously.",-    "That's a measle-worded statement if I ever heard one.",-    "Beware a horse weaving a Trojan blanket.",-    "If you'd let me, I'd forget the shirt off my back.",-    "That would drive him right out of his banana.",-    "One does not want to let the government's nose under the camel.",-    "They've got the bull by the tail now.",-    "We don't want a neophyte we have to wet nurse.",-    "It plunged all over the place.",-    "I have to get my act in gear.",-    "He's too smart for his own bootstraps.",-    "Everything's all ruffled over.",-    "That sure takes the steam out of the sails.",-    "We'll burn that bridge when we get to it.",-    "I'm wimping at the seams.",-    "I'm ground up to a high pitch.",-    "I guess I'm putting all my birds in one pie.",-    "The importance of that cannot be underestimated.",-    "Give him a square shake.",-    "Put your knuckles to the grindstone.",-    "I can do it with one eye tied behind me.",-    "Let's stop beating around a dead horse and cut right to the mustard.",-    "It's going to go up the tubes.",-    "Nobody could fill his socks.",-    "I'm going to blow their socks out of the water.",-    "That makes me as mad as a wet hatter.",-    "There's a missing gap somewhere.",-    "Now we have some chance to cut new water.",-    "The system got caught with its pants down.",-    "She could charm the door knobs off the top of a temple.",-    "That doesn't cut any weight with him.",-    "That aspect permutes the whole situation.",-    "I'm Pepto-bilious.",-    "I'm up against a blind wall.",-    "I'd as soon wipe my nose with a pot holder as get in bed with him.",-    "Necessity is the mother of strange bed linen.",-    "They closed the doors after the barn was stolen.",-    "It was an infringement of my imagination.",-    "Better sorry than safe.",-    "I'm going right out of my bonker.",-    "You're a sore sight for eyes.",-    "It peaked my interest.",-    "There's a lot of blanche here to carte.",-    "They're like two chick peas in a pod.",-    "It's a tough road to haul.",-    "The eggs we put all in one basket have come home to roost.",-    "Don't oil your feathers with troubled water.",-    "I'm just about to lose my gourd.",-    "I wouldn't throw a wet blanket on a cold turkey if I were you.",-    "He's barking down the wrong tree.",-    "It's a sight to make your eyes water.",-    "This makes me so sore it gets my dandruff up.",-    "Get off the stick and do something.",-    "Sometimes fact is stranger than truth.",-    "I'm up to my earballs in garbage.",-    "It's the blind leading the deaf.",-    "He's trying to get his bearing together.",-    "They're germs in the rough.",-    "It's not my cup of pie.",-    "Peanut butter jelly go together hand over fist.",-    "He's singing a little off-keel.",-    "I can smell the finish line.",-    "That's way down in the chicken feed.",-    "I don't always play with a full house of cards.",-    "It's not that kind of zero.",-    "That's a different cup of fish.",-    "It's under closed doors.",-    "Screwed by my own petard, as it were.",-    "The lights are so bright the air is opaque.",-    "If we keep going this way, somebody is going to be left standing at the church with his pants on.",-    "They've done that before and in the past.",-    "He's as happy as clam chowder.",-    "I heard it out of the corner of my ear.",-    "You hit it right on the nail.",-    "I was thinking out of the corner of my eye.",-    "I had to make a split decision.",-    "It's a small weenie in the fast-food restaurant of life.",-    "He's spending a lot of brunt on the task.",-    "I want to get more fire into the iron.",-    "I don't know what else I can do ... my shoes are tied.",-    "I'm mad enough to fry a wet hen.",-    "It's going to fall on its ass from within.",-    "He's off in a cloud of \"hearty heigh-ho Silver\".",-    "It's the bird song of paradise.",-    "You're eating like wildfire.",-    "If there's no fire, don't make waves.",-    "You should talk to her; she's a mind field of information.",-    "He's somewhere down wind of the innuendo.",-    "Speaking off the hand, I'd advise you to quit.",-    "Don't open Pandora's can of worms.",-    "He's as ugly as Godzilla the Hun.",-    "Don't throw a monkey wrench into the apple cart.",-    "Let me take you under my thumb.",-    "Don't pull out the rug from under the horses in midstream.",-    "Vision is in the eyes of the beholder.",-    "The domestic problems are a terrible can of worms.",-    "I'm bored stuffless.",-    "I'd lose my screw if it wasn't on my head.",-    "I'm in my reclining years.",-    "All you have to do is fill in the missing blanks.",-    "Play one excuse against another.",-    "I'm parked somewhere in the boondoggles.",-    "They're falling on hollow ears.",-    "Don't morbidize me!",-    "We are on equally unfooted ground.",-    "It's good to get a taste of someone else's moccasins.",-    "It caught me out of the blue.",-    "All the lemmings are coming home to roost.",-    "Let's talk to the horse's mouth.",-    "Bend over backwards too far and you'll fall flat on your face.",-    "If anything, I bend over on the backwards side.",-    "He would forget his head if it weren't screwed up.",-    "That's enough to make your sock explode.",-    "The world is closing in on my head.",-    "Things are going to a hand basket in hell.",-    "No loaf is better than half a loaf at all.",-    "It's your turn in the bottom of the barrel.",-    "Go for the juggler!",-    "He doesn't let any moss grow under him.",-    "A look from here would melt his socks.",-    "He's like a wine glass in a storm.",-    "I only mentioned it to give you another side of the horse.",-    "Don't count your chickens until the barn door is closed.",-    "He doesn't know his hole from an ass in the ground.",-    "To be a leader, you have to develop a spear de corps.",-    "He's king bee.",-    "Don't pour troubled oil into the water.",-    "That report reads like a bleached whale.",-    "Our product will eat the pants off the competition!",-    "If they do it there won't be a living orgasm left.",-    "I apologize on cringed knees.",-    "It's an ill wind that doesn't dry someone's clothes.",-    "It's going to bog everybody up.",-    "Right off the top of my cuff, I don' know what to say.",-    "He has an agenda to grind.",-    "I've had more girls than you've got hair between your teeth.",-    "They've got their heads squirreled upside down.",-    "Put it in a guinea sack.",-    "He's bailing him out of the woods.",-    "Don't kiss a gift horse in the mouth.",-    "I'm torn between a rock and a hard place.",-    "It's all above and beyond board.",-    "Your ass is going to be mud.",-    "We might as well be hanged for an inch as for a mile.",-    "He has his ass on the wrong end of his head.",-    "It's the sine quo non of necessity.",-    "The restaurants are terrible -- the town is completely indigestible.",-    "I have the mind of a steel trap.",-    "This business is being run by bean-pushers.",-    "It leaks like a fish.",-    "We'll put our mouth where our money is.",-    "Not by the foggiest stretch of the imagination!",-    "Don't throw feathers on oily water.",-    "We're on the foreskin of modern technology.",-    "I'm just about out of my bonker.",-    "His position is not commiserate with his abilities.",-    "Come down off your charlie horse.",-    "Do you have your screws on right?",-    "That's going to be the gravy on the cake!",-    "I'm creaking at the seams.",-    "We'd better toe the yard arm.",-    "When the tough get going they let sleeping does lie.",-    "His limitations are limitless.",-    "There are two sides to every marshmallow.",-    "I threw the tie iron in the fire.",-    "They're dropping his course like flies.",-    "No dust grows under her feet.",-    "Don't let the government's nose under the camel.",-    "It's like a raft on roller skates.",-    "They've got everything from soup to hairballs.",-    "My antipathy runneth over.",-    "Don't father-hen me!",-    "It's a fool's paradise wrapped in sheep's clothing.",-    "Not in a pig's bladder you don't.",-    "Don't upset the apple pie.",-    "Don't count your high horses before they come home to roost.",-    "Every cloud has a blue horizon.",-    "Half the lies they tell me aren't true.",-    "That's an unexpected surprise.",-    "I'll give you a definite maybe.",-    "Don't throw the baby out with the dishwasher.",-    "A woman has no hell like a fury scorned.",-    "I think you might have hit the nail on the button.",-    "Let me clarify my fumbling.",-    "He's clam bait.",-    "He's trying to pull the buffalo over our eyes.",-    "I'm going to read between your lines.",-    "I can't underestimate how good he is.",-    "I think I've lost my bonkers.",-    "I heard it out of the corner of my eye.",-    "It's the holy grail of naughtiness.",-    "The autumn leaves are in full bloom.",-    "See the forest through the trees.",-    "It's enough to drive a bat up the wall.",-    "Get that albatross off his back!",-    "I'm all raveled up.",-    "We'd be biting off a new can of worms.",-    "Fellow alumni run thicker than water.",-    "We have a wild card in the soup.",-    "I reject it out of the whole cloth.",-    "It's as easy as falling off a piece of cake.",-    "She's trying to feather her own bush.",-    "You can't feed old tricks to a new dog.",-    "They don't work worth lima beans.",-    "I'm not going to bail him out of his own juice.",-    "He puts his pants on two legs at a time like everyone else.",-    "That throws a monkey wrench in the soup.",-    "He wears his finger on his sleeve.",-    "There's nothing like stealing the barn door after the horse is gone.",-    "If you don't want words put in your mouth, don't leave it hanging open.",-    "He has his crutches around her throat.",-    "They are very far and few between.",-    "They're spreading like wild flowers.",-    "They're over the pale.",-    "That's a horse of a different feather.",-    "She's got it up to her ears.",-    "We were looking out for our own bootstraps.",-    "Let's not hurdle into too many puddles at once.",-    "I worked my toes to the bonenail.",-    "Today I was singing 'Snowflakes roasting on an open file'.",-    "He's as elusive as the abdominal snowman.",-    "I resent the insinuendoes.",-    "This wine came from a really great brewery.",-    "He didn't flinch an eyelid.",-    "It's a tour de farce.",-    "It's a virgin field pregnant with possibilities.",-    "There's a little life in the old shoe yet.",-    "Don't sink the boat that lays the golden egg.",-    "Don't criticize him for lack of inexperience.",-    "That restaurant is so crowded no one goes there anymore.",-    "Go ahead; I'm all ear lobes.",-    "It's too much for it's own boots.",-    "I'm so hungry I could eat a cannibal.",-    "We won't turn a deaf shoulder to the problem.",-    "We're biting ourselves in the foot.",-    "He's been living off his laurels for years.",-    "Have the seeds we've sown fallen on deaf ears?",-    "The people are too nameless to number.",-    "Just remember that, and then forget it.",-    "That's not my sack of worms.",-    "I owe you a great gratitude of thanks.",-    "It's so unbelievable you wouldn't believe it.",-    "You're barking up the wrong lamp post.",-    "He's foot sure and fancy free.",-    "I'm as happy as a clambake.",-    "An ounce of prevention is better than pounding the table.",-    "It's the other end of the kettle of fish.",-    "I'm weighted down with baited breath.",-    "It's like finding hen's teeth in August.",-    "I've built enough fudge into that factor.",-    "He has the courage of a second-story man.",-    "That puts the onus on the other shoe.",-    "Get off your Little red Riding Hood.",-    "The seeds I've sown have come home to roost.",-    "Let it slip between the cracks.",-    "We have to read between the tea leaves.",-    "I'm losing touch by leaps and bounds.",-    "Let's get down to brass facts.",-    "I have too many cooks in the pot already.",-    "I'm the happiest little clam in the fritter.",-    "It's no sweat off my nose.",-    "I'm going off tangentially.",-    "One back scratches another.",-    "I wouldn't trust her to throw out the baby with the bath water.",-    "The horse is stolen before the barn even gets its door closed.",-    "I had her by the nap of the neck.",-    "That's spilt water under the bridge.",-    "Abandon ship, all ye who enter here.",-    "I'm right on the edge of my rope.",-    "That makes the hair on the back of my neck really stick in my craw.",-    "There's laughing on the outside, paneling on the inside.",-    "A lot of these arguments are fetious.",-    "I've had it up to the hilt.",-    "He's like Godzilla the Hun.",-    "I'm too uptight for my own bootstraps.",-    "Rolling toads gather no moss.",-    "We need to retain our strategic disadvantage.",-    "Don't look a gift horse in the left foot.",-    "All my lemmings came home to roost.",-    "They make strange bedfellows together.",-    "Don't look for a gift in the horse's mouth.",-    "You put all your eggs before the horse.",-    "This mess would make Humpty Dumpty bleed.",-    "There's some trash to be separated from the chaff.",-    "Look at the camera and say 'bird'.",-    "If King Tut were still alive, we'd be dead meat.",-    "You pay through the noodle for it.",-    "There are just too many hands to feed.",-    "I had to scratch in the back recesses of my memory.",-    "I'll be there in the next foreseeable future.",-    "He's the king of queens.",-    "I's got rats in his belfry.",-    "I wouldn't do it for a ton of bricks.",-    "Not on your bootstraps!",-    "He's the kind of guy that doesn't like it when anything out of the abnormal happens.",-    "They're very far and few between.",-    "I had a monumental idea last night, but I didn't like it.",-    "I can't hum a straight tune.",-    "I'm on my last nerve with that person.",-    "It hit me to the core.",-    "You have to take the bitter with the sour.",-    "Actually, I'm a day owl.",-    "Let a dead horse rest.",-    "Dot your t's and cross your i's.",-    "We better cover our ass and put it on their heads.",-    "Time and tide strike but once.",-    "You need some hair of the chicken.",-    "Things are getting a little sloppy around the gills.",-    "I'm pulling something over on you.",-    "There's one difficult apple in the barrel.",-    "It's spearing like wildflowers!",-    "It's a silk purse stuffed with sow's ears.",-    "I put the onus entirely on my own shoes.",-    "There's more than one way to swing a cat.",-    "I want to see the play like a hole in the head.",-    "I've been eating peanuts like they were coming out of my ears.",-    "I think that we are making an out-and-out molehill of this issue.",-    "I think the real crux is the matter.",-    "If they had to stand on their own two feet, they would have gone down the drain a long time ago.",-    "Better safe than sadistic.",-    "I'm sitting on the edge of my ice.",-    "Don't pull an enigma on me.",-    "He's riding the crest of his momentum.",-    "Don't burn your bridges until you come to them.",-    "For a change, the foot is on the other sock.",-    "It will take a while to ravel down.",-    "I would imagine he chafes a bit.",-    "They're a bunch of pushers and shavers.",-    "It's another millstone in the millpond of life.",-    "It goes from tippy top to tippy bottom.",-    "He can't hack the other can of worms.",-    "He's not breathing a muscle.",-    "Everything is going all bananas.",-    "Don't let the camels get their feet in the door.",-    "It's a Byzantine thicket of quicksand.",-    "Don't rock the boat that feeds you.",-    "She makes Atilla the Nun look like the Virgin Mary.",-    "He's got a rat's nest by the tail.",-    "They've beaten the bushes to death.",-    "He's up a creek with his paddles leaking.",-    "I see several little worms raising their heads around the corner.",-    "We have to understand the theoretical tenants here.",-    "Part of the verbiage is a language thing.",-    "History is just a repetition of the past.",-    "That's a pretty dicament.",-    "It's a mute point.",-    "I have other cats to fry.",-    "It looks like it's going to go on ad infinitum for a while.",-    "I'll fight to the nail.",-    "That's a sight for deaf ears.",-    "It's an abomination in sheep's clothing.",-    "I haven't bitten off an easy nut.",-    "I did it from start to scratch.",-    "Don't cast a gander upon the water.",-    "They sure dipsied his doodle.",-    "He's lying through his britches.",-    "The customer is always right-handed.",-    "The fruits of our labors are about to be felt.",-    "The meaning of the phrase should be clear after some medication.",-    "If they do that, they'll be committing suicide for the rest of their lives.",-    "Don't cast doubts on troubled waters.",-    "Hair balls of the world, unite!",-    "We all have to die some day, if we live long enough.",-    "And I take the blunt of it!",-    "I'm getting my revenge back.",-    "I wouldn't take it for granite, if I were you.",-    "Too many cooks call the kettle black.",-    "Good grace is in the eye of the beholder.",-    "That old witch gave me the eagle eye.",-    "It will spurn a lot of furious action.",-    "That would pry the socks off a dead cat.",-    "Those are good practices to avoid.",-    "I can't remember, but it's right on the tip of my head.",-    "Everything is ipso facto.",-    "It's hanging out like a sore tongue.",-    "They're breathing down my door.",-    "We don't want to get enhangled in that either.",-    "Take advantage of the carpe diem.",-    "Let's play the other side of the coin.",-    "That's the whole kettle of fish in a nutshell.",-    "The grass is always greener when you can't see the forest for the trees.",-    "Tread lightly on the face of the void.",-    "It's not really hide nor hair.",-    "I have feedback on both sides of the coin.",-    "Drop the other foot, for Christ's sake!",-    "He's running off at the seams.",-    "We're teetering on the edge of the brink.",-    "Between these words, fathoms have been said.",-    "He might be barking at a red herring.",-    "The up-kick of all that will be nothing.",-    "In the kingdom of the blind the one-eyed horse is king.",-    "He wants to get his nose wet in several areas.",-    "There are too many cooks and not enough Indians.",-    "It's more than the mind can boggle.",-    "He's lost his noodles.",-    "Let me transition away.",-    "That job is at the bottom of the rung.",-    "Don't disgruntle my feathers.",-    "The hand is on the wall.",-    "I'm tired from being exhausted.",-    "We snarled our teeth.",-    "That's a whole new ball park.",-    "Being able to roll with the punches comes with the territory.",-    "That's getting to the crotch of the matter.",-    "I can remember everything -- I have a pornographic mind.",-    "In one mouth and out the other.",-    "Abandon ship all you who enter here!",-    "Watch her -- she gets on the stick very quickly.",-    "She's masquerading under false pretenses.",-    "It's like a knife through hot butter.",-    "I'll see it when I believe it.",-    "Let's not get ahead of the bandwagon.",-    "To coin a cliche, let's have at them.",-    "He behaves louder than words.",-    "I'll hit him right between the teeth.",-    "There's a rotten apple in every barrel.",-    "There's only so many times you can beat a dead horse.",-    "Would you please cast a jaundiced gander at this?",-    "I only read it in snips and snabs.",-    "I'm going to put a little variety in your spice of life.",-    "Let's roll up our elbows and get to work.",-    "I wouldn't give you a pound of belly-button lint for that.",-    "Get on with the bandwagon, or get out of the pot.",-    "He's running around like a head with its chicken cut off.",-    "Let them hang in their own juice.",-    "The initiative is on the wrong foot.",-    "I thought I'd fall out of my gourd.",-    "Never judge a book by its contents.",-    "Heads will fry over this.",-    "He has the attention span of a fig newton.",-    "There must be a Godzilla of those things in there!",-    "This town is too big for both of us.",-    "Necessity is a mother.",-    "That'll fry the socks off your feet.",-    "Friends don't let friends drive them to drink.",-    "More and more people are asking for fewer and fewer pieces of the pie.",-    "Anybody who marries her would stand out like a sore thumb.",-    "It's like pulling hen's teeth.",-    "He couldn't see his way out of a paper bag.",-    "It's like talking to a needle in a haystack.",-    "In one follicle, out the other.",-    "I don't feel like the sharpest button on the beach today.",-    "We're going to where we're going.",-    "I'll keep my nose peeled.",-    "He got taken right through the nose.",-    "He rules with an iron thumb.",-    "It sounds like roses to my ears.",-    "That really took the steam out of their sails.",-    "Never accept an out-of-state sanity check.",-    "It dates back to the Holy Roller Empire.",-    "Better never than late.",-    "I don't want to cast a pall on the water.",-    "He may be the greatest piece of cheese that ever walked down the plank.",-    "Give him an inch and he'll screw you.",-    "There's a war in my ointment.",-    "Strike while the cat is hot.",-    "I wouldn't want to be sitting in his shoes.",-    "I see the carrot at the end of the tunnel.",-    "Too many chiefs spoil the soup.",-    "Don't pour oil on troubled feathers.",-    "It's music to your eyes.",-    "I need to find out where his head is coming from.",-    "He's an incremental creep.",-    "We're scraping the bottom of the iceberg.",-    "Don't jump on a ship that's going down in flames.",-    "Let him try this in his own petard!",-    "The next time I take you anywhere, I'm leaving you at home.",-    "My train of thought went out to lunch.",-    "Medicate on it.",-    "I don't know which dagger to clothe it in.",-    "Feather your den with somebody else's nest.",-    "My head is twice its size.",-    "A lot of things are going to be bywashed.",-    "I was working my balls to the bone.",-    "It gets grained into you.",-    "Cut bait and talk turkey.",-    "I got you by the nap of your neck.",-    "He's too clever for his own bananas.",-    "Pick them up from their bootstraps.",-    "He's as loony as a jay bird.",-    "He was running around like a person with his chicken cut off.",-    "I'd better get my horse on it's ass.",-    "My gourd is up a tree.",-    "He was hoisted by a skyhook on his own petard!",-    "I listen with a very critical eye.",-    "It was nothing. You planted the seed and I ran with it.",-    "I have an open mind &mdash; like a sieve.",-    "You're blowing it all out of context.",-    "It's crumbling at the seams.",-    "I was treading on silk gloves.",-    "I have post-naval drip.",-    "He out-positioned me.",-    "They just want to shoot the fat.",-    "This befalls on all of us.",-    "I'm casting the dye on the face of the water.",-    "Do it now, before the worm turns.",-    "You're skating on thin eggs.",-    "It's about as satisfactory as falling off a log.",-    "If you want to be heard, go directly to the horse's ear.",-    "We're treading on new water.",-    "He was a living legend when he was still alive.",-    "Pour midnight oil on troubled waters.",-    "Were you by yourself or alone?",-    "He didn't even bat an eyebrow.",-    "For all intensive purposes, the act is over.",-    "They kicked the tar out of our ass.",-    "She had a missed conception.",-    "We have achieved a wide specter of support.",-    "I wouldn't marry her with a twenty-foot pole.",-    "All the lemmings are going home to roost.",-    "He's the best programmer east of the Mason-Dixon line.",-    "I'm throwing those ideas to you off the top of my hat.",-    "She was sitting there with an insidious look on her face.",-    "I'm running around like a one-armed paper bandit.",-    "That'll rattle your socks.",-    "We need an escape goat.",-    "You have to bite the bullet, take the bull by the horns and make him face the music.",-    "They don't see eye for eye with us.",-    "I'm being raped over the coals.",-    "It's an off-the-cheek comment.",-    "He kicked the nail right in the head.",-    "Somebody is going to have to take a forefront here.",-    "He's going to fall flat on his feet.",-    "I accept it with both barrels.",-    "I'm tickled green.",-    "She'll fight it tooth and toenail.",-    "I'm burning my bridges out from under me!",-    "The town is a simmering powder keg.",-    "The faculty has cast a jaundiced eye upon the waters.",-    "Look up that word in your catharsis!",-    "I'm willing to throw my two cents into the fire.",-    "Let's throw some feathers on the oily water.",-    "I'm ready to go when the bell opens.",-    "There's a lot of credibility in that gap!",-    "It's a hairy can of worms.",-    "She can stew in her own rhubarb.",-    "I have to put my knuckles to the grindstone.",-    "My mind went blank and I had to wait until the dust cleared.",-    "He flipped his cork.",-    "Pictures speak louder than words.",-    "It's burned to shreds.",-    "It's better to be a big fish than a little pond.",-    "I could tell you stories that would curdle your hair.",-    "He's running from gamut to gamut.",-    "I never liked you and I always will.",-    "There are more feathers here than there are marbles in a candy store.",-    "Don't Chicken-Little me!",-    "It went through the palm of my shoe.",-    "Half a loaf is better than two in the bush.",-    "I'm waiting for her to get enough resultage.",-    "Let's get our signals crossed before the meeting.",-    "That's a project of a different horse.",-    "They descended on me like a hoar of locust.",-    "I know those woods like the back of my head.",-    "I sloughed it under the rug.",-    "That's a matter for sore eyes.",-    "I can meet your objections.",-    "Don't cut off the limb you've got your neck strung out on.",-    "They're working their bones off.",-    "Don't throw ruffled feathers on troubled water.",-    "He's being shifted from shuttle to cock.",-    "It's as dry as dish water.",-    "He needs to get blown out of his water.",-    "We worked at a meticulous pace.",-    "Don't discombonbulate the apple cart.",-    "I've got applicants up to the ears.",-    "We're biting our foot to spite our nose.",-    "I contributed to the charity of my cause.",-    "Shit or cut bait.",-    "He's tossing symbols around like a percussionist in a John Philip Sousa band.",-    "Let's grab the initiative by the horns.",-    "He's a nut-cake.",-    "They wrecked havoc in the kitchen.",-    "I'm not my keeper's brother.",-    "Old habits die young.",-    "Are there any problems we haven't beat out to death?",-    "He's as fruity as a loon.",-    "He's crazier than Jude's fruitcake.",-    "They're eating out of our laps.",-    "We pulled the cork on Pandora's Box.",-    "I'm so proud of myself I could pop a hissy.",-    "He's a young peeksqueek.",-    "You can lead a pig to pearls, but you can't make a sow's ear drink.",-    "They's chomping their lips at the prospect.",-    "I was bleeding like a pig stuck in a trough.",-    "I'm looking at it with a jaundiced ear.",-    "I'm waiting for him to drop the other foot.",-    "I'm as happy as a clam in pig broth.",-    "I won't cow-tail to anyone.",-    "I'd like to strike while the inclination is hot.",-    "A little hindsight is forethought.",-    "Their attitude is to let lying dogs sleep.",-    "They rolled their eyebrows at me.",-    "In this vein I will throw out another item for Pandoras' box.",-    "The fervor is so deep you can taste it.",-    "Each day I never cease to be amazed.",-    "We are paying for the sins of serenity.",-    "If you listen in the right tone of voice, you'll hear what I mean.",-    "I need to glue my nose to the grind stone.",-    "It's about 15 feet as the eye flies.",-    "Getting him to do anything is like pulling hen's teeth.",-    "They're colder than blue blazes.",-    "Please don't leave me out with the wolves to dry!",-    "Don't blow a hissie.",-    "I'm a mere fragment of my imagination.",-    "They went after him tooth and fang.",-    "The ball is in the other person's lap.",-    "I don't care if the rain don't shine.",-    "I don't want to violate anyone's toenails.",-    "Jesus died to save our sins.",-    "He's as crazy as a fruitcake.",-    "It was an unintentional accident.",-    "Let's raise our horizons.",-    "They laid their guts on the line.",-    "She'll whine bloody murder.",-    "Let sleeping dogs bite the hand that feeds them.",-    "I'd better jack up my bootstraps and get going.",-    "You're opening a complete can of Pandora's worms there.",-    "There's less money in the pie than there used to be.",-    "There's always a rotten monkey in every barrel.",-    "He's screw-loose and fancy free.",-    "He rammed it down their ears.",-    "Don't push the envelope over the edge of the cliff.",-    "It's the greatest thing since fired whiskey.",-    "It's a fine-feathered kettle of fish.",-    "I don't want to stick my hand in the mouth that's feeding me.",-    "He faded out of anonymity.",-    "No moss grows on his stone.",-    "Don't put all you irons on the fire in one pot.",-    "Don't look a Trojan horse in the mouth.",-    "I'm within a hairshirt of being done.",-    "I come to you on bended bootstrap.",-    "He puts his heads on one neck at a time.",-    "He's got so much zap he can barely twitch.",-    "There's more than one way to lick a cat.",-    "He's guilty of obfuscation of justice.",-    "This thing kills me to the bone.",-    "I'm losing my gourd.",-    "Don't through midnight candles on oily water.",-    "I'm just a cog in the wheel.",-    "He faked a bluff.",-    "Just use your own excretion.",-    "You're going to have fun whether you like it or not.",-    "You're scraping the top of the barrel.",-    "Anything he wants is a friend of mine.",-    "That's the straw that broke the camel's hump.",-    "Pledge now and join the list of growing members.",-    "Don't buy a greased pig in a poke.",-    "He's the last straw on the camel's back to be called.",-    "After that, we'll break our gums on the computer.",-    "He threw an extra wrench into the pot.",-    "I'm going to take my vendetta out on them.",-    "He and his group are two different people.",-    "He was hoisted by his own canard.",-    "You get more for your mileage that way.",-    "We're overpaying him, but he's worth it.",-    "Well, it's no skin off my teeth.",-    "He has his foot in the pie.",-    "There was danger lurking under the tip of an iceberg.",-    "Those guys weld a lot of power.",-    "There is some milk of contention between us.",-    "You can't clothe a sow's ear in a silk gown.",-    "If you want to get your jollies off, watch this!",-    "Don't bury your bridges before you cross them.",-    "Sometimes you've just got to grab the cow by the tail and face the music.",-    "When you're jumping on sacred cows, you've got to watch your step.",-    "Its coming down like buckets outside.",-    "If you're sick, you'd better not come in. I don't want you to start an academic.",-    "Let he who casts the first stone cast it in concrete.",-    "I'm not going to beat a dead horse to death.",-    "Who needs mental health when you can have Prozac?",-    "Too many drinks spoil the broth.",-    "It's a hairy banana.",-    "They're coming farther between.",-    "If you ask him he could wax very quickly on that subject.",-    "I'm pissed out of my bootstraps.",-    "We have to make sure we're all swimming on the same page.",-    "That's water under the dam.",-    "I need to get my high horse in gear.",-    "They're moving as fast as molasses wheels.",-    "Today was like the day Rome was built in; we can't afford to have any fiddlers.",-    "It's raining like a bandit.",-    "There's a flaw in the ointment.",-    "Don't put all your flamingos in one basket.",-    "I'm deathly curious.",-    "Take care of two stones with one bird.",-    "You take the chicken and run with me.",-    "I'd rather be tight than right.",-    "Don't strike any bells while the fire is hot.",-    "It's a mare's nest of rat nests.",-    "He's running around like a chicken with his ass cut off.",-    "He has feet of molasses.",-    "They also wait who only stand and stare.",-    "He's got a lot of fires to burn.",-    "I have to get my guts up.",-    "I don't have any monkey wrenches in my closet.",-    "A sock in time saves none.",-    "It's perfect, but it will have to do.",-    "I'll be there with spades one.",-    "Make hay while the apple is ripe.",-    "That puts the icing on the kibosh.",-    "Don't look a door knocker in the nose.",-    "People who live in glass houses should be the last ones to throw the first stone.",-    "All good things come to pass.",-    "We're cooking on all cylinders.",-    "We have a real messy ball of wax.",-    "I'm going to clean your cake!",-    "He's like sheep in a bullpen.",-    "A nickel ain't worth a dime anymore.",-    "Don't rock the boat that launched the cat.",-    "I haven't gotten the knack down yet.",-    "Don't throw out the baby with the sheep dip.",-    "This is a magnitude of the first water.",-    "There's a lot of bad blood in the water between those two.",-    "Godzilla, the Hun.",-    "I'm just a hog loose in the woodwork.",-    "The egg is cracked and there's no way to scramble it.",-    "Cast an eyeball over troubled waters.",-    "Don't make a tempest out of a teapot.",-    "I'm as happy as a pig at high tide.",-    "I don't like the feel of this ball of wax.",-    "He's restoring order to chaos.",-    "I'm soaked to the teeth.",-    "Don't worry, I've got an ace up my hole.",-    "We've been eating our hump for a long time.",-    "He doesn't know A from Z.",-    "Let me say a word before I throw in the reins.",-    "He takes to water like a duck takes to tarmac.",-    "If the sock fits, wear it.",-    "They're grasping for needles.",-    "Don't kill the gander that laid the golden egg.",-    "Thanks giving is early this year because the first Thursday fell on a Monday.",-    "He's running around like a bull with his head cut off.",-    "That opens up a whole other kettle of songs.",-    "He screwed himself into a corner.",-    "They run like flies when he comes near.",-    "It's an ill wind that doesn't blow somebody.",-    "Your socks are toast!",-    "He's getting pretty down in the tooth.",-    "I'm not sure we're all speaking from the same sheet of music.",-    "A penny saved is worth two in the bush.",-    "It's a slap in the chaps.",-    "Row, row, row your boat, gently down the drain.",-    "She's melting out punishment.",-    "They locked the door after the house was stolen.",-    "Have we gone too fast too far?",-    "That was the pan he was flashed in.",-    "Don't bite the gift horse.",-    "They are straining at nits.",-    "He doesn't have the brains God gave a goose egg.",-    "Not all the irons in the fire will bear fruit or even come home to roost.",-    "Necessity is the invention of strange bedfellows.",-    "It's an old hat and a yard wide.",-    "It's one more cog in the wheel.",-    "I'm flapping at the gills.",-    "Put it on the back burner and let it simper.",-    "Heads are rolling in the aisles.",-    "We got another thing out of it that I want to heave in.",-    "It's a home of contention.",-    "The foot that rocks the cradle is usually in the mouth.",-    "My chicken house has come home to roost.",-    "Don't let the skeletons out of the bushes.",-    "He's got bells in his batfry.",-    "Don't cast an eyeball on the face of the water.",-    "Sex is an aphrodisiac.",-    "He's on the back of the pecking order.",-    "It's enough to make you want to rot your socks.",-    "I'm all puckered down.",-    "We've got our necks strung out.",-    "I'm wound up like a cork.",-    "Everything is mutually intertangled.",-    "You've got to get the bull by the teeth.",-    "Trying to do anything is like a tour de force.",-    "We can clean ourselves right up to date.",-    "The meeting was a first-class riot squad.",-    "This program has many weaknesses, but its strongest weakness remains to be seen.",-    "He has a mind like a steel hinge.",-    "Is there any place we can pull a chink out of the log jam?",-    "Lay a bugaboo to rest.",-    "I only hope your every wish is desired.",-    "I'll reek the benefits.",-    "Misery loves strange bedfellows.",-    "Don't look a sawhorse in the mouth.",-    "Let's solve two problems with one bird.",-    "You ninney-wit!",-    "She's got her ass up a tree.",-    "I'm as healthy as a stuck pig.",-    "Deep water runs in strange ways.",-    "That's the whole kit and caboose.",-    "I'll buckle my nose down.",-    "It's a pot of crock.",-    "I heard it out of the corner of my eyes.",-    "Every rainbow has a silver lining.",-    "I have my neck hung out on an open line.",-    "It's like baiting a dead fish.",-    "Let's blow out all the stops.",-    "We've been sold up stream.",-    "His self-esteem doesn't hold water.",-    "It's a caterpillar in pig's clothing.",-    "Keep your nose to the plow.",-    "She's a virgin who has never been defoliated.",-    "That really burns my craw!",-    "If the harmonica fits, wear it.",-    "When crunch comes to shove ...",-    "I've gone over the bend.",-    "Let's pour some holy water on the troubled feathers.",-    "Women don't change their spots.",-    "You're barking your shins on the wrong tree.",-    "The sock is fried now.",-    "There are enough cooks in the pot already.",-    "If the onus fits, wear it.",-    "I like the cut of your giblets.",-    "Have it prepared under my signature.",-    "No moss grows under Charlie's rock.",-    "His head's too big for his britches.",-    "I'm walking on thin water.",-    "Run your socks up the flag pole to see if anyone salutes them.",-    "I should have stood in bed.",-    "It's no skin off my stiff upper lip.",-    "He was stark raving nude.",-    "In the last year, you've turned around 150%.",-    "Somebody pushed the panic nerve.",-    "That went through my mind and right out the other nostril.",-    "There are too many people in the soup.",-    "Before they made him they broke the mold.",-    "He's in over his head up to his ass.",-    "That was the corker in the bottle.",-    "The idea did cross my head.",-    "I want to embark upon your qualms.",-    "I'm in transit on that point.",-    "We're boggled down.",-    "I'm working my blood up into a fervor.",-    "I'm not going to stand for this lying down.",-    "He's as fruity as a loon cake.",-    "He said it thumb in cheek.",-    "Don't count your Easter eggs before they hatch.",-    "Just cool your horses.",-    "I rushed around like a chicken out of my head.",-    "I want to get to know them on a face-to-name basis.",-    "Well, darn my socks!",-    "One stitch in nine saves time.",-    "Let's put out a smeller.",-    "Too many hands spoil the soap.",-    "Your wild oats have come home to roost.",-    "That fills a lot of gray areas.",-    "I'm going to pass it on to my predecessor.",-    "I'm going to plant a seed in her ear.",-    "We need to offset the gaps in our product line.",-    "I'm having a hard time getting my handles around that one.",-    "I'm going to hide my nook in a cranny.",-    "That took the steam out of my sails.",-    "He drinks like a sieve.",-    "He doesn't know his ass from his rear end.",-    "That's a ball of another wax.",-    "I speak only with olive branches dripping from the corners of my mouth.",-    "He choked on his own craw.",-    "My stomach gets all knotted up in rocks.",-    "He's completely lost his gourd.",-    "Let's kill two dogs with one bone.",-    "I'm going to put my horn in.",-    "If the shoe fits, put it in your mouth.",-    "The left foot doesn't know what shoe it's in.",-    "Don't count your chickens before the barn door is closed.",-    "Deep water runs still.",-    "We sure pulled the wool over his socks.",-    "It's a road of hard knocks.",-    "I'm in for the count.",-    "That's just putting the gravy on the cake.",-    "You can make a prima donna sing, but you can't make her dance.",-    "My fuse is running out.",-    "He's a real jerk-wad.",-    "He's in a class by himself with maybe three or four others.",-    "It's an idea whose future is past.",-    "We threw everything in the kitchen sink at them.",-    "I'm just about to the end of my bee's wax.",-    "The skeleton is there; you just have to sharpen it and put the decorations on the tree.",-    "You sure take the prize cake.",-    "I'm going to take my venom out on you.",-    "Hold your cool!",-    "I'm a victim of extraneous circumstances.",-    "He's fruitier than a nut cake.",-    "He's worse than Godzilla the Hun.",-    "My tail feathers have dry rot.",-    "Necessity is the mother of strange bedfellows.",-    "You gotta strike while the shoe is hot or the iron may be on the other foot.",-    "We haven't found a smoking baton.",-    "That's just cutting your throat to spite your face.",-    "He was hung by his own bootstraps.",-    "The wishbone's connected to the kneebone.",-    "I think I've committed a fore paw.",-    "This is a case if the pot calling the fruitcake black.",-    "Screw the bastards, full speed ahead!",-    "It's dressing on the cake.",-    "A lot of water has gone over the bridge since then.",-    "Don't put all your ducks in one barrel.",-    "It might break the straw that holds the camel's back.",-    "He's so ego-testicle.",-    "Half a brain is better than no loaf at all.",-    "Another day, a different dollar.",-    "That's like the pot calling the cattle black.",-    "You can't judge a book by its contents.",-    "Have more discretion in the face of valor.",-    "You gotta walk with your pants on.",-    "It floated right to the bottom.",-    "No rocks grow on Charlie.",-    "The early worm catches the fish.",-    "Gee, it must have fallen into one of my cracks.",-    "He's capable of playing every button on his clarinet.",-    "He's as crazy as a bloody loon!",-    "He was screwed by his own petard.",-    "I'm basking in his shadow.",-    "I may not be the brightest light in...the...light drawer!",-    "Keep your eyes geared to the situation.",-    "It's time to pour on the midnight oil.",-    "He's become the real vocal point on this.",-    "You can blow it up and down.",-    "Let him be rent from limb to limb.",-    "Dig a hole and bury it.",-    "You have sowed a festering cow pie of suspicion.",-    "He's breathing down my throat.",-    "There's a lot of bull in the china shop.",-    "Gore no ox before its time.",-    "If you can't stand the heat, get out of the chicken.",-    "I read the sign, but it went in one ear and out the other.",-    "I won't kick a gift horse in the mouth.",-    "Don't throw the dog's blanket over the horse's nose.",-    "There's a vortex swimming around out there.",-    "Keep your nose to the mark.",-    "He pulled out all the punches.",-    "Go fry a kite!",-    "He's fuming at the seams.",-    "You're not going to get anymore until you've eaten what you've already eaten.",-    "I'd like to intersperse a comment.",-    "We're out of hear shot.",-    "Pour sand on troubled waters.",-    "Don't cash in your chips until the shill is down.",-    "It's all in knowing when to let a dead horse die.",-    "There is no surefool way of proceeding.",-    "To all intensive purposes, the cause is lost.",-    "Don't rock the status quo.",-    "Not in a pig's bladder you don't!",-    "Sounds like we're swimming an uphill battle.",-    "We've ported it to every platform under the world.",-    "You have your oar up the wrong tree.",-    "That's money we'll save right off the top of the hat.",-    "That curdles my toes.",-    "Necessity is the mother of reality.",-    "Hindsight is better than a foot in the mouth.",-    "He's a wolf in sheep's underwear.",-    "It's got all the bugs and whistles.",-    "That really burns my goat!",-    "He has an utter lack of disregard.",-    "Let's get out flamingos in a row.",-    "He's faster than a weeping alligator.",-    "I'm going to throw myself into the teeth of the gamut.",-    "If you can't read minds, don't.",-    "Don't look a gift horse in the face.",-    "We'll overlook things from top to bottom and bottom to top.",-    "That really uprooted the apple cart.",-    "A stitch in time wastes nine.",-    "We brought this can of worms into the open.",-    "It's like a greased pig in a wet blanket.",-    "When they go downstairs, you can hear neither hide nor hair of them.",-    "An avalanche is nipping at their heels.",-    "I worked my bone to a nubbin.",-    "We're just going to ad-hoc our way through it.",-    "Not in a cocked hat, you don't!",-    "That problem is getting pushed into the horizon.",-    "He's three socks to the wind.",-    "He has a very weak indigestion.",-    "He was putrified with fright.",-    "Any excuse in a storm.",-    "It sure hits the people between the head.",-    "Our deal fell through the boards.",-    "Don't get your eye out of joint.",-    "Together again for the first time.",-    "Beware a Trojan bearing a horse.",-    "Let him fry in his own juice.",-    "Strange bedfellows flock together.",-    "A stop-gap measure is better than no gap at all.",-    "He's got his tail in really deep.",-    "We're getting down to bare tacks.",-    "It's not all peaches and gravy.",-    "I'm going to down-peddle that aspect.",-    "To hell with your hand basket!",-    "No problem is so formidable that you can't just walk away from it.",-    "This field of research is so virginal that no human eye has set foot on it.",-    "I gave him a lot of rope and he took it, hook, line, and sinker.",-    "You've overgrown your welcome.",-    "I don't want to throw another monkey at the wrench right now.",-    "He's a fart off the old block.",-    "That's obviously a very different cup of fish.",-    "I'd have been bent out of shape like spades.",-    "They'll dazzle you out of your socks.",-    "There's no two ways around it.",-    "I don't want to start hurdling profanity.",-    "A squeaky wheel gathers no moss.",-    "She's madder than a wet hornet.",-    "Don't eat with your mouth full.",-    "It looks real enough to be artificial.",-    "I thought I'd have an aneurism.",-    "I have reasonably zero desire to do it.",-    "Never feed a hungry dog an empty loaf of bread.",-    "We have a wide range of broad-gauge people.",-    "There's no point in crying over skim milk.",-    "He has a wool of steel.",-    "We definitely don't want to nail ourselves into a corner.",-    "It's the greatest little seaport in town.",-    "I'm not the brightest bean in the hole.",-    "There's no place in the bowl for another spoon to stir the broth.",-    "It cuts like a hot knife through solid rock.",-    "I'll procrastinate when I get around to it.",-    "Prices are dropping like flies.",-    "He's faster than the naked eye.",-    "A lot of people my ages are dead at the present time.",-    "I'm going to have an apocalyptic fit.",-    "I'm going to scatter them like chaff before the wind.",-    "If you're going to break a chicken, you have to scramble a few eggs.",-    "They're from out neck of the family.",-    "It's not completely an unblessed advantage.",-    "People who live in glass houses shouldn't throw cow pies.",-    "It sticks like sixty.",-    "We have to fill the gaff.",-    "He has his pot in too many pies.",-    "It's always better to be safe than have your neck out on a limb.",-    "Don't count your chick peas until they hatch.",-    "He's running around with his chicken cut off.",-    "We're dislodging some inertia.",-    "She's flying off the deep end.",-    "Let me throw a monkey into the wrench.",-    "I'm just a worm in the ointment.",-    "You're preoccupying the bathroom.",-    "I'm impressed out of my gourd.",-    "We're up to our earballs in garbage.",-    "I think I've lost my gourd.",-    "He knows which side of his bread his goose is buttered on.",-    "A carpenter's son doesn't have shoes.",-    "It's a hiatus on the face of the void.",-    "We groove in the same ballpark.",-    "To the cook goes the broth!",-    "He doesn't have the brain to rub two nickels together.",-    "He gave me a blanket check.",-    "It's within the pall of reason.",-    "Hands were made before feet.",-    "He was guilty of statuary rape.",-    "Let's kick the bucket with a certain amount of daintiness.",-    "We can throw a lot of muscle into the pot.",-    "It's a travesty on the face of the void.",-    "It needs a bad case of washing.",-    "The onus is on the other foot.",-    "Don't sweep your dirty laundry under the rug.",-    "His credentials are too many to mention.",-    "Judas Proust!",-    "She hit the nail on the nose.",-    "I was distracted beyond all recognition.",-    "I'm going to scream right out of my gourd.",-    "She's too goody-bunny-shoes for me.",-    "Never screw a gift-horse in the mouth.",-    "I'd kill a dog to bite that man.",-    "It's a travesty to the human spirit.",-    "He's a real slime-burger.",-    "It's the first inauguration of their idea.",-    "My impatience is running out.",-    "That plant looks cyanotic.",-    "We haven't begun to scratch the tip of the iceberg.",-    "I don't want to rock the boat whose hand is in the cradle.",-    "It's a lot like recumbent DNA.",-    "Let's strike the fire before the iron gets hot.",-    "He's a wolf in sheep's underware.",-    "He's shot in the ass with himself.",-    "I put all my marbles in one basket.",-    "He's so mad he is spitting wooden nickels.",-    "He's a child progeny.",-    "He deserves a well-rounded hand of applause.",-    "There is one niche in his armor.",-    "We need to get over organized.",-    "He's going to go up like tinder smoke.",-    "It was oozing right out of the lurches.",-    "We have a real ball of wax to unravel.",-    "I'm a little woozy around the gills.",-    "If you want something bad enough, you have to pay the price.",-    "He has his priorities screwed on right.",-    "My steam is wearing down.",-    "I transgressed from the subject.",-    "Men, women, and children first!",-    "If you're going to break eggs, you have to make an omelette.",-    "He's got bees in his belfry.",-    "I really took the bull by the hands.",-    "I'll sue their pants on backwards.",-    "I've milked that dead end for all it's worth.",-    "Don't rattle the boat.",-    "That puts me up a worse creek.",-    "If the shoe is on the other foot, wear it.",-    "Things are all up in a heaval.",-    "I'm stone cold sane.",-    "It happened for the last two hours, including yesterday.",-    "It's the highest of the lows.",-    "He won't last as long as a crow flies.",-    "I won't hang my laurels on it.",-    "That solves two stones with one bird.",-    "He's a bulldog in a china shop.",-    "As long as somebody let the cat out of the bag, we might as well spell it correctly.",-    "It's more than magnificent &mdash; it's mediocre.",-    "Let's wreck havoc!",-    "Don't cast any dispersions.",-    "It fills a well-needed gap.",-    "There is a prolifery of new ideas.",-    "I guess that muddled the waters.",-    "It's just a matter of sweeping the rug under the carpet.",-    "He just sat there like a bump on a wart.",-    "The gremlins have gone off to roost on someone else's canard.",-    "I'm just about to spring a gasket.",-    "It was really amazing to see the spectra of people there.",-    "He's foot sore and fancy free.",-    "If Calvin Coolidge were alive today, he'd turn over in his grave.",-    "I want to see him get a good hands-on feel.",-    "There will be fangs flying.",-    "How old is your 2-year old?",-    "It's as predictable as cherry pie.",-    "He's as batty as a fruitcake.",-    "Those are not the smartest cookies under the Christmas tree.",-    "It puts feathers under my wings.",-    "We opened a big ball of worms.",-    "The early bird will find his can of worms.",-    "That's pushing a dead horse.",-    "Nobody is going to give you the world in a saucer.",-    "The whole thing is a hairy potpourri.",-    "They're dying off like fleas.",-    "I'm woefully glad you're here.",-    "A hand in the bush is worth two anywhere else.",-    "I need to pick up my head and dust it off.",-    "I'm as happy as a pig in clam broth.",-    "It's hot off the vine.",-    "He knows which side his pocketbook is buttered on.",-    "Things keep falling out of it, three or four years at a time.",-    "No crumbs gather under his feet.",-    "I only hear half of what I believe.",-    "That will sooth your savage brow.",-    "The sink is shipping.",-    "I'm beat up around the gills.",-    "It's time to take off our gloves and talk from the heart.",-    "You're too big for your ass.",-    "They're atrophying on the vine.",-    "I feel like hell and high water.",-    "I said it beneath my breath.",-    "That's a different jar of worms.",-    "You can't make a silk cow out of a sow.",-    "They are unscrupulously honest.",-    "I was held up about an hour casting feathers on oily water.",-    "He went out in a poof of glory.",-    "I'm as happy as a fried clam.",-    "I'm creaming off the top of my head.",-    "He'll get his neck in hot water.",-    "She'll show up if she cares which side her ass is buttered on.",-    "He tried to sweep the skeleton under the rug.",-    "Does it joggle any bells?",-    "Just cut a thin slither of it.",-    "We're off in a cloud of hooves.",-    "If you can't stand the heat, get off the car hood.",-    "That's the whole ball of snakes.",-    "Don't leave the nest that feeds you.",-    "Things have slowed down to a terrible halt.",-    "I'm standing over your shoulder.",-    "He has his neck out on a limb.",-    "I'll bet there's one guy out in the woodwork.",-    "I wouldn't touch that with a glass parrot.",-    "Put every marble in its socket.",-    "He's sweating like a stuck pig.",-    "You can't make a sow's ear out of a silk purse.",-    "I'll feather my own mare's nest, thank you!",-    "Gander your eye at that!",-    "The onus of responsibility lies on his shoulders.",-    "The die has been cast on the face of the waters.",-    "It makes my chops drool.",-    "I'd like to feel you up about taking on the job.",-    "Put it on the back of the stove and let it simper.",-    "If you can't imitate him, don't copy him.",-    "I flew it by ear.",-    "He's biting the shaft and getting the short end of the problem.",-    "Someone took the steam out of my sails.",-    "I never put on a pair of shoes until I've worn then five years.",-    "I smell a needle in the haystack.",-    "He's got four sheets in the wind.",-    "Don't talk with your mouth open.",-    "It's a tough nut to hoe.",-    "I had to throw in the white flag.",-    "Your irons in the fire are coming home to roost.",-    "We're dragging out dead skeletons.",-    "You just sawed yourself right off my tree.",-    "Don't count your marbles before they hatch.",-    "It was deja vu all over again.",-    "There's more than one way to skin an egg without letting the goose out of the bag.",-    "This is an exercise in fertility.",-    "I don't give a Ricardo's Montalban what you think.",-    "That's the wart that sank the camel's back.",-    "Don't rattle the cage that rocks the cradle.",-    "We can't get through the forest for the trees.",-    "They are pushing us into a panic that does not exist.",-    "The analogy is a deeply superficial one.",-    "He's sinking to new heights.",-    "Right off the top of my hand, I'd say no.",-    "Put your mouth where your money is.",-    "I'm quaking in my oats.",-    "Not over my dead body, you don't!",-    "He's as quick as an eyelash.",-    "It drove me to no wits end.",-    "If not us, when?",-    "It costs a Jewish princess's ransom.",-    "There're not enough daisies on the chain.",-    "It's a typical case of alligator mouth and hummingbird ass.",-    "A squeaking hinge gathers no moss.",-    "You're barking your shins up the wrong tree.",-    "I'll lend you a  jaundiced ear.",-    "May I inveigle on you?",-    "I looked at it with some askance.",-    "His little red wagon came home to roost.",-    "We sure pulled the wool over their socks.",-    "Picasso wasn't born in a day.",-    "Two thoughts but with a single mind.",-    "I have other pigs to fry.",-    "He's splitting up at the seams.",-    "That would have been right up Harry's meat.",-    "It's a useful ace in the pocket.",-    "The screws of progress grind fine.",-    "By the time we unlock the bandages, he will have gone down the drain.",-    "Let me feast your ears.",-    "My mind is a vacuum of information.",-    "He doesn't know which side his head is buttered on.",-    "I want half a cake and eat it too.",-    "We have the whole gambit to select from.",-    "We got on board at ground zero.",-    "Someone is going to be left in the church with his pants on.",-    "Make haste while the snow falls.",-    "I could count it on the fingers of one thumb.",-    "Let's not drag any more dead herrings across the garden path.",-    "They were hunkering for a shut out.",-    "That's a tough nut to carry on your back.",-    "When you get to the end of your rope, tie a knot and jump off.",-    "He's as happy as a pig at high tide.",-    "I gave him a real mouthful.",-    "He had the eyes of a bat.",-    "This is a really tough wretchimen.",-    "Straighten up or fly right.",-    "Do it now; don't dingle-dally over it.",-    "I've got other socks to fry.",-    "He is as dishonest as the day is long.",-    "A dog under any other coat is still a dog.",-    "Dishwater is duller than he is.",-    "A verbal contract isn't worth the paper it's printed on.",-    "Any kneecap of yours is a friend of mine.",-    "We're revisiting deja vu.",-    "It' not an easy thing to get your teeth around.",-    "I'm going to take a hiatus.",-    "I'm willing to listen to the other side of the coin.",-    "Put that in your teapot and smoke it!",-    "You can't break an egg without making an omelette.",-    "It causes my goose to bump.",-    "He's downstream from upstage.",-    "They sucked all the cream off the crop.",-    "I'm collapsing around the seams.",-    "It's time for me to get my high-horse on.",-    "Is he gay or an omnivore?",-    "Nothing is good enough for our customers.",-    "This work was the understatement of the year.",-    "I'm as happy as a clam in pig's broth.",-    "There are a lot of areas for efficiency reduction.",-    "I'll take any warm body in a storm.",-    "It's like asking a man to stop eating in the middle of a starvation diet.",-    "He'll grease any palm that will pat his ass.",-    "He has a good mind, if only we could light a fire under it.",-    "This bit of casting oil on troubled feathers is more than I can take.",-    "He opened up that can of worms, let him swim in them.",-    "It's a mecca of people.",-    "I think he's gone over the bend.",-    "He's within eyeshot of shore.",-    "It's a white herring.",-    "She's got a bee in her bonnet and just won't let it go.",-    "The Albatross of Damocles is hanging over your neck.",-    "Boulder dash!",-    "It's a terrible crutch to bear.",-    "He has a dire need, actually it's half-dire, but he thinks it's double-dire.",-    "The circuit breaker just kicked in.",-    "I'll take a few pegs out of his sails.",-    "Somebody should have waved a flag louder than they did.",-    "It's not my Diet of Worms.",-    "He has a brain for a rhubarb.",-    "It's the old Paul Revere bit . . . one if by two and two if by one.",-    "He reads memos with a fine tooth comb.",-    "That's their apple cart, let them choke on it.",-    "Take it with a block of salt.",-    "Where there's smoke, there're mirrors.",-    "This game is a punctuation point.",-    "We're trying very hard to maintain the high road.",-    "It's as dry as mud.",-    "I march to a different kettle of fish.",-    "This manure must be stopped dead in its tracks.",-    "He's a lion in a den of Daniels.",-    "The ideas sprang full-blown from the hydra's heads.",-    "We'll see what comes down the tubes.",-    "Put all your money where your marbles are.",-    "Each of us sleazes by at our own pace.",-    "I may not always be right, but I'm never wrong.",-    "I enjoy his smiling continence.",-    "We don't want to stick our necks out and get our asses chopped off.",-    "Just because it's there, you don't have to mount it.",-    "Sometimes things just gag me the wrong way.",-    "Don't jump off the handle.",-    "That'll blow the socks off the cat.",-    "My laurels have come home to roost.",-    "Don't feed the hand that bites you.",-    "He's trying to domestify you.",-    "We don't want to go at it like a wild bull in Chinatown.",-    "I'm sweating like a greased pig.",-    "I have the self-discipline of a mouse.",-    "It's not the only bowl of fish in the ocean.",-    "Step up to the plate and fish or cut bait.",-    "He's a clod of the first water.",-    "That sure muddles the water.",-    "I'd avoid him like sixty.",-    "I'll be ready just in case a windfall comes down the pike.",-    "That was like getting the horse before the barn.",-    "Let's lurch into the next hour of the show.",-    "A lot of wine has gone under the bridge since we last met.",-    "They unspaded some real down to earth data.",-    "I'll keep my eyes out in case I hear anything.",-    "There were foot-high puddles.",-    "He got his socks off on it.",-    "We need to do it ex-post-hasto.",-    "Stick that in your hat and smoke it!",-    "He's doing a great job in spades.",-    "May the wind at your back never be your own.",-    "I wish somebody could drop the other foot.",-    "Some bigger fish knocked on the door, wanting to be fried.",-    "He doesn't have an ox to grind.",-    "When I want your opinion, I'll give it to you.",-    "My dog was pent up all day.",-    "I'm sticking my neck out on a ledge.",-    "There's more intelligence in this town than you can shake a stick at.",-    "Let me see if I have my eggs on straight.",-    "I'm scared out of my witless.",-    "I've been burning the midnight hours.",-    "Wait until the cows come home to roost!",-    "He's letting ground grow under his feet.",-    "It's right on the tip of my head.",-    "Let's set up a straw vote and knock it down.",-    "I just got indicted into the Hall of Fame.",-    "Let me throw a monkey wrench in the ointment.",-    "He's casting a red herring on the face of the water.",-    "By a streak of coincidence, it really happened.",-    "Stick that in your peace pipe and smoke it.",-    "Those people have no bones to grind.",-    "He's sharp as a whip.",-    "Just say whatever pops into your mouth.",-    "Sounds like it's time to sever the apron string.",-    "She's just another chick in the china shop.",-    "It's not going to rock any apple carts.",-    "It's the old chicken-in-the-egg problem.",-    "That curdles the milk of human kindness.",-    "A whole hog is better than no hole at all.",-    "I keep stubbing my shins." ]---- from jose nazario-nixonList :: [String]-nixonList =-    [-    "A man is not finished when he is defeated. He is finished when he quits.",-    "A man who has never lost himself in a cause bigger than himself has missed one of life's mountaintop experiences. Only in losing himself does he find himself. Only then does he discover all the latent strengths he never knew he had and which otherwise would have remained dormant.",-    "A public man must never forget that he loses his usefulness when he as an individual, rather than his policy, becomes the issue.",-    "Always remember that others may hate you but those who hate you don't win unless you hate them. And then you destroy yourself.",-    "Americans admire a people who can scratch a desert and produce a garden. The Israelis have shown qualities that Americans identify with: guts, patriotism, idealism, a passion for freedom. I have seen it. I know. I believe that.",-    "Any change is resisted because bureaucrats have a vested interest in the chaos in which they exist.",-    "Any lady who is first lady likes being first lady. I don't care what they say, they like it. ",-    "Castro couldn't even go to the bathroom unless the Soviet Union put the nickel in the toilet. ",-    "Certainly in the next 50 years we shall see a woman president, perhaps sooner than you think. A woman can and should be able to do any political job that a man can do.",-    "Don't get the impression that you arouse my anger. You see, one can only be angry with those he respects. ",-    "Finishing second in the Olympics gets you silver. Finishing second in politics gets you oblivion.",-    "I am not a crook.",-    "I believe in the battle-whether it's the battle of a campaign or the battle of this office, which is a continuing battle. ",-    "I brought myself down. I impeached myself by resigning.",-    "I can see clearly now... that I was wrong in not acting more decisively and more forthrightly in dealing with Watergate.",-    "I can take it. The tougher it gets, the cooler I get.",-    "I don't know anything that builds the will to win better than competitive sports. ",-    "I reject the cynical view that politics is a dirty business.",-    "I played by the rules of politics as I found them.",-    "I'm glad I'm not Brezhnev. Being the Russian leader in the Kremlin. You never know if someone's tape recording what you say. ",-    "If you think the United States has stood still, who built the largest shopping center in the world?",-    "It is necessary for me to establish a winner image. Therefore, I have to beat somebody.",-    "Once you get into this great stream of history, you can't get out. ",-    "People react to fear, not love; they don't teach that in Sunday School, but it's true.",-    "Politics would be a helluva good business if it weren't for the goddamned people. ",-    "Scrubbing floors and emptying bedpans has as much dignity as the Presidency.",-    "Solutions are not the answer.",-    "Sure there are dishonest men in local government. But there are dishonest men in national government too.",-    "The presidency has many problems, but boredom is the least of them.",-    "The press is the enemy.",-    "Voters quickly forget what a man says.",-    "Voters quickly forget what a man says.",-    "When the President does it, that means that it is not illegal.",-    "You won't have Nixon to kick around anymore, because, gentlemen, this is my last press conference.",-    "Don't try to take on a new personality; it doesn't work.",-    "The Chinese use two brush strokes to write the word 'crisis.' One brush stroke stands for danger; the other for opportunity. In a crisis, be aware of the danger - but recognize the opportunity.",-    "I've never canceled a subscription to a newspaper because of bad cartoons or editorials. If that were the case, I wouldn't have any newspapers or magazines to read.",-    "The second point is that coming out--coming back and saying that black Americans aren't as good as black Africans--most of them , basically, are just out of the trees.  Now, let's face it, they are.",-    "Government enterprise is the most inefficient and costly way of producing jobs.",-    "In a flat choice between smoke and jobs, we're for jobs...But just keep me out of trouble on environmental issues.",-    "This is a great day for France!",-    "I don't want to see this country to go that way.  You know what happened to the Greeks.  Homosexuality destroyed them. Sure, Aristotle was a homo, we all know that, so was Socrates.",-    "They're not like us. They smell different, they look different, they act different.  The trouble is, you can't find one that's honest.",-    "You know, it's a funny thing, every one of the bastards that are out for legalizing marijuana is Jewish. What the Christ is the matter with the Jews, Bob? What is the matter with them? I suppose it is because most of them are psychiatrists.",-    "Do you know what happened to the Romans?  The last six Roman emperors were fags. . . .  You know what happened to the popes?  It's all right that popes were laying the nuns.",-    "You have to face the fact that whole problem is really the blacks. The key is to divise a system that reconizes this while not appearing to...",-    "Your boys will be home for Christmas." ]--harrop :: [String]-harrop = -    [ "Our conclusion is, of course, that we are not going to consider diversifying into the Haskell market, at least not until it matures. Right now, Scala is looking much more viable."-    , "These remarkable new figures show that Haskell is still a virgin language: despite a huge number of open source projects being started in Haskell, virtually none reach maturity and the vast majority of those never garner a significant user base (i.e. they remain untested)."-    , "almost all of the examples of Haskell's use in industry are fakes"-    , "On Mr. Harrop: \"Where exactly did we pick up this, er, individual?  Would they please take it back as defective?\""-    ]
− Plugin/Scheck.hs 
@@ -1,88 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, PatternGuards #-}--- Copyright (c) 6 DonStewart - http://www.cse.unsw.edu.au/~dons--- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)---- | Test a property with SmallCheck-module Plugin.Scheck where--import File (findFile)-import Plugin-import Lambdabot.Parser-import qualified Text.Regex as R--$(plugin "Small")--instance Module SmallModule () where-    moduleCmds   _     = ["scheck"]-    moduleHelp _ _     = "scheck <expr>\nYou have SmallCheck and 3 seconds. Test something."-    process _ _ to _ s = ios80 to (check s)--binary :: String-binary = "mueval"---check :: String -> IO String-check src = do-    case parseExpr src of-        Left e  -> return e-        Right _ -> do-            file <- findFile "L.hs"-            (out,err,_) <- popen binary ["--loadfile=", file, "-XExtendedDefaultRules", "-e", "mysmallcheck " ++ src ++ ""] Nothing-            let o = munge out-                e = munge err-            return $ case () of {_-                                 | null o && null e -> "Terminated\n"-                                 | null o           -> " " ++ e-                                 | otherwise        -> " " ++ o-            }-            where munge = id-                  f []   = []-                  f [x]  = [x]-                  f (x:y)= [x ++ " " ++ (concat . intersperse ", ") y]--clean_ :: String -> String-clean_ s-    |  no_io      `matches'`    s = "No IO allowed\n"-    |  terminated `matches'`    s = "Terminated\n"-    |  hput       `matches'`    s = "Terminated\n"-    |  stack_o_f  `matches'`    s = "Stack overflow\n"-    |  loop       `matches'`    s = "Loop\n"-    |  undef      `matches'`    s = "Undefined\n"-    |  type_sig   `matches'`    s = "Add a type signature\n"--    | Just (_,m,_,_) <- ambiguous  `R.matchRegexAll` s = m-    | Just (_,_,b,_) <- inaninst   `R.matchRegexAll` s = clean_ b-    | Just (_,_,b,_) <- irc        `R.matchRegexAll` s = clean_ b-    | Just (_,m,_,_) <- nomatch    `R.matchRegexAll` s = m-    | Just (_,m,_,_) <- notinscope `R.matchRegexAll` s = m-    | Just (_,m,_,_) <- hsplugins  `R.matchRegexAll`  s = m-    | Just (a,_,_,_) <- columnnum  `R.matchRegexAll`  s = a-    | Just (a,_,_,_) <- extraargs  `R.matchRegexAll`  s = a-    | Just (_,_,b,_) <- filename'  `R.matchRegexAll`  s = clean_ b-    | Just (a,_,b,_) <- filename   `R.matchRegexAll`  s = a ++ clean_ b-    | Just (a,_,b,_) <- filepath   `R.matchRegexAll`   s = a ++ clean_ b-    | Just (a,_,b,_) <- runplugs   `R.matchRegexAll`  s = a ++ clean_ b--    | otherwise      = s--    where-        -- s/<[^>]*>:[^:]: //-        type_sig   = regex' "add a type signature that fixes these type"-        no_io      = regex' "No instance for \\(Show \\(IO"-        terminated = regex' "waitForProc"-        stack_o_f  = regex' "Stack space overflow"-        loop       = regex' "runplugs: <<loop>>"-        irc        = regex' "\n*<irc>:[^:]*:[^:]*:\n*"-        filename   = regex' "\n*<[^>]*>:[^:]*:\\?[^:]*:\\?\n* *"-        filename'  = regex' "/tmp/.*\\.hs[^\n]*\n"-        filepath   = regex' "\n*/[^\\.]*.hs:[^:]*:\n* *"-        undef      = regex' "Prelude.undefined"-        ambiguous  = regex' "Ambiguous type variable `a\' in the constraints"-        runplugs   = regex' "runplugs: "-        notinscope = regex' "Variable not in scope:[^\n]*"-        hsplugins  = regex' "Compiled, but didn't create object"-        extraargs  = regex' "[ \t\n]*In the [^ ]* argument"-        columnnum  = regex' " at <[^\\.]*\\.[^\\.]*>:[^ ]*"-        nomatch    = regex' "Couldn't match[^\n]*\n"-        inaninst   = regex' "^[ \t]*In a.*$"-        hput       = regex' "<stdout>: hPutStr"
− Plugin/Search.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, ViewPatterns #-}--- | Search various things, Wikipedia and google for now.------ (c) 2005 Samuel Bronson--- (c) 2006 Don Stewart---- Joel Koerwer 11-01-2005 generalized query for different methods---   and added extractConversion to make things like @google 1+2 work-module Plugin.Search (theModule) where--import Plugin-import Network.HTTP-import Text.HTML.TagSoup-import Text.HTML.TagSoup.Match (anyAttr, tagOpen)-import Data.Maybe (listToMaybe)--$(plugin "Search")--engines :: [(String, (URI, String -> String, [Header]))]-engines =-   [("google", (googleUri, (\s -> "?hl=en&q="++s++"&btnI=I'm+Feeling+Lucky"), googleHeaders)),-    -- ("wikipedia", (wikipediaUri, ("?search="++), [])), -- this has changed and Wikipedia requires a User-Agent string-    ("gsite", (googleUri, (\s -> "?hl=en&q=site%3A"++s++"&btnI=I'm+Feeling+Lucky"), googleHeaders)),-    ("gwiki", (googleUri, (\s -> "?hl=en&q=site%3Ahaskell.org/haskellwiki+" ++s++"&btnI=I'm+Feeling+Lucky"), googleHeaders))-   ]--googleHeaders :: [Header]-googleHeaders = [mkHeader HdrReferer "http://www.google.com/"]--normalizeOptions :: NormalizeRequestOptions a-normalizeOptions = defaultNormalizeRequestOptions {-    normDoClose = True,-    normForProxy = isJust (proxy config),-    normUserAgent = Nothing } -- there is a default user agent, perhaps we want it?--makeUri :: String -> String -> URI-makeUri regName path = nullURI {-    uriScheme = "http:",-    uriAuthority = Just (URIAuth { uriUserInfo = "", uriRegName = regName, uriPort = "" }),-    uriPath = path }--googleUri :: URI-googleUri = makeUri "www.google.com" "/search"--- wikipediaUri = makeUri "en.wikipedia.org" "/wiki/Special:Search"--instance Module SearchModule () where-    moduleHelp _ s      = case s of-         "google"    -> "google <expr>. Search google and show url of first hit"-         -- "wikipedia" -> "wikipedia <expr>. Search wikipedia and show url of first hit"-         "gsite"     -> "gsite <site> <expr>. Search <site> for <expr> using google"-         "gwiki"     -> "gwiki <expr>. Search (new) haskell.org wiki for <expr> using google."-    moduleCmds _ = map fst engines-    process_ _ s e = lift $ searchCmd s (dropSpace e)----------------------------------------------------------------------------searchCmd :: String -> String -> LB [String]-searchCmd _          []   = return ["Empty search."]-searchCmd engineName (Network.HTTP.urlEncode -> query)-    | engineName == "google" = -- for Google we do both to get conversions, e.g. for '3 lbs in kg'-        doHTTP request $ \response -> -        case response of-            Response { rspCode = (3,0,2), rspHeaders = (lookupHeader HdrLocation -> Just url) } ->-                doGoogle >>=  handleUrl url-            _ -> fmap (\extra -> if null extra then ["No Result Found."] else extra) doGoogle-    | otherwise = -        doHTTP request $ \response -> -        case response of-            Response { rspCode = (3,0,2), rspHeaders = (lookupHeader HdrLocation -> Just url) } ->-                handleUrl url []-            _ -> return ["No Result Found."]-  where handleUrl url extra = do-            title <- io $ runWebReq (urlPageTitle url) (proxy config)-            return $ extra ++ maybe [url] (\t -> [url, t]) title-        Just (uri, makeQuery, headers) = lookup engineName engines-        request = normalizeRequest normalizeOptions $ Request {-            rqURI = uri { uriQuery = makeQuery query },-            rqMethod = HEAD,-            rqHeaders = headers,-            rqBody = "" }-        doGoogle = -            doHTTP (request { rqMethod = GET, rqURI = uri { uriQuery = "?hl=en&q=" ++ query } }) $ \response ->-                case response of-                    Response { rspCode = (2,_,_), rspBody = (extractConversion -> Just result) } ->-                        return [result]-                    _ -> return []--doHTTP :: HStream a => Request a -> (Response a -> LB [String]) -> LB [String]-doHTTP request handler = do-    result <- io $ simpleHTTP request-    case result of-        Left connError -> return ["Connection error: "++show connError]-        Right response -> handler response---- This is clearly fragile.-extractConversion :: String -> Maybe String-extractConversion (parseTags -> tags) = listToMaybe [txt |-    section <- sections (tagOpen ("h2"==) (anyAttr (\(name, value) -> name == "class" && value == "r"))) tags,-    txt <- [dropSpace $ drop 1 $ dropWhile (/= '=') t | TagText t <- section],-    not (null txt)]
− Plugin/Seen.hs 
@@ -1,464 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeSynonymInstances #-}--- Copyright (c) 2004 Thomas Jaeger--- Copyright (c) 2005-6 Don Stewart - http://www.cse.unsw.edu.au/~dons--- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)---- | Keep track of IRC users.-module Plugin.Seen (theModule) where--import Data.Binary--import File (findFile)-import Plugin-import Lambdabot.AltTime-import Lambdabot.Error         (tryError)-import Lambdabot.Util          (lowerCaseString)--import qualified Message as G (Message, names, channels, nick, packNick, unpackNick, Nick(..), body, lambdabotName, showNick, readNick)--import qualified Data.Map as M-import qualified Data.ByteString.Char8 as P-import qualified Data.ByteString.Lazy as L--import System.Directory--import System.Time (normalizeTimeDiff) -- or export from AltTime.hs?--import Control.Monad       (unless, zipWithM_)-import Control.Arrow       (first)-import Text.Printf--$(plugin "Seen")---- Try using packed strings?---- | The type of channels-type Channel = P.ByteString---- | The type of nicknames-type Nick = P.ByteString---- | We last heard the user speak at ClockTime; since then we have missed---   TimeDiff of him because we were absent.-type LastSpoke = Maybe (ClockTime, TimeDiff)---- | 'UserStatus' keeps track of the status of a given Nick name.-data UserStatus-        = Present    !LastSpoke [Channel]-          -- ^ Records when the nick last spoke and that the nick is currently-          --   in [Channel].-        | NotPresent !ClockTime !StopWatch [Channel]-          -- ^ The nick is not present and was last seen at ClockTime in Channel.-          --   The second argument records how much we've missed.-        | WasPresent !ClockTime !StopWatch !LastSpoke [Channel]-          -- ^ The bot parted a channel where the user was. The Clocktime-          --   records the time and Channel the channel this happened in.-          --   We also save the reliablility of our information and the-          --   time we last heard the user speak.-        | NewNick !Nick-          -- ^ The user changed nick to something new.-    deriving (Show, Read)--data StopWatch = Stopped !TimeDiff-               | Running !ClockTime-        deriving (Show,Read)--type SeenState = (MaxMap, SeenMap)-type SeenMap   = M.Map Nick UserStatus-type MaxMap    = M.Map String Int-type Seen m a  = ModuleT SeenState m a------------------------------------------------------------------------------ ok, since this module generates quite a lot of state, what we'll do--- is use Binary to pack this value, since Read is sooo slow and exe (as--- my gf says :)--{--instance Binary (M.Map Nick UserStatus) where-    put_ bh m = put_ bh (M.toList m)-    get bh    = do x <- get bh ; return (M.fromList x)--}--instance Binary StopWatch where-    put (Stopped td) = putWord8 0 >> put td-    put (Running ct) = putWord8 1 >> put ct--    get = do-        h <- getWord8-        case h of-            0 -> liftM Stopped get-            1 -> liftM Running get-            _ -> error "Seen.StopWatch.get"--instance Binary UserStatus where-    put (Present spoke chans) = do-        putWord8 0-        put spoke-        put chans-    put (NotPresent ct sw chans) = do-        putWord8 1-        put ct-        put sw-        put chans-    put (WasPresent ct sw spoke chans) = do-        putWord8 2-        put ct-        put sw-        put spoke-        put chans-    put (NewNick n) = putWord8 3 >> put n--    get = do-        h <- getWord8-        case h of-            0 -> do-                x <- get-                y <- get-                return (Present x y)-            1 -> do-                x <- get-                y <- get-                z <- get-                return (NotPresent x y z)-            2 -> do-                x <- get-                y <- get-                z <- get-                a <- get-                return (WasPresent x y z a)-            3 -> do-                x <- get-                return (NewNick x)--            _ -> error "Seen.UserStatus.get"-------------------------------------------------------------------------------- something's broken. doesn't seem to correctly keep the seen data over--- reboots anymore :/-----instance Module SeenModule SeenState where-    moduleHelp _ "seen"  = "seen <user>. Report if a user has been seen by the bot"-    moduleHelp _ "users" = "users [chan]. Report the maximum number of users seen in a channel, and active users in the last 30 minutes"-    moduleCmds _         = ["users","seen"]-    moduleDefState _     = return (M.empty,M.empty)--    -- first step towards tracking the maximum number of users-    process _ msg chan "users" rest = do-         (m, seenFM) <- readMS-         s <- io getClockTime-         let who = G.packNick $ lcNick $ if null rest then chan else G.readNick msg rest-             now = length [ () | (_,Present _ chans) <- M.toList seenFM-                               , who `elem` chans ]--             n = case M.lookup (P.unpack who) m of Nothing -> 1; Just n' -> n'--             active = length [() | (_,st@(Present _ chans)) <- M.toList seenFM-                                 , who `elem` chans && isActive st ]--             isActive (Present (Just (ct,_td)) _cs) = recent ct-             isActive _                             = False--             recent t = normalizeTimeDiff (diffClockTimes s t) < gap_minutes-             gap_minutes = TimeDiff 0 0 0 0 30 0 0 -- 30 minutes--         return $!-           [concat-              [ "Maximum users seen in ", G.showNick msg $ G.unpackNick who, ": "-              , show n-              , ", currently: ", show now-              , printf " (%0.1f%%)" (100 * (fromIntegral now    / fromIntegral n) :: Double)-              , ", active: ", show active-              , printf " (%0.1f%%)" (100 * (fromIntegral active / fromIntegral now) :: Double)-              ]-            ]--    process _ msg target _      rest = do-         (_,seenFM) <- readMS-         now        <- io getClockTime-         let (txt,safe) = first unlines (getAnswer msg rest seenFM now)-         if safe || not ("#" `isPrefixOf` G.nName target)-             then return [txt]-             else do lift $ ircPrivmsg (G.nick msg) txt-                     return []--    moduleInit _        = do-      wSFM <- bindModule2 withSeenFM-      zipWithM_ ircSignalConnect-        ["JOIN", "PART", "QUIT", "NICK", "353",      "PRIVMSG"] $ map wSFM-        [joinCB, partCB, quitCB, nickCB, joinChanCB, msgCB]--      -- This magically causes the 353 callback to be invoked :)-      -- this is broken...-      lift $ tryError $ send . G.names "freenode" . map G.nName =<< ircGetChannels--      -- and suck in our state. We read directly from the handle, to avoid copying--      c <- io $ findFile "seen"-      s <- io $ P.readFile c-      let ls = L.fromChunks [s]-      return (decode ls) >>= writeMS--    moduleExit _ = do-      chans <- lift $ ircGetChannels-      unless (null chans) $ do-            ct    <- io getClockTime-            modifyMS $ \(n,m) -> (n, botPart ct (map G.packNick chans) m)--        -- and write out our state:-      withMS $ \s _ -> io ( findFile "seen" >>= \ c -> encodeFile c s)--lcNick :: G.Nick -> G.Nick-lcNick (G.Nick svr nck) = G.Nick svr (lowerCaseString nck)---------------------------------------------------------------------------getAnswer :: G.Message a => a -> String -> SeenMap -> ClockTime -> ([String], Bool)-getAnswer msg rest seenFM now-  | null nick' =-       let people  = map fst $ filter isActive $ M.toList seenFM-           isActive (_nick,state) = case state of-               (Present (Just (ct,_td)) _cs) -> recent ct-               _ -> False-           recent t = normalizeTimeDiff (diffClockTimes now t) < gap_minutes-           gap_minutes = TimeDiff 0 0 0 0 15 0 0-       in (["Lately, I have seen " ++ (if null people then "nobody"-                else listToStr "and" (map upAndShow people)) ++ "."], False)--  | pnick == G.lambdabotName msg =-        case M.lookup (G.packNick pnick) seenFM of-            Just (Present _ cs) ->-                (["Yes, I'm here. I'm in " ++ listToStr "and" (map upAndShow cs)], True)-            _ -> error "I'm here, but not here. And very confused!"--  | head (G.nName pnick) == '#' =-       let people  = map fst $ filter inChan $ M.toList seenFM-           inChan (_nick,state) = case state of-               (Present (Just _) cs)-                  -> G.packNick pnick `elem` cs-               _ -> False-       in (["In "++nick'++" I can see "-            ++ (if null people then "nobody"    -- todo, how far back does this go?-               else listToStr "and" (map upAndShow people)) ++ "."], False)--  | otherwise        = ((case M.lookup (G.packNick pnick) seenFM of-      Just (Present mct cs)            -> nickPresent mct (map upAndShow cs)-      Just (NotPresent ct td chans)    -> nickNotPresent ct td (map upAndShow chans)-      Just (WasPresent ct sw _ chans)  -> nickWasPresent ct sw (map upAndShow chans)-      Just (NewNick newnick)           -> nickIsNew newnick-      _ -> ircMessage ["I haven't seen ", nick, "."]), True)-  where-    -- I guess the only way out of this spagetty hell are printf-style responses.-    upAndShow = G.showNick msg . G.unpackNick-    nickPresent mct cs = ircMessage [-      if you then "You are" else nick ++ " is", " in ",-      listToStr "and" cs, ".",-      case mct of-        Nothing          -> concat [" I don't know when ", nick, " last spoke."]-        Just (ct,missed) -> prettyMissed (Stopped missed)-               (concat [" I last heard ", nick, " speak ",-                        lastSpoke {-, ", but "-}])-               (" Last spoke " ++ lastSpoke)-          where lastSpoke = clockDifference ct-     ]-    nickNotPresent ct missed chans = ircMessage [-       "I saw ", nick, " leaving ", listToStr "and" chans, " ",-       clockDifference ct, prettyMissed missed ", and " ""-     ]-    nickWasPresent ct sw chans = ircMessage [-       "Last time I saw ", nick, " was when I left ",-       listToStr "and" chans , " ", clockDifference ct,-       prettyMissed sw ", and " ""]-    nickIsNew newnick = ircMessage [if you then "You have" else nick++" has",-        " changed nick to ", us, "."] ++ fst (getAnswer msg us seenFM now)-      where--        findFunc pstr = case M.lookup pstr seenFM of-            Just (NewNick pstr') -> findFunc pstr'-            Just _               -> pstr-            Nothing              -> error "SeenModule.nickIsNew: Nothing"--        us = upAndShow $ findFunc newnick--    ircMessage = return . concat-    nick' = firstWord rest-    you   = pnick == lcNick (G.nick msg)-    nick  = if you then "you" else nick'-    pnick = lcNick $ G.readNick msg nick'-    clockDifference past-      | all (==' ') diff = "just now"-      | otherwise        = diff ++ " ago"-      where diff = timeDiffPretty . diffClockTimes now $ past--    prettyMissed (Stopped _) ifMissed _     = ifMissed ++ "."-    prettyMissed _           _ ifNotMissed  = ifNotMissed ++ "."--{--    prettyMissed (Stopped missed) ifMissed _-      | missedPretty <- timeDiffPretty missed,-        any (/=' ') missedPretty-      = concat [ifMissed, "I have missed ", missedPretty, " since then."]--    prettyMissed _ _ ifNotMissed = ifNotMissed ++ "."--}---- | extract channels from message as packed, lower cased, strings.-msgChans :: G.Message a => a -> [Channel]-msgChans msg = map (G.packNick . lcNick) $ G.channels msg---- | Callback for when somebody joins. If it is not the bot that joins, record---   that we have a new user in our state tree and that we have never seen the---   user speaking.-joinCB :: G.Message a => a -> SeenMap -> ClockTime -> Nick -> Either String SeenMap-joinCB msg fm _ct nick-  | nick == (G.packNick $ G.lambdabotName msg) = Right fm-  | otherwise = Right $! insertUpd (updateJ Nothing chans) nick newInfo fm-  where newInfo = Present Nothing chans-        chans = msgChans msg--botPart :: ClockTime -> [Channel] -> SeenMap -> SeenMap-botPart ct cs fm = fmap botPart' fm where-    botPart' (Present mct xs) = case xs \\ cs of-        [] -> WasPresent ct (startWatch ct zeroWatch) mct cs-        ys -> Present mct ys-    botPart' (NotPresent ct' missed c)-        | head c `elem` cs = NotPresent ct' (startWatch ct missed) c-    botPart' (WasPresent ct' missed mct c)-        | head c `elem` cs = WasPresent ct' (startWatch ct missed) mct c-    botPart' us = us---- | when somebody parts-partCB :: G.Message a => a -> SeenMap -> ClockTime -> Nick -> Either String SeenMap-partCB msg fm ct nick-  | nick == (G.packNick $ G.lambdabotName msg) = Right $ botPart ct (msgChans msg) fm-  | otherwise      = case M.lookup nick fm of-      Just (Present mct xs) ->-        case xs \\ (msgChans msg) of-          [] -> Right $! M.insert nick-                 (NotPresent ct zeroWatch xs)-                 fm-          ys -> Right $! M.insert nick-                                 (Present mct ys)-                                 fm-      _ -> Left "someone who isn't known parted"---- | when somebody quits-quitCB :: G.Message a => a -> SeenMap -> ClockTime -> Nick -> Either String SeenMap-quitCB _ fm ct nick = case M.lookup nick fm of-    Just (Present _ct xs) -> Right $! M.insert nick (NotPresent ct zeroWatch xs) fm-    _ -> Left "someone who isn't known has quit"---- | when somebody changes his\/her name-nickCB :: G.Message a => a -> SeenMap -> ClockTime -> Nick -> Either String SeenMap-nickCB msg fm _ nick = case M.lookup nick fm of-   Just status -> let fm' = M.insert nick (NewNick lcnewnick) fm-                  in  Right $! M.insert lcnewnick status fm'-   _           -> Left "someone who isn't here changed nick"-   where-   newnick = drop 1 $ head (G.body msg)-   lcnewnick = G.packNick $ lcNick $ G.readNick msg newnick---- use IRC.IRC.channels?--- | when the bot join a channel-joinChanCB :: G.Message a => a -> SeenMap -> ClockTime -> Nick -> Either String SeenMap-joinChanCB msg fm now _nick-    = Right $ fmap (updateNP now chan) $ foldl insertNick fm chanUsers-  where-    l = G.body msg-    chan = G.packNick $ lcNick $ G.readNick msg $ l !! 2-    chanUsers = map (G.packNick . lcNick . G.readNick msg) $ words (drop 1 (l !! 3)) -- remove ':'-    insertNick fm' u = insertUpd (updateJ (Just now) [chan])-                                    (G.packNick . unUserMode . lcNick . G.unpackNick $ u)-                                    (Present Nothing [chan])-                                    fm'---- | when somebody speaks, update their clocktime-msgCB :: G.Message a => a -> SeenMap -> ClockTime -> Nick -> Either String SeenMap-msgCB _ fm ct nick =-  case M.lookup nick fm of-    Just (Present _ xs) -> Right $!-      M.insert nick (Present (Just (ct, noTimeDiff)) xs) fm-    _ -> Left "someone who isn't here msg us"---- misc. functions-unUserMode :: G.Nick -> G.Nick-unUserMode nick = G.Nick (G.nTag nick) (dropWhile (`elem` "@+") $ G.nName nick)---- | Callbacks are only allowed to use a limited knowledge of the world.--- 'withSeenFM' is (up to trivial isomorphism) a monad morphism from the--- restricted---   'ReaderT (IRC.Message, ClockTime, Nick) (StateT SeenState (Error String))'--- to the---   'ReaderT IRC.Message (Seen IRC)'--- monad.-withSeenFM :: G.Message a-           => (a -> SeenMap -> ClockTime -> Nick -> Either String SeenMap)-           -> a-           -> Seen LB ()--withSeenFM f msg = do-    let nick = G.packNick . lcNick . G.nick $ msg-    withMS $ \(maxUsers,state) writer -> do-      ct <- io getClockTime-      case f msg state ct nick of-          Left _         -> return () -- debugStrLn $ "SeenModule> " ++ err-          Right newstate -> do--                let curUsers = length $! [ () | (_,Present _ chans) <- M.toList state-                                         , P.pack chan `elem` chans ]--                    newMax = case M.lookup chan maxUsers of-                        Nothing -> M.insert chan curUsers maxUsers-                        Just  n -> if n < curUsers-                                        then M.insert chan curUsers maxUsers-                                        else maxUsers--                newMax `seq` newstate `seq` writer (newMax, newstate)--    where chan = P.unpack . G.packNick . lcNick . head . G.channels $! msg---- | Update the user status.-updateJ :: Maybe ClockTime -- ^ If the bot joined the channel, the time that-                           --   happened, i.e. now.-  -> [Channel]             -- ^ The channels the user joined.-  -> UserStatus            -- ^ The old status-  -> UserStatus            -- ^ The new status--- The user was present before, so he's present now.-updateJ _ c (Present ct cs) = Present ct $ nub (c ++ cs)--- The user was present when we left that channel and now we've come back.--- We need to update the time we've missed.-updateJ (Just now) cs (WasPresent lastSeen _ (Just (lastSpoke, missed)) channels)-  | head channels `elem` cs-  ---                 newMissed-  --- |---------------------------------------|-  --- |-------------------|                   |-  ---        missed    lastSeen              now-  = let newMissed = addToClockTime missed now `diffClockTimes` lastSeen-    in  newMissed `seq` Present (Just (lastSpoke, newMissed)) cs--- Otherwise, we create a new record of the user.-updateJ _ cs _ = Present Nothing cs---- | Update a user who is not present. We just convert absolute missing time---   into relative time (i.e. start the "watch").-updateNP :: ClockTime -> Channel -> UserStatus -> UserStatus-updateNP now _ (NotPresent ct missed c)-  = NotPresent ct (stopWatch now missed) c--- The user might be gone, thus it's meaningless when we last heard him speak.-updateNP now chan (WasPresent lastSeen missed _ cs)-  | head cs == chan = WasPresent lastSeen (stopWatch now missed) Nothing cs-updateNP _ _ status = status----------------------------------------------------------------------------- Stop watches mini-library ----zeroWatch :: StopWatch-zeroWatch = Stopped noTimeDiff--startWatch :: ClockTime -> StopWatch -> StopWatch-startWatch now (Stopped td) = Running $! td `addToClockTime` now-startWatch _ alreadyStarted = alreadyStarted--stopWatch :: ClockTime -> StopWatch -> StopWatch-stopWatch now (Running t)  = Stopped $! t `diffClockTimes` now-stopWatch _ alreadyStopped = alreadyStopped
− Plugin/Slap.hs 
@@ -1,66 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}--- | Support for quotes-module Plugin.Slap (theModule) where--import Plugin-import qualified Message (nick, showNick)--$(plugin "Quote")--instance Module QuoteModule () where-    moduleCmds _           = ["slap", "smack"]-    moduleHelp _ _         = "slap <nick>. Slap someone amusingly."-    process _ msg _ _ rest = ios $ slapRandom (if rest == "me" then sender else rest)-       where sender = Message.showNick msg $ Message.nick msg------------------------------------------------------------------------------ | Return a random arr-quote-slapRandom :: String -> IO String-slapRandom = (randomElem slapList `ap`) . return--slapList :: [String -> String]-slapList =-    [(\x -> "/me slaps " ++ x)-    ,(\x -> "/me smacks " ++ x ++ " about with a large trout")-    ,(\x -> "/me beats up " ++ x)-    ,(\x -> "/me pokes " ++ x ++ " in the eye")-    ,(\x -> "why on earth would I slap " ++ x ++ "?")-    ,(\x -> "*SMACK*, *SLAM*, take that " ++ x ++ "!")-    ,(\_ -> "/me activates her slap-o-matic...")-    ,(\x -> "/me orders her trained monkeys to punch " ++ x)-    ,(\x -> "/me smashes a lamp on " ++ possesiveForm x ++ " head")-    ,(\x -> "/me hits " ++ x ++ " with a hammer, so they breaks into a thousand pieces")-    ,(\x -> "/me throws some pointy lambdas at " ++ x)-    ,(\x -> "/me loves " ++ x ++ ", so no slapping")-    ,(\x -> "/me would never hurt " ++ x ++ "!")-    ,(\x -> "go slap " ++ x ++ " yourself")-    ,(\_ -> "I won't; I want to go get some cookies instead.")-    ,(\x -> "I'd rather not; " ++ x ++ " looks rather dangerous.")-    ,(\_ -> "I don't perform such side effects on command!")-    ,(\_ -> "stop telling me what to do")-    ,(\x -> "/me clobbers " ++ x ++ " with an untyped language")-    ,(\x -> "/me pulls " ++ x ++ " through the Evil Mangler")-    ,(\x -> "/me secretly deletes " ++ possesiveForm x ++ " source code")-    ,(\x -> "/me places her fist firmly on " ++ possesiveForm x ++ " jaw")-    ,(\x -> "/me locks up " ++ x ++ " in a Monad")-    ,(\x -> "/me submits " ++ possesiveForm x ++ " email address to a dozen spam lists")-    ,(\x -> "/me moulds " ++ x ++ " into a delicous cookie, and places it in her oven")-    ,(\_ -> "/me will count to five...")-    ,(\x -> "/me jabs " ++ x ++ " with a C pointer")-    ,(\x -> "/me is overcome by a sudden desire to hurt " ++ x)-    ,(\x -> "/me karate-chops " ++ x ++ " into two equally sized halves")-    ,(\x -> "Come on, let's all slap " ++ x)-    ,(\x -> "/me pushes " ++ x ++ " from his chair")-    ,(\x -> "/me hits " ++ x ++ " with an assortment of kitchen utensils")-    ,(\x -> "/me slaps " ++ x ++ " with a slab of concrete")-    ,(\x -> "/me puts on her slapping gloves, and slaps " ++ x)-    ,(\x -> "/me decomposes " ++ x ++ " into several parts using the Banach-Tarski theorem and reassembles them to get two copies of " ++ x ++ "!")-    ]---- | The possesive form of a name, "x's"-possesiveForm :: String -> String-possesiveForm [] = []-possesiveForm x- | last x == 's' = x ++ "'"- | otherwise     = x ++ "'s"
− Plugin/Source.hs 
@@ -1,39 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeSynonymInstances #-}--- Plugin.Source--- Display source for specified identifiers-module Plugin.Source (theModule) where--import Plugin-import Lambdabot.Util-import qualified Data.Map as M-import qualified Data.ByteString.Char8 as P-import Data.ByteString.Char8 (pack,ByteString)--$(plugin "Source")--type Env = M.Map ByteString ByteString--instance Module SourceModule Env where-    moduleCmds _     = ["src"]-    moduleHelp _ _   = help--    -- all the hard work is done to build the src map.-    -- uses a slighly custom Map format-    moduleSerialize _= Just . readOnly $ M.fromList . map pair . splat . P.lines-        where-            pair (a:b) = (a, P.unlines b)-            splat []   = []-            splat s    = a : splat (tail b) where (a,b) = break P.null s--    fprocess_ _ _ key = readMS >>= \env -> case fetch key env of-        _ | M.null env -> box $ pack "No source in the environment yet"-        _ | P.null key -> box $ pack help-        Nothing        -> box . P.pack . ("Source not found. " ++) =<< io (random insult)-        Just s         -> box s--fetch :: ByteString -> M.Map ByteString ByteString -> Maybe ByteString-fetch x m = M.lookup x m `mplus`-            M.lookup (P.concat [P.singleton '(', x, P.singleton ')']) m--help :: String-help = "src <id>. Display the implementation of a standard function"
− Plugin/Spell.hs 
@@ -1,121 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, PatternGuards #-}--- Copyright (c) 2004-6 Don Stewart - http://www.cse.unsw.edu.au/~dons--- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)------ | Interface to /aspell/, an open source spelling checker, from a--- suggestion by Kai Engelhardt. Requires you to install aspell.-module Plugin.Spell where--import Plugin-import qualified Text.Regex as R--$(plugin "Spell")--instance Module SpellModule Bool where-    moduleCmds   _   = ["spell", "spell-all"]-    modulePrivs  _   = ["nazi-on", "nazi-off"]-    moduleHelp _ _   = "spell <word>. Show spelling of word"-    moduleDefState _ = return False--    process_ _ "spell" [] = box "No word to spell."-    process_ _ "spell" s  = (return . showClean . take 5) `fmap` liftIO (spell s)--    process_ _ "spell-all" [] = box "No phrase to spell."-    process_ _ "spell-all" s  = liftIO (spellingNazi s)--    process_ _ "nazi-on"  _ = on  >> box "Spelling nazi engaged."-    process_ _ "nazi-off" _ = off >> box "Spelling nazi disengaged."--    contextual _ _ _ txt      = do-        alive <- readMS-        if alive then liftIO $ spellingNazi txt-                 else return []--on :: ModuleUnit Bool-on  = writeMS True--off :: ModuleUnit Bool-off = writeMS False--binary :: String-binary = "aspell"--args :: [String]-args = ["pipe"]------- | Find the first misspelled word in the input line, and return plausible--- output.----spellingNazi :: String -> IO [String]-spellingNazi lin = fmap (take 1 . concat) (mapM correct (words lin))-    where correct word = do-            var <- take 5 `fmap` spell word-            return $ if null var || any (equating' lowerCaseString word) var-                then []-                else ["Did you mean " ++ listToStr "or" var ++ "?"]-          equating' f x y = f x == f y------ | Return a list of possible spellings for a word--- 'String' is a word to check the spelling of.----spell :: String -> IO [String]-spell word = spellWithDict word Nothing []------- | Like 'spell', but you can specify which dictionary and pass extra--- arguments to aspell.----spellWithDict :: String -> Maybe Dictionary -> [String] -> IO [String]-spellWithDict word (Just d) ex = spellWithDict word Nothing ("--master":show d:ex)-spellWithDict word Nothing  ex = do-    (out,err,_) <- popen binary (args++ex) (Just word)-    let o = fromMaybe [word] ((clean_ . lines) out)-        e = fromMaybe e      ((clean_ . lines) err)-    return $ case () of {_-        | null o && null e -> []-        | null o           -> e-        | otherwise        -> o-    }------- Parse the output of aspell (would probably work for ispell too)----clean_ :: [String] -> Maybe [String]-clean_ (('@':'(':'#':')':_):rest) = clean' rest -- drop header-clean_ s = clean' s                             -- no header for some reason------- Parse rest of aspell output.------ Grammar is:---      OK          ::=  *---      Suggestions ::= & <original> <count> <offset>: <miss>, <miss>, ...---      None        ::= # <original> <offset>----clean' :: [String] -> Maybe [String]-clean' (('*':_):_)    = Nothing                          -- correct spelling-clean' (('#':_):_)    = Just []                          -- no match-clean' (('&':rest):_) = Just $ split ", " (clean'' rest) -- suggestions-clean' _              = Just []                          -- not sure--clean'' :: String -> String-clean'' s-    | Just (_,_,m,_) <- pat `R.matchRegexAll` s = m-    | otherwise = s-    where pat  = regex' "[^:]*: "    -- drop header------- Alternate dictionaries, currently just lambdabot's. The idea was to--- have a dictionary for lambdabot commands, and aspell rather than--- levinshtein for spelling errors. Turns out to be quite complicated,--- for negligible gain.----data Dictionary-    = Lambdabot -- ^ Dictionary of lambdabot commands (it's its own language)---- path to the master dictionary-instance Show Dictionary where-    -- TODO: use findFile from File.hs. But does this module even work anymore?-    showsPrec _ Lambdabot = showString "State/lambdabot"-
− Plugin/State.hs 
@@ -1,33 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeSynonymInstances #-}--- | Persistent state--- A demo plugin-module Plugin.State (theModule) where--import Plugin--$(plugin "State")--instance Module StateModule String where-    moduleCmds      _ = [] -- ["state","++"]-    moduleHelp    _ _ = "state [expr]. Get or set a state variable."-    moduleDefState  _ = return "This page intentionally left blank."-    moduleSerialize _ = Just stdSerial-    process_  _ _ []      = withMS $ \s _ -> return $ if null s then [] else [s]-    process_ _ "state" t  = withMS $ \_ w -> w t >> return [t]-    process_ _ "++"    t  = withMS $ \s w -> w s >> return [s++t]--{---An example of scripting lambdabot. Implementing Rock/paper/scissors:--20:07  dons:: ?state (\xs -> case last (init xs) of '1' -> "rock"; '2' -> "paper"; '3' -> "scissors")-20:07  lambdabot:: (\xs -> case last (init xs) of '1' -> "rock"; '2' -> "paper"; '3' -> "scissors")--20:08  dons:: now, compose another plugin, with this state--20:08  dons:: ?. read . run . ++ . show dice 1d3-20:08  lambdabot::  paper-20:08  dons:: ?. read . run . ++ . show dice 1d3-20:08  lambdabot::  rock---}
− Plugin/System.hs 
@@ -1,135 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, Rank2Types #-}--- | System module : IRC control functions-module Plugin.System (theModule) where--import Plugin-import Lambdabot.AltTime-import qualified Message (Message, Nick, joinChannel, partChannel, server, readNick)-import qualified Data.Map as M       (Map,keys,fromList,lookup,union,insert,delete)--import Control.Monad.State      (MonadState(get, put), gets)--$(plugin "System")--instance Module SystemModule (ClockTime, TimeDiff) where-    moduleCmds   _   = M.keys syscmds-    modulePrivs  _   = M.keys privcmds-    moduleHelp _ s   = fromMaybe defaultHelp (M.lookup s $ syscmds `M.union` privcmds)-    process      _   = doSystem-    moduleDefState _ = flip (,) noTimeDiff `fmap` io getClockTime-    moduleSerialize  = const $ Just stdSerial-    moduleInit _     = do (_, d) <- readMS-                          t      <- liftIO getClockTime-                          writeMS (t, d)-    moduleExit _     = do (initial, d) <- readMS-                          now          <- liftIO getClockTime-                          writeMS (initial, max d (diffClockTimes now initial))----------------------------------------------------------------------------syscmds :: M.Map String String-syscmds = M.fromList-       [("listchans",   "Show channels bot has joined")-       ,("listmodules", "listmodules. Show available plugins")-       ,("listservers", "listservers. Show current servers")-       ,("list",        "list [module|command]\n"++-                        "show all commands or command for [module]. http://code.haskell.org/lambdabot/COMMANDS")-       ,("echo",        "echo <msg>. echo irc protocol string")-       ,("uptime",      "uptime. Show uptime")]--privcmds :: M.Map String String-privcmds = M.fromList [-        ("join",        "join <channel>")-       ,("leave",       "leave <channel>")-       ,("part",        "part <channel>")-       ,("msg",         "msg <nick or channel> <msg>")-       ,("quit",        "quit [msg], have the bot exit with msg")-       ,("listall",     "list all commands")-       ,("flush",       "flush. flush state to disk")-       ,("admin",       "admin [+|-] nick. change a user's admin status.")-       ,("ignore",      "ignore [+|-] nick. change a user's ignore status.")-       ,("reconnect",   "reconnect to server")]----------------------------------------------------------------------------defaultHelp :: String-defaultHelp = "system : irc management"--doSystem :: Message.Message a => a -> Message.Nick -> [Char] -> [Char] -> ModuleLB (ClockTime, TimeDiff)-doSystem msg _ cmd rest = get >>= \s -> case cmd of-  "listchans"   -> return [pprKeys (ircChannels s)]-  "listmodules" -> return [pprKeys (ircModules s) ]-  "listservers" -> return [pprKeys (ircServerMap s)]-  "listall"     -> lift listAll-  "list"| null rest -> return ["http://code.haskell.org/lambdabot/COMMANDS"]-        | otherwise -> lift $ listModule rest >>= return . (:[])--  --------------------------------------------------------------------------  --TODO error handling-   -- system commands-  "join"  -> lift $ send (Message.joinChannel (Message.readNick msg rest)) >> return []-  "leave" -> lift $ send (Message.partChannel (Message.readNick msg rest)) >> return []-  "part"  -> lift $ send (Message.partChannel (Message.readNick msg rest)) >> return []--   -- writes to another location:-  "msg"   -> lift $ ircPrivmsg (Message.readNick msg tgt) txt' >> return []-                  where (tgt, txt) = breakOnGlue " " rest-                        txt'       = dropWhile (== ' ') txt--  "quit" -> lift $ do ircQuit (Message.server msg) $ if null rest then "requested" else rest-                      return []--  "reconnect" -> lift $ do ircReconnect (Message.server msg) $ if null rest then "request" else rest-                           return []--  "echo" -> return [concat ["echo; msg:", show msg, " rest:", show rest]]--  "flush" -> lift $ do flushModuleState-                       return []--  "admin" -> do let pu = ircPrivilegedUsers s-                pu' <- case rest of '+':' ':_ -> return $ M.insert nck True pu-                                    '-':' ':_ -> return $ M.delete nck pu-                                    _         -> fail "@admin: invalid usage"-                put (s {ircPrivilegedUsers = pu'})-                return []-      where nck = Message.readNick msg (drop 2 rest)--  "ignore" -> do let iu = ircIgnoredUsers s-                 iu' <- case rest of '+':' ':_ -> return $ M.insert nck True iu-                                     '-':' ':_ -> return $ M.delete nck iu-                                     _         -> fail "@ignore: invalid usage"-                 put (s {ircIgnoredUsers = iu'})-                 return []-      where nck = Message.readNick msg (drop 2 rest)--  "uptime" -> do-          (loaded, m) <- readMS-          now         <- io getClockTime-          let diff = now `diffClockTimes` loaded-          return ["uptime: "           ++ timeDiffPretty diff ++-                  ", longest uptime: " ++ timeDiffPretty (max diff m)]----------------------------------------------------------------------------listAll :: LB [String]-listAll = get >>= mapM listModule . M.keys . ircModules--listModule :: String -> LB String-listModule s = withModule ircModules s fromCommand printProvides-  where-    fromCommand = withModule ircCommands s-        (return $ "No module \""++s++"\" loaded") printProvides--    -- ghc now needs a type annotation here-    printProvides :: (forall mod s. Module mod s => mod -> ModuleT s LB String)-    printProvides m = do-        let cmds = moduleCmds m-        privs <- gets ircPrivCommands-        let cmds' = cmds \\ privs -- don't display privledged commands-        name' <- getName-        return . concat $ if null cmds'-                          then [name', " has no visible commands"]-                          else [name', " provides: ", showClean cmds']-
− Plugin/Tell.hs 
@@ -1,225 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeSynonymInstances #-}-{- Leave a message with lambdabot, the faithful secretary--> 17:11 < davidhouse> @tell dmhouse foo-> 17:11 < hsbot> Consider it noted-> 17:11 < davidhouse> @tell dmhouse bar-> 17:11 < hsbot> Consider it noted-> 17:11 < dmhouse> hello!-> 17:11 < hsbot> dmhouse: You have 2 new messages. '/msg hsbot @messages' to read them.-> 17:11 < dmhouse> Notice how I'm speaking again, and hsbot isn't buzzing me more than that one time.-> 17:12 < dmhouse> It'll buzz me after a day's worth of not checking my messages.-> 17:12 < dmhouse> If I want to check them in the intermittent period, I can either send a /msg, or:-> 17:12 < dmhouse> @messages?-> 17:12 < hsbot> You have 2 messages-> 17:12 < dmhouse> Let's check them, shall we?->-> [In a /msg to hsbot]-> 17:12 <hsbot> davidhouse said less than a minute ago: foo-> 17:12 <hsbot> davidhouse said less than a minute ago: bar->-> [Back in the channel-> 17:12 < dmhouse> You needn't use a /msg, however. If you're not going to annoy the channel by printing 20 of->                  your messages, feel free to just type '@messages' in the channel.-> 17:12 < davidhouse> @tell dmhouse foobar-> 17:12 < hsbot> Consider it noted-> 17:12 < davidhouse> @ask dmhouse barfoo-> 17:12 < hsbot> Consider it noted-> 17:12 < davidhouse> You can see there @ask. It's just a synonym for @tell, but it prints "foo asked X ago M",->                     which is more natural. E.g. '@ask dons whether he's applied my latest patch yet?'-> 17:13 < dmhouse> For the admins, a useful little debugging tool is @print-notices.-> 17:13 < hsbot> dmhouse: You have 2 new messages. '/msg hsbot @messages' to read them.-> 17:14 < dmhouse> Notice that hsbot pinged me there, even though it's less than a day since I last checked my->                  messages, because there have been some new ones posted.-> 17:14 < dmhouse> @print-notices-> 17:14 < hsbot> {"dmhouse":=(Just Thu Jun  8 17:13:46 BST 2006,[Note {noteSender = "davidhouse", noteContents =->                "foobar", noteTime = Thu Jun  8 17:12:50 BST 2006, noteType = Tell},Note {noteSender =-                 "davidhouse", noteContents = "barfoo", noteTime = Thu Jun  8 17:12:55 BST 2006, noteType = Ask}])}-> 17:15 < dmhouse> There you can see the two notes. The internal state is a map from recipient nicks to a pair of->                  (when we last buzzed them about having messages, a list of the notes they've got stacked up).-> 17:16 < dmhouse> Finally, if you don't want to bother checking your messages, then the following command will->                  likely be useful.-> 17:16 < dmhouse> @clear-messages-> 17:16 < hsbot> Messages cleared.-> 17:16 < dmhouse> That's all, folks!-> 17:17 < dmhouse> Any comments, queries or complaints to dmhouse@gmail.com. The source should be fairly readable, so->                  hack away!--}--module Plugin.Tell where--import Control.Arrow (first)-import qualified Data.Map as M-import Text.Printf (printf)--import Lambdabot.AltTime-import Message-import Plugin---- | Was it @tell or @ask that was the original command?-data NoteType    = Tell | Ask deriving (Show, Eq, Read)--- | The Note datatype. Fields self-explanatory.-data Note        = Note { noteSender   :: Nick,-                          noteContents :: String,-                          noteTime     :: ClockTime,-                          noteType     :: NoteType }-                   deriving (Eq, Show, Read)--- | The state. A map of (times we last told this nick they've got messages, the---   messages themselves)-type NoticeBoard = M.Map Nick (Maybe ClockTime, [Note])--- | A nicer synonym for the Tell monad.-type Telling a   = ModuleT NoticeBoard LB a--$(plugin "Tell")--instance Module TellModule NoticeBoard where-    moduleCmds      _ = ["tell", "ask", "messages", "messages?", "clear-messages"]-    modulePrivs     _ = ["print-notices", "purge-notices"]-    moduleHelp      _ = fromJust . flip lookup help-    moduleDefState  _ = return M.empty-    moduleSerialize _ = Just mapSerial--    -- | Debug output the NoticeBoard-    process _ _ _ "print-notices" _ = liftM ((:[]) . show) readMS--    -- | Clear notes.-    process _ msg _ "purge-notices" args = do-        case words args of-          [] -> writeMS M.empty-          ns -> mapM_ (clearMessages . readNick msg) ns-        return ["Messages purged."]--    -- | Clear a user's notes-    process _ msg _ "clear-messages" _ =-      clearMessages (nick msg) >> return ["Messages cleared."]--    -- | Check whether a user has any messages-    process _ msg _ "messages?" _  = do-      let sender = nick msg-      ms <- getMessages msg sender-      case ms of-        Just _ -> doRemind msg sender-        Nothing   -> return ["Sorry, no messages today."]--    -- | Write down a note-    process _ msg _ "tell" args = doTell args msg Tell--    -- | Really just a synonym for "@tell", but phrases it as a question instead.-    process _ msg _ "ask" args = doTell args msg Ask--    -- | Give a user their messages-    process _ msg _ "messages" _ =-      do msgs <- getMessages msg $ nick msg-         let res = fromMaybe ["You don't have any new messages."] msgs-         clearMessages (nick msg)-         return res--    -- | Hook onto contextual. Grab nicks of incoming messages, and tell them-    --   if they have any messages, if it's less than a day since we last did so.-    contextual _ msg _ _ = do-      let sender = nick msg-      remp <- needToRemind sender-      if remp-         then doRemind msg sender-         else return []---- | Lookup table for documentation-help :: [(String, String)]-help = [("tell",-         "tell <nick> <message>. When <nick> shows activity, tell them " ++-           "<message>."),-        ("ask",-         "ask <nick> <message>. When <nick> shows activity, ask them " ++-           "<message>."),-        ("messages",-         "messages. Check your messages."),-        ("messages?",-         "messages?. Tells you whether you have any messages"),-        ("clear-messages",-         "clear-messages. Clears your messages."),-        ("print-notices", "print-notices. Print the current map of notes."),-        ("purge-notices", "purge-notices [<nick> [<nick> [<nick> ...]]]]. " ++-          "Clear all notes for specified nicks, or all notices if you don't "-          ++ "specify a nick.")]---- | Take a note and the current time, then display it-showNote :: Message m => m -> ClockTime -> Note -> String-showNote msg time note = res-    where diff         = time `diffClockTimes` noteTime note-          ago          = case timeDiffPretty diff of-                           [] -> "less than a minute"-                           pr -> pr-          action       = case noteType note of Tell -> "said"; Ask -> "asked"-          res          = printf "%s %s %s ago: %s"-                           (showNick msg $ noteSender note) action ago (noteContents note)---- | Is it less than a day since we last reminded this nick they've got messages?-needToRemind :: Nick -> Telling Bool-needToRemind n = do-  st  <- readMS-  now <- io getClockTime-  return $ case M.lookup n st of-             Just (Just lastTime, _) ->-               let diff = now `diffClockTimes` lastTime-               in diff > noTimeDiff { tdDay = 1 }-             Just (Nothing,       _) -> True-             Nothing                 -> True---- | Add a note to the NoticeBoard-writeDown :: Nick -> Nick -> String -> NoteType -> Telling ()-writeDown to from what ntype = do-  time <- io getClockTime-  let note = Note { noteSender   = from,-                    noteContents = what,-                    noteTime     = time,-                    noteType     = ntype }-  modifyMS (M.insertWith (\_ (_, ns) -> (Nothing, ns ++ [note]))-                         to (Nothing, [note]))---- | Return a user's notes, or Nothing if they don't have any-getMessages :: Message m => m -> Nick -> Telling (Maybe [String])-getMessages msg n = do-  st   <- readMS-  time <- io getClockTime-  case M.lookup n st of-    Just (_, msgs) -> do-      -- update the last time we told this person they had messages-      writeMS $ M.insert n (Just time, msgs) st-      return . Just $ map (showNote msg time) msgs-    Nothing -> return Nothing---- | Clear a user's messages.-clearMessages :: Nick -> Telling ()-clearMessages n = modifyMS (M.delete n)---- * Handlers------- | Execute a @tell or @ask command.-doTell :: Message m => String -> m -> NoteType -> Telling [String]-doTell args msg ntype = do-  let args'     = words args-      recipient = readNick msg (head args')-      sender    = nick msg-      rest      = unwords $ tail args'-      res | sender    == recipient   = Left "You can tell yourself!"-          | recipient == lambdabotName msg = Left "Nice try ;)"-          | otherwise                = Right "Consider it noted."-  when (isRight res) (writeDown recipient sender rest ntype)-  return [unEither res]---- | Remind a user that they have messages.-doRemind :: Message m => m -> Nick -> Telling [String]-doRemind msg sender = do-  ms  <- getMessages msg sender-  now <- io getClockTime-  modifyMS (M.update (Just . first (const $ Just now)) sender)-  return $ case ms of-             Just msgs ->-               let (messages, pronoun) =-                     if length msgs > 1-                       then ("messages", "them") else ("message", "it")-               in [printf "%s: You have %d new %s. '/msg %s @messages' to read %s."-                          (showNick msg sender) (length msgs) messages (showNick msg $ lambdabotName msg) pronoun-                   :: String]-             Nothing -> []
− Plugin/Ticker.hs 
@@ -1,147 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}---- | Pull quotes down from yahoo.-module Plugin.Ticker (theModule) where--import Plugin hiding((<$>))-import Data.Either-import Control.Applicative ((<$>))--- import Control.Arrow (second)-import Text.Printf--$(plugin "Ticker")--instance Module TickerModule () where-    moduleCmds      _     = ["ticker", "bid"]-    moduleHelp _ s        = case s of-         "ticker" -> "ticker symbols.  Look up quotes for symbols"-         "bid"    -> "bid symbols.  Sum up the bid and ask prices for symbols."-    process_ _ "ticker" e = lift $ tickerCmd e-    process_ _ "bid"    e = lift $ bidsCmd e------------------------------------------------------------------------------ Fetch several ticker quotes and report them.-tickerCmd :: String -> LB [String]-tickerCmd []        = return ["Empty ticker."]-tickerCmd tickers = do-    quotes <- io $ fetchPage "GET" $ tickerUrl $ words tickers-    case [x | Just x <- map extractQuote quotes] of-      []       -> return ["No Result Found."]-      xs       -> return xs---- fetch: s symbol, l1 price, c change with percent, d1 date, t1 time.-tickerUrl :: [String] -> String-tickerUrl tickers =  "http://download.finance.yahoo.com/d/quotes.csv?f=sl1cd1t1&e=.csv&s=" ++ ts-    where ts = concatWith "+" $ map urlEncode tickers---- $ curl "http://download.finance.yahoo.com/d/quotes.csv?f=sl1cd1t1&e=.csv&s=C"--- "C",23.19,"-0.45 - -1.90%","5/13/2008","1:32pm"--- "GBPUSD=X",1.9478,"N/A - N/A","5/13/2008","1:52pm"-extractQuote :: String -> Maybe String-extractQuote = getQuote . csv-    where-        getQuote [sym, price, change, date, time] =-            Just $ printf "%s: %s %s@ %s %s" sym price change' date time-            where change' = case words change of-                              ("N/A":_)    -> ""-                              [ch, _, pch] -> ch ++ " (" ++ pch ++ ") "-                              _            -> ""-        getQuote _ = Nothing---- Fetch quotes for tickers and sum their bid/ask prices.-bidsCmd :: String -> LB [String]-bidsCmd tickers =-    case words tickers of-        [] -> return [printf "Invalid argument '%s'" tickers]-        xs -> io $ (:[]) <$> calcBids xs---- fetch: b bid, a ask-bidsUrl :: [String] -> String-bidsUrl tickers = "http://download.finance.yahoo.com/d/quotes.csv?f=ba&e=.csv&s=" ++ ts-    where ts = concatWith "+" $ map urlEncode tickers--getBidAsks :: [String] -> IO [Maybe (Float, Float)]-getBidAsks tickers = do-    xs <- fetchPage "GET" $ bidsUrl tickers-    return $ map (extractPrice.csv) xs-    where-        extractPrice :: [String] -> Maybe (Float, Float)-        extractPrice [bid,ask] = liftM2 (,) (readMaybe bid) (readMaybe ask)-        extractPrice _         = Nothing--type AccumVal = Either String (Float, Float)---- If we have a new bid/ask pair, accumulate it (normally add, but--- if the ticker starts with '-' then subtract).  If there is no--- value, make a note that it is an error.-accumOption :: AccumVal -> (String, Maybe (Float, Float)) -> AccumVal-accumOption err@(Left _) _ = err-accumOption (Right _) (ticker, Nothing) = Left $ printf "Can't find '%s'" ticker-accumOption (Right (a,b)) (('-':_), Just (a',b')) = Right (a-b', b-a')-accumOption (Right (a,b)) (_, Just (a',b')) = Right (a+a', b+b')---- Take a list of tickers which are optionally prefixed with '+' or '-'--- and add up (or subtract) the bid/ask prices on the based on the prefix.-calcBids :: [String] -> IO String-calcBids ticks = do-    xs <- getBidAsks $ map noPrefix ticks-    return $ case foldl accumOption (Right (0,0)) (zip ticks xs) of-        (Left err)        -> err-        (Right (bid,ask)) -> printf "%s: bid $%.02f, ask $%.02f" s bid ask-    where-        s = unwords ticks-        noPrefix ('+':xs) = xs-        noPrefix ('-':xs) = xs-        noPrefix xs = xs------- Library routines, consider moving elsewhere. -------- | Fetch a page via HTTP and return its body as a list of lines.-fetchPage :: String -> String -> IO [String]-fetchPage meth url = cleanup <$> readPage (proxy config) uri request ""-    where Just uri = parseURI url-          abs_path = uriPath uri ++ uriQuery uri ++ uriFragment uri-          request  = case proxy config of-                        Nothing -> [meth ++ " " ++ abs_path ++ " HTTP/1.0", ""]-                        _       -> [meth ++ " " ++ url ++ " HTTP/1.0", ""]-          dropHdr = drop 1 . dropWhile (not.null)-          cleanup = dropHdr . (map (filter (/= '\r')))---- | Split a list into two lists based on a predicate.-splitWhile :: (a -> Bool) -> [a] -> ([a], [a])-splitWhile p xs = (takeWhile p xs, dropWhile p xs)---- | Unfoldr, continuing while the predicate is true.-{--unfoldrp :: (b -> Bool) -> (b -> Maybe (a, b)) -> b -> [a]-unfoldrp p f = unfoldr (\x -> guard (p x) >> f x)--}---- | Split a list on a distinguished character (which is eliminated).-{--splitList :: (Eq a) => a -> [a] -> [[a]]-splitList ch = unfoldrp (not.null) (return.f)-    where f = (second (drop 1)) . (splitWhile (/= ch))--}---- | Return a list of comma-separated values.--- Quotes allowed in CSV if it's the first character of a field.-csv :: String -> [String]-csv ('"':xs) = case splitWhile (/= '"') xs of-                  (word, '"':',':rest) -> word : csv rest-                  (word, '"':[])       -> word : []-                  _                    -> error "invalid CSV"-csv xs = case splitWhile (/= ',') xs of-             (word, ',':rest) -> word : csv rest-             ([], [])         -> []-             (word, [])       -> [word]-             _                -> error "shouldn't happen"---- | Read a value from a string.-readMaybe :: Read a => String -> Maybe a-readMaybe x = case readsPrec 0 x of-                [(y,"")] -> Just y-                _        -> Nothing-
− Plugin/Todo.hs 
@@ -1,69 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, PatternGuards, ScopedTypeVariables, TypeSynonymInstances #-}--- | A todo list------ (c) 2005 Samuel Bronson-module Plugin.Todo (theModule) where--import Plugin-import Message (Message, nick, packNick, unpackNick, showNick)-import qualified Data.ByteString.Char8 as P--$(plugin "Todo")---- A list of key/elem pairs with an ordering determined by its position in the list-type TodoState = [(P.ByteString, P.ByteString)]--instance Module TodoModule TodoState where-    moduleCmds  _ = ["todo", "todo-add"]-    modulePrivs _ = ["todo-delete"]-    moduleHelp _ s = case s of-        "todo"        -> "todo. List todo entries"-        "todo-add"    -> "todo-add <idea>. Add a todo entry"-        "todo-delete" -> "todo-delete <n>. Delete a todo entry (for admins)"-        _ -> "Keep a todo list. Provides @todo, @todo-add, @todo-delete"--    moduleDefState  _ = return ([] :: TodoState)-    moduleSerialize _ = Just assocListPackedSerial--    process _ msg _ cmd rest = do-       todoList <- readMS-       case cmd of-           "todo"        -> getTodo msg todoList rest-           "todo-add"    -> addTodo sender rest-           "todo-delete" -> delTodo rest--        where sender = Message.packNick $ Message.nick msg---- | Print todo list-getTodo :: Message.Message m => m -> TodoState -> String -> ModuleLB TodoState-getTodo msg todoList [] = return [formatTodo msg todoList]-getTodo _ _ _           = error "@todo has no args, try @todo-add or @list todo"---- | Pretty print todo list-formatTodo :: Message.Message m => m -> [(P.ByteString, P.ByteString)] -> String-formatTodo _ [] = "Nothing to do!"-formatTodo msg todoList =-    unlines $ map (\(n::Int, (idea, nick_)) -> concat $-            [ show n,". ",showNick msg $ unpackNick nick_,": ",P.unpack idea ]) $-                zip [0..] todoList---- | Add new entry to list-addTodo :: P.ByteString -> String -> ModuleLB TodoState-addTodo sender rest = do-    modifyMS (++[(P.pack rest, sender)])-    return ["Entry added to the todo list"]---- | Delete an entry from the list-delTodo :: String -> ModuleLB TodoState-delTodo rest-    | Just n <- readM rest = withMS $ \ls write -> case () of-      _ | null ls -> return ["Todo list is empty"]-        | n > length ls - 1 || n < 0-        -> return [show n ++ " is out of range"]--        | otherwise -> do-            write (map snd . filter ((/= n) . fst) . zip [0..] $ ls)-            let (a,_) = ls !! n-            return ["Removed: " ++ P.unpack a]--    | otherwise = return ["Syntax error. @todo <n>, where n :: Int"]
− Plugin/Topic.hs 
@@ -1,83 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}--- | The Topic plugin is an interface for messing with the channel topic.---   It can alter the topic in various ways and keep track of the changes.---   The advantage of having the bot maintain the topic is that we get an---   authoritative source for the current topic, when the IRC server decides---   to delete it due to Network Splits.-module Plugin.Topic (theModule) where--import Plugin-import Message (Message, setTopic, Nick, readNick)-import qualified Data.Map as M--import Control.Monad.State (gets)--$(plugin "Topic")--instance Module TopicModule () where-  moduleHelp _ s = case s of-      "topic-tell" -> "@topic-tell #chan -- " ++-                       "Tell the requesting person of the topic of the channel"-      "topic-cons" -> "@topic-cons #chan <mess> -- " ++-                       "Add a new topic item to the front of the topic list"-      "topic-snoc" -> "@topic-snoc #chan <mess> -- " ++-                       "Add a new topic item to the back of the topic list"-      "topic-tail" -> "@topic-tail #chan -- " ++-                       "Remove the first topic item from the topic list"-      "topic-null" -> "@topic-null #chan -- " ++-                       "Clear out the topic entirely"-      "topic-init" -> "@topic-init #chan -- " ++-                       "Remove the last topic item from the topic list"-      _ -> "Someone forgot to document his new Topic function! Shame on him/her!"--  moduleCmds   _ = ["topic-tell",-                   "topic-cons", "topic-snoc",-                   "topic-tail", "topic-init", "topic-null"]--  process _ msg _ "topic-cons" text = lift $ alterTopic msg chan (topic_item :)-        where (chan, topic_item) = splitFirstWord text--  process _ msg _ "topic-snoc" text = lift $ alterTopic msg chan (snoc topic_item)-        where (chan, topic_item) = splitFirstWord text--  process _ msg _ "topic-tail" chan = lift $ alterTopic msg chan tail-  process _ msg _ "topic-init" chan = lift $ alterTopic msg chan init-  process _ msg _ "topic-null" chan = lift $ send (Message.setTopic (readNick msg chan) "[]") >> return []-  process _ msg _ "topic-tell" chan = lift $ lookupTopic (readNick msg chan) $ \maybetopic -> return $-        case maybetopic of-            Just x  -> [x]-            Nothing -> ["Do not know that channel"]------------------------------------------------------------------------------ | 'lookupTopic' Takes a channel and a modifier function f. It then---   proceeds to look up the channel topic for the channel given, returning---   Just t or Nothing to the modifier function which can then decide what---   to do with the topic-lookupTopic :: Nick                          -- ^ Channel-            -> (Maybe String -> LB [String]) -- ^ Modifier function-            -> LB [String]-lookupTopic chan f = gets (\s -> M.lookup (mkCN chan) (ircChannels s)) >>= f---- | 'alterTopic' takes a message, a channel and an altering function.---   Then it alters the topic in the channel by the altering function,---   returning eventual problems back to the sender.-alterTopic :: Message a-           => a                      -- ^ Original messesg-           -> String                 -- ^ Channel name-           -> ([String] -> [String]) -- ^ Modifying function-           -> LB [String]-alterTopic msg chan f =-  let chan' = readNick msg chan-      p maybetopic =-        case maybetopic of-          Just x -> case reads x of-                [(xs, "")] -> do send $ Message.setTopic chan' (show $ f $ xs)-                                 return []-                [(xs, r)] | length r <= 2-                  -> do send $ Message.setTopic chan' (show $ f $ xs)-                        return ["ignoring bogus characters: " ++ r]--                _ -> return ["Topic does not parse. Should be of the form [\"...\",...,\"...\"]"]-          Nothing -> return ["I do not know the channel " ++ chan]-   in lookupTopic chan' p
− Plugin/Type.hs 
@@ -1,213 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, 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 Plugin.Type where-import File-import Plugin-import qualified Text.Regex as R--$(plugin "Type")--instance Module TypeModule () where-     moduleCmds        _  = ["type", "kind"]-     moduleHelp _ "kind"  = "kind <type>. Return the kind of a type"-     moduleHelp _ _       = "type <expr>. Return the type of a value"-     process_ _ s expr = lift $ flip query_ghci expr $ case s of-                                                    "type" -> ":t"-                                                    "kind" -> ":k"--     contextual  _ _ _ text = case () of-        _| ":t " `isPrefixOf` text -> lift $ query_ghci ":t" expr-         | ":k " `isPrefixOf` text -> lift $ query_ghci ":k" expr-         | otherwise               -> return []-         where expr = drop 3 text----     In accordance with the KISS principle, the plan is to delegate all---     the hard work! To get the type of foo, pipe--command :: [Char] -> [Char] -> [Char]-command cmd foo = cmd ++ " " ++ foo----     into hugs and send any line matching--signature_regex :: Regex-signature_regex-    = R.mkRegexWithOpts-      "^(\\*?[A-Z][_a-zA-Z0-9]*(\\*?[A-Z][_a-zA-Z0-9]*)*>)? *(.*[       -=:].*)"-      True True------- 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 []          = []-stripComments ('\n':_)    = [] -- drop any newwline and rest. *security*-stripComments ('-':'-':_) = []  ---stripComments ('{':'-':cs)= stripComments (go 1 cs)-stripComments (c:cs)      = c : stripComments cs---- Adapted from ghc/compiler/parser/Lexer.x-go :: Int -> String -> String-go 0 xs         = xs-go _ ('-':[])   = []   -- unterminated-go n ('-':x:xs)-    | x == '}'  = go (n-1) xs-    | otherwise = go n (x:xs)-go _ ('{':[])   = []  -- unterminated-go n ('{':x:xs)-    | x == '-'  = go (n+1) xs-    | otherwise = go n (x:xs)-go n (_:xs) = go n 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 output-        = fmap reverse . removeExp . reverse .-          unwords . map (dropWhile isSpace . expandTab) .-          mapMaybe ((>>= last') . R.matchRegex signature_regex) .-          lines $ output-        where-        last' [] = Nothing-        last' xs = Just $ last xs--        removeExp :: String -> Maybe String-        removeExp [] = Nothing-        removeExp xs = removeExp' 0 xs--        removeExp' :: Int -> String -> Maybe String-        removeExp' 0 (' ':':':':':' ':_) = Just []-        removeExp' n ('(':xs)            = ('(':) `fmap` removeExp' (n+1) xs-        removeExp' n (')':xs)            = (')':) `fmap` removeExp' (n-1) xs-        removeExp' n (x  :xs)            = (x  :) `fmap` removeExp'  n    xs-        removeExp' _ []                  = Nothing-------     With this the command handler can be easily defined using popen:------ TODO, bring more modules into scope.----query_ghci' :: String -> String -> IO String-query_ghci' cmd expr = do-       importHeader <- findFile "imports.h"-       imports <- fmap (map (unwords . drop 1 . words)-                        . filter (null-                                  . intersect ["as","hiding","qualified"]-                                  . words)-                        . filter (isPrefixOf "import")-                        . lines)-                       (readFile importHeader)-       l <- findFile "L.hs"-       let context = ":load "++l++"\n" ++ concatMap ((":m + " ++) . (++"\n")) imports-       (output, errors, _) <- popen (ghci config) ["-v0","-fglasgow-exts","-XNoTemplateHaskell","-iState","-iscripts","-XNoMonomorphismRestriction"]-                                       (Just (context ++ command cmd (stripComments expr)))-       let ls = extract_signatures output-       return $ case ls of-                  Nothing -> unlines . take 3 . filter (not . null) . map cleanRE2 .-                             lines . expandTab . cleanRE . filter (/='\r') $ errors -- "bzzt"-                  Just t -> t-  where-     {--     context = ":l L\n" ++ (concatMap (\m -> ":m + "++m++"\n") $-                    prehier ++ datas ++ qualifieds ++ controls ++ other ++ extras)--     other      =-        ["Text.Printf"-        ,"Text.PrettyPrint.HughesPJ"]--     prehier    = ["Numeric"]--     qualifieds = []--     datas   = map ("Data." ++)-        ["Array"-        ,"Bits"-        ,"Bool"-        ,"Char"-        ,"Complex"-        ,"Dynamic"-        ,"Either"-        ,"Eq"-        ,"Fixed"-    --  ,"Foldable"-    --  ,"Function"-    --  ,"Generics"-        ,"Graph"-        ,"Int"-    --  ,"IntMap"-    --  ,"IntSet"-        ,"Ix"-        ,"List"-    --  ,"Map"-        ,"Maybe"-        ,"Monoid"-        ,"Ord"-        ,"Ratio"-    --  ,"Set"-        ,"Tree"-        ,"Tuple"-        ,"Typeable"-        ,"Word"-        ]-     extras   = [] -- ["L"]--     controls = map ("Control." ++)-        ["Monad"-        ,"Monad.Cont"-        ,"Monad.Error"-        ,"Monad.Identity"-        ,"Monad.List"-        ,"Monad.RWS"-        ,"Monad.Reader"-        ,"Monad.State"-        ,"Monad.Trans"-        ,"Monad.Writer"-        ,"Monad.Fix"-        ,"Monad.Instances"-        ,"Applicative"-        ,"Arrow"-    --  ,"Arrow.Transformer"-    --  ,"Arrow.Transformer.All"-    --  ,"Arrow.Operations"-        ,"Parallel"-        ,"Parallel.Strategies"-        ]-     -}--     cleanRE, cleanRE2 :: String -> String-     cleanRE s-        | Just _         <- notfound `R.matchRegex` s = "Couldn\'t find qualified module."-        | Just (_,_,b,_) <- ghci_msg `R.matchRegexAll`  s = b-        | otherwise      = s-     cleanRE2 s-        | Just (_,_,b,_) <- ghci_msg `R.matchRegexAll`  s = b-        | otherwise      = s-     ghci_msg = R.mkRegex "<interactive>:[^:]*:[^:]*: ?"-     notfound = R.mkRegex "Failed to load interface"--query_ghci :: String -> String -> LB [String]-query_ghci y z = ios (query_ghci' y z)
− Plugin/UnMtl.hs 
@@ -1,181 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}-------------------------------------------------------------------------- |--- Module      : Plugin.UnMtl--- Copyright   : Don Stewart, Lennart Kolmodin 2007, Twan van Laarhoven 2008--- License     : GPL-style (see LICENSE)------ Unroll the MTL monads with your favorite bot!----------------------------------------------------------------------------module Plugin.UnMtl where--import Control.Monad.Error ()--import Language.Haskell.Syntax-import Language.Haskell.Parser-import Lambdabot.Parser (prettyPrintInLine)--import Plugin as P--$(plugin "UnMtl")--instance P.Module UnMtlModule () where-    moduleCmds   _ = ["unmtl"]-    moduleHelp _ _ = "unroll mtl monads"-    process_ _ _ mtl =-        return $ [ either ("err: "++) prettyPrintInLine (mtlParser mtl) ]---------------------------------------------------------------- 'PType' wrapper type--data PMonad a = PMonad-       { pResult :: a                      -- The result (trsnsformed type)-       , pError  :: Maybe String           -- An error message?-       , pFun    :: Maybe (PType -> PType) -- A type function-       }--type PType = PMonad HsType---- A monad instance so we get things like liftM and sequence for free-instance Monad PMonad where-    return t = PMonad t Nothing Nothing-    m >>= g  = let x = g (pResult m)-               in PMonad (pResult x) (pError m `mplus` pError x) Nothing---------------------------------------------------------------- Lifiting function types--type P = PType--lift0 :: P                            -> HsType -> P-lift1 :: (P -> P)                     -> HsType -> P-lift2 :: (P -> P -> P)                -> HsType -> P-lift3 :: (P -> P -> P -> P)           -> HsType -> P-lift4 :: (P -> P -> P -> P -> P)      -> HsType -> P-lift5 :: (P -> P -> P -> P -> P -> P) -> HsType -> P--lift0 f _ = f-lift1 f n = mkPfun n (lift0 . f)-lift2 f n = mkPfun n (lift1 . f)-lift3 f n = mkPfun n (lift2 . f)-lift4 f n = mkPfun n (lift3 . f)-lift5 f n = mkPfun n (lift4 . f)--mkPfun :: HsType -> (PType -> HsType -> PType) -> PType-mkPfun n cont = PMonad n (Just msg) (Just fun)-  where fun p = cont p (HsTyApp n (pResult p))-        msg = "`" ++ prettyPrintInLine n ++ "' is not applied to enough arguments" ++ full fun ['A'..'Z'] "/\\"-        full p (x:xs) l = case p (con [x]) of-                   PMonad{pFun    = Just p'} -> full p' xs l'-                   PMonad{pError  = Just _}  -> "."-                   PMonad{pResult = t }      -> ", giving `" ++ init l' ++ ". " ++ prettyPrintInLine t ++ "'"-          where l' = l ++ [x] ++ " "---------------------------------------------------------------- Helpers for constructing types--infixr 5 -->-infixl 6 $$---- Function type-(-->) :: PType -> PType -> PType-a --> b = liftM2 cu a b--cu :: HsType -> HsType -> HsType-cu (HsTyTuple xs) y = foldr HsTyFun y xs-cu a b = HsTyFun a b---- Type application:---   If we have a type function, use that---   Otherwise use HsTyApp, but check for stupid errors-($$) :: PType -> PType -> PType-($$) PMonad{ pFun=Just f } x = f x-($$) f x = PMonad-         { pResult = HsTyApp (pResult f) (pResult x)-         , pError  = pError f `mplus` -- ignore errors in x, the type constructor f might have a higher kind and ignore x-                      if isFunction (pResult f) then Nothing else-                            Just $ "`" ++ prettyPrintInLine (pResult f) ++ "' is not a type function."-         , pFun    = Nothing-         }-  where-    isFunction (HsTyFun _ _) = False-    isFunction (HsTyTuple _) = False-    isFunction _             = True--con, var :: String -> PType-con = return . HsTyCon . UnQual . HsIdent-var = return . HsTyVar . HsIdent--tuple :: [PType] -> PType-tuple = liftM (HsTyTuple . concatMap unpack) . sequence-    where-    unpack (HsTyTuple xs) = xs-    unpack x = [x]---- a bit of a hack-forall_ :: String -> (PType -> PType) -> PType-forall_ x f = var ("forall "++x++".") $$ f (var x)---------------------------------------------------------------- Definitions from the MTL library---- MTL types (plus MaybeT)-types :: [(String, HsType -> PType)]-types =-    [ ("Cont",     lift2 $ \r       a -> (a -->      r) -->      r)-    , ("ContT",    lift3 $ \r     m a -> (a --> m $$ r) --> m $$ r)-    , ("ErrorT",   lift3 $ \e     m a -> m $$ (con "Either" $$ e $$ a))-    , ("Identity", lift1 $ \        a -> a)-    , ("ListT",    lift2 $ \      m a -> m $$ (return list_tycon $$ a))-    , ("RWS",      lift4 $ \r w s   a -> r --> s -->      tuple [a, s, w])-    , ("RWST",     lift5 $ \r w s m a -> r --> s --> m $$ tuple [a, s, w])-    , ("Reader",   lift2 $ \r       a -> r -->            a)-    , ("ReaderT",  lift3 $ \r     m a -> r -->       m $$ a)-    , ("Writer",   lift2 $ \  w     a ->                  tuple [a,    w])-    , ("WriterT",  lift3 $ \  w   m a ->             m $$ tuple [a,    w])-    , ("State",    lift2 $ \    s   a ->       s -->      tuple [a, s   ])-    , ("StateT",   lift3 $ \    s m a ->       s --> m $$ tuple [a, s   ])-    -- very common:-    , ("MaybeT",   lift2 $ \      m a -> m $$ (con "Maybe" $$ a))-    -- from the Haskell wiki-    , ("Rand",     lift2 $ \g       a -> g -->      tuple [a, g])-    , ("RandT",    lift3 $ \g     m a -> g --> m $$ tuple [a, g])-    , ("NonDet",   lift1 $ \        a -> forall_ "b" $ \b -> (a --> b --> b) --> b --> b)-    , ("NonDetT",  lift2 $ \      m a -> forall_ "b" $ \b -> (a --> m $$ b --> m $$ b) --> m $$ b --> m $$ b)-    ]------------------------------------------------------- Parsing of types--mtlParser :: String -> Either String HsType-mtlParser input = do-    HsModule _ _ _ _ decls <- liftE $ parseModule ("type X = "++input++"\n")-    hsType <- case decls of-        (HsTypeDecl _ _ _ hsType:_) -> return hsType-        _ -> fail "No parse?"-    let result = mtlParser' hsType-    case pError result of-        Just e  -> fail e-        Nothing -> return (pResult result)-  where-    liftE (ParseOk a) = return a-    liftE (ParseFailed _src str) = fail str--mtlParser' :: HsType -> PType-mtlParser' t@(HsTyCon (UnQual (HsIdent v))) = case lookup v types of-     Just pt -> pt t-     Nothing -> return t-mtlParser' (HsTyApp a b) = mtlParser' a $$ mtlParser' b-mtlParser' t = return t---------------------------------------------------------------- Examples--ex1 :: String-ex1 = "ContT ByteString (StateT s IO) a"-ex2 :: String-ex2 = "StateT s (ContT ByteString IO) a"-ex3 :: String-ex3 = "ErrorT ByteString (WriterT String (State s)) a"
− Plugin/Undo.hs 
@@ -1,123 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}---- Copyright (c) 2006 Spencer Janssen--- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)--module Plugin.Undo where--import Plugin-import Lambdabot.Parser-import Language.Haskell.Syntax hiding (Module)-import Data.Generics-import qualified Data.Set as Set-import Control.Monad (guard)--$(plugin "Undo")--instance Module UndoModule () where-    moduleCmds   _ = ["undo", "do"]-    moduleHelp _ "undo" = "undo <expr>\nTranslate do notation to Monad operators."-    moduleHelp _ "do" = "do <expr>\nTranslate Monad operators to do notation."-    process_ _ cmd args = ios $ return $ transform f args-     where f = case cmd of-                "undo" -> undo-                "do" -> do'-                _      -> error "unknown command"--findVar :: Data a => a -> String-findVar e = head $ do-                    i <- [0 ..]-                    x <- ['a' .. 'z']-                    let xi = x : replicate i '\''-                    guard $ not $ Set.member xi s-                    return xi- where s = Set.fromList $ listify (const True :: String -> Bool) e--transform :: (String -> HsExp -> HsExp) -> String -> String-transform f = withParsed $ \e -> everywhere (mkT . f . findVar $ e) e--undo :: String -> HsExp -> HsExp-undo v (HsDo stms) = f stms- where-    f [HsQualifier e]          = e-    f (HsQualifier e     : xs) = infixed e ">>" $ f xs-    f (HsLetStmt   ds    : xs) = HsLet ds $ f xs-    f (HsGenerator s p e : xs)-        | irrefutable p = infixed e ">>=" $ HsLambda s [p] $ f xs-        | otherwise     = infixed e ">>=" $-                            HsLambda s [pvar v] $-                                HsCase (var v)-                                    [ alt p (f xs)-                                    , alt HsPWildCard $-                                        HsApp-                                            (var "fail")-                                            (HsLit $ HsString "")-                                    ]-        where alt pat x = HsAlt s pat (HsUnGuardedAlt x) []-undo v (HsListComp e stms) = f stms- where-    f []                       = HsList [e]-    f (HsQualifier g     : xs) = HsIf g (f xs) nil-    f (HsLetStmt   ds    : xs) = HsLet ds $ f xs-    f (HsGenerator s p l : xs)-        | irrefutable p = concatMap' $ HsLambda s [p] $ f xs-        | otherwise     = concatMap' $-                            HsLambda s [pvar v] $-                                HsCase (var v)-                                    [ alt p (f xs)-                                    , alt HsPWildCard nil-                                    ]-        where alt pat x = HsAlt s pat (HsUnGuardedAlt x) []-              concatMap' fun = HsApp (HsApp (var "concatMap") (HsParen fun)) l-undo _ x           = x--irrefutable :: HsPat -> Bool-irrefutable (HsPVar _)     = True-irrefutable (HsPIrrPat _)  = True-irrefutable HsPWildCard    = True-irrefutable (HsPAsPat _ p) = irrefutable p-irrefutable (HsPParen p)   = irrefutable p-irrefutable (HsPTuple ps)  = all irrefutable ps-irrefutable _              = False--infixed :: HsExp -> String -> HsExp -> HsExp-infixed l o r = HsInfixApp l (HsQVarOp $ UnQual $ HsSymbol o) r--nil :: HsExp-nil = HsVar list_tycon_name--var :: String -> HsExp-var = HsVar . UnQual . HsIdent--pvar :: String -> HsPat-pvar = HsPVar . HsIdent--do' :: String -> HsExp -> HsExp-do' _ (HsLet ds (HsDo s)) = HsDo (HsLetStmt ds : s)-do' v e@(HsInfixApp l (HsQVarOp (UnQual (HsSymbol op))) r) =-     case op of-         ">>=" ->-             case r of-                 (HsLambda loc [p] (HsDo stms)) -> HsDo (HsGenerator loc p l : stms)-                 (HsLambda loc [HsPVar v1] (HsCase (HsVar (UnQual v2))-                                            [ HsAlt _ p (HsUnGuardedAlt s) []-                                            , HsAlt _ HsPWildCard (HsUnGuardedAlt (HsApp (HsVar (UnQual (HsIdent "fail"))) _)) []-                                            ]))-                           | v1 == v2           -> case s of-                                                       HsDo stms -> HsDo (HsGenerator loc p l : stms)-                                                       _         -> HsDo [HsGenerator loc p l, HsQualifier s]-                 (HsLambda loc [p] s)           -> HsDo [HsGenerator loc p l, HsQualifier s]-                 _ -> HsDo [ HsGenerator undefined (pvar v) l-                           , HsQualifier . app r $ var v]-         ">>" ->-             case r of-                 (HsDo stms) -> HsDo (HsQualifier l : stms)-                 _           -> HsDo [HsQualifier l, HsQualifier r]-         _    -> e-do' _ x = x---- | 'app' is a smart constructor that inserts parens when the first argument--- is an infix application.-app :: HsExp -> HsExp -> HsExp-app e@(HsInfixApp {}) f = HsApp (HsParen e) f-app e                 f = HsApp e f
− Plugin/Unlambda.hs 
@@ -1,29 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}--- Copyright (c) 2006 Don Stewart - http://www.cse.unsw.edu.au/~dons--- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)------ | A plugin for the Haskell interpreter for the unlambda language------ http://www.madore.org/~david/programs/unlambda/-module Plugin.Unlambda (theModule) where--import Plugin--$(plugin "Unlambda")--instance Module UnlambdaModule () where-    moduleCmds   _     = ["unlambda"]-    moduleHelp _ _     = "unlambda <expr>. Evaluate an unlambda expression"-    process _ _ to _ s = ios80 to (unlambda s)--binary :: String-binary = "unlambda"--unlambda :: String -> IO String-unlambda src = run binary src scrub-  where scrub = unlines . take 6 . map (' ':) . lines . cleanit--cleanit :: String -> String-cleanit s | terminated `matches'` s = "Terminated\n"-          | otherwise               = s-    where terminated = regex' "waitForProc"
− Plugin/Url.hs 
@@ -1,119 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, PatternGuards #-}--- | Fetch URL page titles of HTML links.-module Plugin.Url (theModule) where--import Plugin-import Network.URI--import qualified Text.Regex as R -- legacy--$(plugin "Url")--instance Module UrlModule Bool where-    moduleHelp  _ "url-title"     = "url-title <url>. Fetch the page title."-    moduleCmds  _                 = ["url-title", "tiny-url"]-    modulePrivs _                 = ["url-on", "url-off"]-    moduleDefState _              = return True -- url on-    moduleSerialize _             = Just stdSerial--    process_    _ "url-title" txt = lift $ maybe (return ["Url not valid."])-                                      fetchTitle (containsUrl txt)-    process_    _ "tiny-url"  txt = lift $ maybe (return ["Url not valid."])-                                      fetchTiny  (containsUrl txt)-    process_    _ "url-on"    _   = writeMS True  >> return ["Url enabled"]-    process_    _ "url-off"   _   = writeMS False >> return ["Url disabled"]--    contextual  _ _ _ text        = do-      alive <- readMS-      if alive && (not $ areSubstringsOf ignoredStrings text)-        then case containsUrl text of-               Nothing  -> return []-               Just url-                 | length url > 65 -> do-                     title <- lift $ fetchTitle url-                     tiny  <- lift $ fetchTiny url-                     return $ zipWith' cat title tiny-                 | otherwise -> lift $ fetchTitle url-        else return []-      where cat x y = x ++ ", " ++ y-            zipWith' _ [] ys = ys-            zipWith' _ xs [] = xs-            zipWith' f (x:xs) (y:ys) = f x y : zipWith' f xs ys------------------------------------------------------------------------------ | Fetch the title of the specified URL.-fetchTitle :: String -> LB [String]-fetchTitle url = do-    title <- io $ runWebReq (urlPageTitle url) (proxy config)-    return $ maybe [] return title---- | base url for fetching tiny urls-tinyurl :: String-tinyurl = "http://tinyurl.com/api-create.php?url="---- | Fetch the title of the specified URL.-fetchTiny :: String -> LB [String]-fetchTiny url-    | Just uri <- parseURI (tinyurl ++ url) = do-        tiny <- io $ runWebReq (getHtmlPage uri) (proxy config)-        return $ maybe [] return $ findTiny $ foldl' cat "" tiny-    | otherwise = return $ maybe [] return $ Just url-    where cat x y = x ++ " " ++ y---- | Tries to find the start of a tinyurl-findTiny :: String -> Maybe String-findTiny text = do-  (_,kind,rest,_) <- R.matchRegexAll begreg text-  let url = takeWhile (/=' ') rest-  return $ stripSuffixes ignoredUrlSuffixes $ kind ++ url-  where-  begreg = R.mkRegexWithOpts "http://tinyurl.com/" True False---- | List of strings that, if present in a contextual message, will--- prevent the looking up of titles.  This list can be used to stop--- responses to lisppaste for example.  Another important use is to--- another lambdabot looking up a url title that contains another--- url in it (infinite loop).  Ideally, this list could be added to--- by an admin via a privileged command (TODO).-ignoredStrings :: [String]-ignoredStrings =-    ["paste",                -- Ignore lisppaste, rafb.net-     "cpp.sourcforge.net",   -- C++ paste bin-     "HaskellIrcPastePage",  -- Ignore paste page-     "title of that page",   -- Ignore others like the old me-     urlTitlePrompt]         -- Ignore others like me---- | Suffixes that should be stripped off when identifying URLs in--- contextual messages.  These strings may be punctuation in the--- current sentence vs part of a URL.  Included here is the NUL--- character as well.-ignoredUrlSuffixes :: [String]-ignoredUrlSuffixes = [".", ",", ";", ")", "\"", "\1", "\n"]---- | Searches a string for an embeddded URL and returns it.-containsUrl :: String -> Maybe String-containsUrl text = do-    (_,kind,rest,_) <- R.matchRegexAll begreg text-    let url = takeWhile (`notElem` " \n\t\v") rest-    return $ stripSuffixes ignoredUrlSuffixes $ kind ++ url-    where-      begreg = R.mkRegexWithOpts "https?://"  True False---- | Utility function to remove potential suffixes from a string.--- Note, once a suffix is found, it is stripped and returned, no other--- suffixes are searched for at that point.-stripSuffixes :: [String] -> String -> String-stripSuffixes []   str   = str-stripSuffixes (s:ss) str-    | isSuffixOf s str   = take (length str - length s) $ str-    | otherwise          = stripSuffixes ss str----- | Utility function to check of any of the Strings in the specified--- list are substrings of the String.-areSubstringsOf :: [String] -> String -> Bool-areSubstringsOf = flip (any . flip isSubstringOf)-    where-      isSubstringOf s str = any (isPrefixOf s) (tails str)-
− Plugin/Version.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}--- Copyright (c) 2005-6 Don Stewart - http://www.cse.unsw.edu.au/~dons--- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)---- | Lambdabot version information-module Plugin.Version where--import Plugin-import Paths_lambdabot (version)-import Data.Version (showVersion)--$(plugin "Version")--instance Module VersionModule () where-    moduleCmds   _ = ["version"]-    moduleHelp _ _ = "version/source. Report the version " ++-                     "and darcs repo of this bot"-    process_ _ _ _ = ios . return $ concat-                [ "lambdabot ", showVersion version, "\n"-                , "darcs get http://code.haskell.org/lambdabot" ]
− Plugin/Vixen.hs 
@@ -1,114 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses #-}---- | Talk to hot chixxors.---- (c) Mark Wotton--- Serialisation (c) 2007 Don Stewart--module Plugin.Vixen where---- import Data.Int (for code to read old state data)-import Data.Binary-import Data.Binary.Put-import Data.Binary.Get--import Control.Arrow ((***))-import System.Directory-import qualified Data.ByteString.Char8 as P--import File (findFile)-import Plugin--$(plugin "Vixen")--instance Module VixenModule (Bool, String -> IO String) where-    moduleCmds   _   = ["vixen"]-    modulePrivs  _   = ["vixen-on", "vixen-off"] -- could be noisy-    moduleHelp _ _   = "vixen <phrase>. Sergeant Curry's lonely hearts club"--    -- if vixen-chat is on, we can just respond to anything-    contextual _ _ _ txt      = do-        (alive, k) <- readMS-        if alive then ios (k txt)-                 else return []--    process_ _ "vixen-on"  _ =-        withMS $ \(_,r) k -> do k (True, r)-                                return ["What's this channel about?"]-    process_ _ "vixen-off" _ =-        withMS $ \(_,r) k -> do k (False, r)-                                return ["Bye!"]--    process_ _ _ txt = readMS >>= ios . ($ txt) . snd--    moduleDefState _ = return (False, const (return "<undefined>"))--    -- suck in our (read only) regex state from disk-    -- compile it, and stick it in the plugin state-    moduleInit _     = do-      b <- io $ doesFileExist =<< findFile "vixen"-      when b $ do-          s <- io $ do st <- decodeFile =<< findFile "vixen"-                       let compiled = map (regex *** id) st-                       return (vixen (mkResponses compiled))-          modifyMS $ \(v,_) -> (v, s)----------------------------------------------------------------------------vixen :: (String -> WTree) -> String -> IO String-vixen k key = P.unpack `fmap` randomW (k key)--randomW :: WTree -> IO P.ByteString-randomW (Leaf a)  = return a-randomW (Node ls) = randomElem ls >>= randomW--mkResponses :: RChoice -> String -> WTree-mkResponses choices them = (\((_,wtree):_) -> wtree) $-    filter (\(reg,_) -> matches' reg them) choices----------------------------------------------------------------------------- serialisation for the vixen state------ The tree of regexes and responses is written in binary form to--- State/vixen, and we suck it in on module init, then lazily regexify it all--data WTree = Leaf !P.ByteString | Node ![WTree]-             deriving Show--instance Binary WTree where-    put (Leaf s)  = putWord8 0 >> put s-    put (Node ls) = putWord8 1 >> put ls-    get = do-        tag <- getWord8-        case tag of-            0 -> liftM Leaf get-            1 -> liftM Node get--type Choice  = [(P.ByteString, WTree)]-type RChoice = [(Regex, WTree)] -- compiled choices--{- Sample of how to rescue data in the old 32-bit Binary format--newtype OldChoice = OC { unOC :: Choice }-                    deriving Show-instance Binary OldChoice where-    get = do liftM OC (getList (getPair getBS getWTree))-        where-          getList :: (Get a) -> Get [a]-          getList getA = do-            n <- liftM fromIntegral (get :: Get Int32)-            replicateM n getA--          getShort :: Get Int-          getShort = liftM fromIntegral (get :: Get Int32)--          getPair = liftM2 (,)--          getBS   = getShort >>= getByteString--          getWTree = do-            tag <- getWord8-            case tag of-              0 -> liftM Leaf getBS-              1 -> liftM Node (getList getWTree)--}
− Plugin/Where.hs 
@@ -1,65 +0,0 @@-{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeSynonymInstances #-}---- |--- Module    : Where--- Copyright : 2003 Shae Erisson------ License:     lGPL------ Slightly specialised version of Where for associating projects with their urls.--- Code almost all copied.-module Plugin.Where (theModule) where--import Plugin-import Lambdabot.Util (confirmation)-import qualified Data.ByteString.Char8 as P-import qualified Data.Map as M--$(plugin "Where")--type WhereState         = M.Map P.ByteString P.ByteString-type WhereWriter        = WhereState -> LB ()--- type Where m a          = ModuleT WhereState m a--instance Module WhereModule WhereState where--  moduleCmds _ = ["where", "url", "what", "where+" ]-  moduleHelp _ s = case s of-    "where"    -> "where <key>. Return element associated with key"-    "what"     -> "what <key>. Return element associated with key"-    "url"      -> "url <key>. Return element associated with key"--    "where+"   -> "where+ <key> <elem>. Define an association"--  moduleDefState  _ = return M.empty-  moduleSerialize _ = Just mapPackedSerial--  process_ _ cmd rest = list $ withMS $ \factFM writer ->-        case words rest of-            []         -> return "@where <key>, return element associated with key"-            (fact:dat) -> processCommand factFM writer-                                (lowerCaseString fact) cmd (unwords dat)----------------------------------------------------------------------------processCommand :: WhereState -> WhereWriter-               -> String -> String -> String -> LB String--processCommand factFM writer fact cmd dat = case cmd of-        "where"     -> return $ getWhere factFM fact-        "what"      -> return $ getWhere factFM fact -- an alias-        "url"       -> return $ getWhere factFM fact -- an alias-        "where+"    -> updateWhere True factFM writer fact dat-        _           -> return "Unknown command."--getWhere :: WhereState -> String -> String-getWhere fm fact =-    case M.lookup (P.pack fact) fm of-        Nothing -> "I know nothing about " ++ fact ++ "."-        Just x  -> P.unpack x--updateWhere :: Bool -> WhereState -> WhereWriter -> String -> String -> LB String-updateWhere _guard factFM writer fact dat = do-        writer $ M.insert (P.pack fact) (P.pack dat) factFM-        random confirmation-
+ README.md view
@@ -0,0 +1,98 @@+lambdabot ![Build Status](https://travis-ci.org/mokus0/lambdabot.png)+===============++Lambdabot is an IRC bot written over several years by those on freenode's #haskell [IRC channel](http://www.haskell.org/haskellwiki/IRC_channel). It also operates in an offline mode as a Haskell development tool, and embedded as an extension to ghci.++PREREQUISITES+-------------++You'll need GHC >= 7.4.  cabal-install is highly recommended.++External executable dependencies:++- `aspell` for the "spell" spell-checking plugin.  This is not a Haskell program, but is available in pretty much all Linux, BSD and Mac OS package managers.+- `bf` for interpreting brainfuck programs.  This is a provided by the "brainfuck" package on Hackage.+- `djinn` for the "djinn" plugin, which tries to find Haskell functions matching arbitrary types.  Available on Hackage.+- `ghc` and `mueval` for the "eval" plugin, which evaluates Haskell expressions in chat (when prefixed with "> "; e.g. `> 1 + 1`).  GHC is available from haskell.org (the Haskell Platform is recommended).  Mueval is available on Hackage.+- `hoogle` for the "hoogle" plugin, which provides a command for searching Haskell APIs.  Available from Hackage.+- `unlambda` for executing unlambda programs.  Available on Hackage.++Some of these dependencies (those with corresponding hackage libraries) will be installed by cabal, but not all of them will.  In all cases, cabal does not actually track the executables so if they have previously been installed and deleted on your system (without unregistering the matching library), you will have to manually reinstall them.++RUNNING+=======++Lambdabot can be installed system-wide or per user, but currently the lambdabot binary makes certain assumptions about what directory it is being run in & where files it needs can be found. (This is the subject of future work.)++Your best bet is currently to read the code and see what it does, and decide for yourself whether that's what you want.++OFFLINE MODE+------------++    lambdabot++CONNECTING+----------++    lambdabot -e 'rc online.rc'++SSL MODE (with stunnel)+-----------------------++append the following to your stunnel.conf:++    client = yes+    [irc]+    accept = 6667+    connect = ssl-irc-server.org:6667++and edit online.rc to use localhost as server, then restart the stunnel+server and restart lambdabot with:++    ./lambdabot -e 'rc online.rc'++SCRIPTS+-------++    The scripts directory contains some shell scripts for Vim editor support+    They are self-explanatory++CONFIGURING+===========++Lambdabot uses an extensible configuration system which allows plugins to define their own configuration variables.  The lambdabot core system defines several, listed in the module `Lambdabot.Config.Core`.  The default `lambdabot` executable provides a command-line interface to set some of the most common ones, but currently the only way to set others is to define your own executable (which you must currently do anyway to change the default set of modules).++When doing so, configuration is passed in to the `lambdabotMain` function as a list of bindings.  Configuration variables are bound using the `:=>` operator (actually the data constructor of the `DSum` type), for example:++    ghcBinary :=> "ghc-7.4.2"++So a typical custom lambdabot executable might look something like:++    module MyBot where+    +    import Lambdabot.Main+    {- import your plugins here -}+    +    main = lambdabotMain myPlugins +        [ configKey  :=> value+        , anotherKey :=> anotherValue+        ]++BUGS+====++Bug reports, patches, new modules etc., open issues on GitHub or contact:++        James Cook <mokus@deepbondi.net>+        aka mokus on #haskell++REPOSITORY+==========++    git clone https://github.com/mokus0/lambdabot++CONTRIBUTING+============++Send pull requests to mokus0 on github. Add yourself to the AUTHORS+file if you haven't already.
− Shared.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE Rank2Types, TypeOperators #-}---- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons--- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)---- | Shared types between static and dynamic code. This is the only--- module that is linked both statically and dynamically. (And doing so--- breaks us from running the whole of the bot in ghci -- so sue me).--module Shared (Module(..), Symbol, DynLoad(..)) where--type Symbol = String--newtype Module = Module String {- unique module identifier -}---- | Operations provided by the dynamic linker linked into the static--- core. A DynLoad value is passed from there to the dynamic code, for--- use by DynamicModule------ Possibly want to treat this as an existential, ala MODULE------ could add to DynLoad, Typeable a => ...----data DynLoad = DynLoad {-        dynload    :: forall a. FilePath -> Symbol -> IO (Module,a),-        unload     :: Module   -> IO ()-    }-
State/L.hs view
@@ -1,24 +1,44 @@-{-# LANGUAGE NoMonomorphismRestriction, StandaloneDeriving, UndecidableInstances #-}+{-# LANGUAGE Safe #-}++{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LiberalTypeSynonyms #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PolymorphicComponents #-}+{-# LANGUAGE PostfixOperators #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnicodeSyntax #-} module L where-import Prelude hiding ((.),(++),flip) import Control.Applicative import Control.Arrow-import Control.Arrow.Operations import Control.Monad import Control.Monad.Cont-import Control.Monad.Error-import Control.Monad.Fix import Control.Monad.Identity import Control.Monad.Instances-import Control.Monad.Logic-import Control.Monad.RWS import Control.Monad.Reader-import Control.Monad.ST (ST, runST, fixST)+import Control.Monad.ST.Safe import Control.Monad.State import Control.Monad.Writer-import Control.Parallel-import Control.Parallel.Strategies-import Data.Array import Data.Bits import Data.Bool import Data.Char@@ -26,20 +46,11 @@ import Data.Dynamic import Data.Either import Data.Eq-import Data.Fixed-import Data.Function hiding ((.),flip)-import Data.Generics hiding (GT)-import Data.Graph+import Data.Function import Data.Int-import Data.Ix-import Data.List hiding ((++),map)+import Data.List import Data.Maybe import Data.Monoid-import Data.Number.BigFloat-import Data.Number.CReal-import Data.Number.Dif-import Data.Number.Interval-import Data.Number.Symbolic import Data.Ord import Data.Ratio import Data.STRef@@ -48,115 +59,20 @@ import Data.Typeable import Data.Word import Numeric-import ShowQ import System.Random+import Lambdabot.Plugin.Eval.Trusted import Text.PrettyPrint.HughesPJ hiding (empty) import Text.Printf-import Text.Regex.Posix-import qualified Control.Arrow.Transformer as AT-import qualified Control.Arrow.Transformer.All as AT import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC import qualified Data.Foldable-import qualified Data.Generics import qualified Data.IntMap as IM import qualified Data.IntSet as IS import qualified Data.Map as M-import qualified Data.Sequence as Seq+import qualified Data.Sequence import qualified Data.Set as S import qualified Data.Traversable-import qualified Data.MemoCombinators as Memo-import ShowIO -import SimpleReflect hiding (var)-import Math.OEIS-import Control.Monad.Random--import Data.VectorSpace hiding (Sum, getSum)-import Data.NumInstances-import Data.LinearMap--import qualified Test.IOSpec as IOSpec--import Data.Fixed--(.) :: (Functor f) => (a -> b) -> f a -> f b-(.) = fmap-infixr 9 .--flip :: Functor f => f (a -> b) -> a -> f b-flip f x = fmap ($ x) f--(++) :: (Monoid m) => m -> m -> m-(++) = mappend-infixr 5 ++--asTypeIn :: a -> (a -> b) -> a-a `asTypeIn` f = a where _ = f a-infixl 0 `asTypeIn`--f `asAppliedTo` x = f `asTypeIn` \f -> f x-infixl 0 `asAppliedTo`--describeSequence = fmap description . lookupSequence--newtype Mu f = In (f (Mu f))-out (In x) = x-deriving instance Show (f (Mu f)) => Show (Mu f)--newtype Rec a = InR { outR :: Rec a -> a }--data Bin a = Tip | Branch a (Bin a) (Bin a)-  deriving (Eq, Ord, Show, Read)--- Fun Stuff--cake = ["One 18.25 ounce package chocolate cake mix.",-        "One can prepared coconut pecan frosting.",-        "Three slash four cup vegetable oil.",-        "Four large eggs.",-        "One cup semi-sweet chocolate chips.",-        "Three slash four cups butter or margarine.",-        "One and two third cups granulated sugar.",-        "Two cups all-purpose flour.",-        "Don't forget garnishes such as:",-        "Fish shaped crackers.",-        "Fish shaped candies.",-        "Fish shaped solid waste.",-        "Fish shaped dirt.",-        "Fish shaped ethylbenzene.",-        "Pull and peel licorice.",-        "Fish shaped organic compounds and sediment shaped sediment.",-        "Candy coated peanut butter pieces. Shaped like fish.",-        "One cup lemon juice.",-        "Alpha resins.",-        "Unsaturated polyester resin.",-        "Fiberglass surface resins.",-        "And volatile malted milk impoundments.",-        "Nine large egg yolks.",-        "Twelve medium geosynthetic membranes.",-        "One cup granulated sugar.",-        "An entry called 'how to kill someone with your bare hands.'",-        "Two cups rhubarb, sliced.",-        "Two slash three cups granulated rhubarb.",-        "One tablespoon all-purpose rhubarb.",-        "One teaspoon grated orange rhubarb.",-        "Three tablespoons rhubarb, on fire.",-        "One large rhubarb.",-        "One cross borehole electro-magnetic imaging rhubarb.",-        "Two tablespoons rhubarb juice.",-        "Adjustable aluminum head positioner.",-        "Slaughter electric needle injector.",-        "Cordless electric needle injector.",-        "Injector needle driver.",-        "Injector needle gun.",-        "Cranial caps.",-        "And it contains proven preservatives, deep penetration agents, and gas and odor control chemicals.",-        "That will deodorize and preserve putrid tissue."]- {-# LINE 1 "<local>" #-}-(****) = (\f n v -> (iterate f v) !! n)-toChurch = ((appEndo . Data.Foldable.foldMap Endo) .) . replicate-fromChuch f = f (+1) 0-evalCont :: Cont o o -> o; evalCont = (`runCont` id)
State/Pristine.hs view
@@ -1,24 +1,44 @@-{-# LANGUAGE NoMonomorphismRestriction, StandaloneDeriving, UndecidableInstances #-}+{-# LANGUAGE Safe #-}++{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LiberalTypeSynonyms #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PolymorphicComponents #-}+{-# LANGUAGE PostfixOperators #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnicodeSyntax #-} module L where-import Prelude hiding ((.),(++),flip) import Control.Applicative import Control.Arrow-import Control.Arrow.Operations import Control.Monad import Control.Monad.Cont-import Control.Monad.Error-import Control.Monad.Fix import Control.Monad.Identity import Control.Monad.Instances-import Control.Monad.Logic-import Control.Monad.RWS import Control.Monad.Reader-import Control.Monad.ST (ST, runST, fixST)+import Control.Monad.ST.Safe import Control.Monad.State import Control.Monad.Writer-import Control.Parallel-import Control.Parallel.Strategies-import Data.Array import Data.Bits import Data.Bool import Data.Char@@ -26,20 +46,11 @@ import Data.Dynamic import Data.Either import Data.Eq-import Data.Fixed-import Data.Function hiding ((.),flip)-import Data.Generics hiding (GT)-import Data.Graph+import Data.Function import Data.Int-import Data.Ix-import Data.List hiding ((++),map)+import Data.List import Data.Maybe import Data.Monoid-import Data.Number.BigFloat-import Data.Number.CReal-import Data.Number.Dif-import Data.Number.Interval-import Data.Number.Symbolic import Data.Ord import Data.Ratio import Data.STRef@@ -48,111 +59,20 @@ import Data.Typeable import Data.Word import Numeric-import ShowQ import System.Random+import Lambdabot.Plugin.Eval.Trusted import Text.PrettyPrint.HughesPJ hiding (empty) import Text.Printf-import Text.Regex.Posix-import qualified Control.Arrow.Transformer as AT-import qualified Control.Arrow.Transformer.All as AT import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSLC import qualified Data.Foldable-import qualified Data.Generics import qualified Data.IntMap as IM import qualified Data.IntSet as IS import qualified Data.Map as M-import qualified Data.Sequence as Seq+import qualified Data.Sequence import qualified Data.Set as S import qualified Data.Traversable-import qualified Data.MemoCombinators as Memo-import ShowIO--import SimpleReflect hiding (var)-import Math.OEIS-import Control.Monad.Random--import Data.VectorSpace hiding (Sum, getSum)-import Data.NumInstances-import Data.LinearMap--import qualified Test.IOSpec as IOSpec--import Data.Fixed--(.) :: (Functor f) => (a -> b) -> f a -> f b-(.) = fmap-infixr 9 .--flip :: Functor f => f (a -> b) -> a -> f b-flip f x = fmap ($ x) f--(++) :: (Monoid m) => m -> m -> m-(++) = mappend-infixr 5 ++--asTypeIn :: a -> (a -> b) -> a-a `asTypeIn` f = a where _ = f a-infixl 0 `asTypeIn`--f `asAppliedTo` x = f `asTypeIn` \f -> f x-infixl 0 `asAppliedTo`--describeSequence = fmap description . lookupSequence--newtype Mu f = In (f (Mu f))-out (In x) = x-deriving instance Show (f (Mu f)) => Show (Mu f)--newtype Rec a = InR { outR :: Rec a -> a }--data Bin a = Tip | Branch a (Bin a) (Bin a)-  deriving (Eq, Ord, Show, Read)--- Fun Stuff--cake = ["One 18.25 ounce package chocolate cake mix.",-        "One can prepared coconut pecan frosting.",-        "Three slash four cup vegetable oil.",-        "Four large eggs.",-        "One cup semi-sweet chocolate chips.",-        "Three slash four cups butter or margarine.",-        "One and two third cups granulated sugar.",-        "Two cups all-purpose flour.",-        "Don't forget garnishes such as:",-        "Fish shaped crackers.",-        "Fish shaped candies.",-        "Fish shaped solid waste.",-        "Fish shaped dirt.",-        "Fish shaped ethylbenzene.",-        "Pull and peel licorice.",-        "Fish shaped organic compounds and sediment shaped sediment.",-        "Candy coated peanut butter pieces. Shaped like fish.",-        "One cup lemon juice.",-        "Alpha resins.",-        "Unsaturated polyester resin.",-        "Fiberglass surface resins.",-        "And volatile malted milk impoundments.",-        "Nine large egg yolks.",-        "Twelve medium geosynthetic membranes.",-        "One cup granulated sugar.",-        "An entry called 'how to kill someone with your bare hands.'",-        "Two cups rhubarb, sliced.",-        "Two slash three cups granulated rhubarb.",-        "One tablespoon all-purpose rhubarb.",-        "One teaspoon grated orange rhubarb.",-        "Three tablespoons rhubarb, on fire.",-        "One large rhubarb.",-        "One cross borehole electro-magnetic imaging rhubarb.",-        "Two tablespoons rhubarb juice.",-        "Adjustable aluminum head positioner.",-        "Slaughter electric needle injector.",-        "Cordless electric needle injector.",-        "Injector needle driver.",-        "Injector needle gun.",-        "Cranial caps.",-        "And it contains proven preservatives, deep penetration agents, and gas and odor control chemicals.",-        "That will deodorize and preserve putrid tissue."]  {-# LINE 1 "<local>" #-}
− State/fact

binary file changed (930 → absent bytes)

− State/fresh 
@@ -1,1 +0,0 @@-94
− State/imports.h 
@@ -1,79 +0,0 @@-import qualified Prelude as P-import Prelude hiding (mapM, sequence, mapM_, sequence_, (.), (++), map)-import Numeric-import System.Random-import Data.Array-import Data.Bits-import Data.Bool-import Data.Char-import Data.Complex-import Data.Dynamic-import Data.Either-import Data.Eq-import Data.Fixed-import qualified Data.Foldable-import Data.Function hiding ((.))-import Data.Ord-import qualified Data.Generics-import Data.Generics hiding (GT)-import Data.Graph-import Data.Int-import Data.Ix-import Data.List hiding ((++),map)-import Data.Maybe-import Data.Monoid-import Data.Ratio-import qualified Data.Sequence-import Data.Tree-import Data.Tuple-import qualified Data.Traversable-import Data.Typeable-import Data.Word-import Data.STRef-import qualified Data.Map as M-import qualified Data.Set as S-import qualified Data.IntSet as IS-import qualified Data.IntMap as IM-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BSC-import qualified Data.ByteString.Lazy as BSL-import qualified Data.ByteString.Lazy.Char8 as BSLC-import Data.Number.Symbolic-import Data.Number.Dif-import Data.Number.CReal-import Data.Number.Fixed-import Data.Number.Interval-import Data.Number.BigFloat-import Control.Monad-import Control.Monad.Cont-import Control.Monad.Identity-import Control.Monad.State-import Control.Monad.State-import Control.Monad.ST (ST, runST, fixST)-import Control.Monad.Reader-import Control.Monad.Fix-import Control.Monad.Writer-import Control.Monad.RWS-import Control.Monad.Error-import Control.Monad.Instances-import Control.Monad.Logic-import Control.Arrow hiding (pure)-import qualified Control.Arrow.Transformer as AT-import qualified Control.Arrow.Transformer.All as AT-import Control.Arrow.Operations-import Control.Applicative-import Control.Parallel-import Control.Parallel.Strategies-import Text.Printf-import Text.PrettyPrint.HughesPJ hiding (empty)-import Test.QuickCheck-import ShowQ--import SimpleReflect hiding (var)-import Math.OEIS--import Data.VectorSpace-import Data.NumInstances-import Data.LinearMap--import Data.Fixed
− State/karma 
@@ -1,3046 +0,0 @@-(":(",-1)-(":(>",-1)-(":)",1)-(":-------",-1)-(":>",-2)-("\"Match\226\144\164WHERE:/\\<",-1)-(")\226\144\164WHERE:/\\<",-1)-("--:--",-3)-("--21:59:59",-1)-("-9>\226\144\164WHERE:/\\<",-1)-(".perl\226\144\164WHERE:/\\<",-1)-("05:11:43",-1)-("05:12:24",-1)-("0\226\144\164WHERE:/\\<",-2)-("1..10\226\144\164WHERE:/\\<",-1)-("10\226\144\164WHERE:/\\<",-1)-("18:07:07",-1)-("2\226\144\164WHERE:/\\<",-2)-("42\226\144\164WHERE:/\\<",-2)-("5;\226\144\164WHERE:/\\<",-1)-("?(,);\226\144\164WHERE:/\\<",-1)-("IPC::Run",1)-("JSON::Tiny",1)-("Rakudo\226\144\164WHERE:/\\<",-1)-("WORLD!\";\226\144\164WHERE:/\\<",-1)-("[+];\226\144\164WHERE:/\\<",-1)-("[1,2,3,4,5]\226\144\164WHERE:/\\<",-1)-("c[${i:h}]",1)-("cls\226\144\164WHERE:/\\<",-1)-("c\226\144\164WHERE:/\\<",-1)-("",0)-("\ESC[32m",-1)-("\ESC[32m$x\ESC[31m",1)-("\ESC[32m$x\ESC[31m++",1)-("!!!-----",-1)-("!c",9)-("!coffee",1)-("!LaraX",1)-("!test",1)-("\"",-68)-("\"\"",16)-("\"(\"",2)-("\"+",3)-("\"++).(",1)-("\"--",-1)-("\"-----------------|---------",-1)-("\"-rw-r--r",-1)-("\"...\"",1)-("\"/Developer/usr/bin/g",1)-("\"0.\"",1)-("\"<",-1)-("\"<!",-3)-("\"<--",-1)-("\"blah5\"",2)-("\"bonnie",1)-("\"broiling\"-",-1)-("\"C",55)-("\"chelo",1)-("\"code}\\n",-1)-("\"crw-r---",-1)-("\"Dev-C",1)-("\"emacs",2)-("\"g",4)-("\"hackages\"",1)-("\"Infec",-1)-("\"kmc",1)-("\"lambdabot",1)-("\"MSVC",1)-("\"vim",1)-("\"wait!",-1)-("\"weed",1)-("\"\\n",-1)-("\"\\n\\tg",1)-("\"]\"",1)-("#",1)-("##c",109)-("##freebsd+++",1)-("##iso-c",1)-("##java",-1)-("#%{#$%{#$%}#${{}[454]]+",1)-("#bookz",1)-("#c",36)-("#c,#c#,#c",1)-("#cafe",1)-("#catalyst",1)-("#django",-1)-("#gentoo-uy",3)-("#haskell",0)-("#haskell-c",1)-("#perl6",1)-("#scrapy",-1)-("#vim",1)-("&",-2)-("'",-11)-("''",-1)-("'-rw-----",-1)-("'<",-1)-("'c",1)-("'F-",-1)-("'pmichaud",1)-("'s/",-1)-("'s/^>//||!/\\S/||s/^/",-1)-("(",192)-("(\"0.\"",1)-("(\"ivanm",1)-("(\"nerdshark",1)-("('",-1)-("((",16)-("((jnthn)",1)-("((jnthn))",2)-("()",0)-("(*q",1)-("(+",1)-("(+)",1)-("(-",-2)-("(-rw-r--r",-1)-("(..)",-1)-("(/dev/u?random)",1)-("(1,2,3)>>",1)-("(<",-3)-("(<-",-1)-("(alester",1)-("(azawawi",1)-("(bacek",1)-("(c",31)-("(C)",1)-("(c/c",2)-("(chromatic",1)-("(Day.mapping.invert)",1)-("(g++)",1)-("(git-svn)",0)-("(has-accessor)",1)-("(hi)(hihi)",1)-("(jnthn",1)-("(jnthn)",10)-("(jnthn))",1)-("(mberends)",1)-("(moritz",1)-("(moritz_",1)-("(new)",-1)-("(people-to-lazy-to-read-back-30-lines-and-I-mean-you-bos)",-1)-("(perl6-projects)",1)-("(pmichaud)",2)-("(r->)monad",1)-("(Seoul.pm)",1)-("(skills_c++)",1)-("(springer-verlag)",-2)-("(squerl.org)",1)-("(TimToady",1)-("(touchpad)-",-1)-("(twice-as-fast)",1)-("(use.perl.org)",0)-(")",4)-(").",1)-("*",-2)-("*)\"+l*8+\"nprint_endline\"+l*15+\"\\\"",-1)-("**",3)-("*a",1)-("*b",1)-("*C",2)-("*C/C",1)-("*d++=*s",1)-("*foo",1)-("*MSVC",1)-("*notepad",1)-("*o",1)-("*p",1)-("*ptr",2)-("+",203)-("++",9)-("++\"/\"",1)-("++$x",1)-("++).(",1)-("+++",6)-("++++",5)-("+++++",2)-("+++++++",1)-("++++++++++",1)-("++++++++++++++++++++",1)-("++++++++++++++++++++++++++++++++++",1)-("++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++",1)-("+++++[>+++++<-]>[>++<-]>",1)-("++++----------[<<-++++----+...]++++",1)-("++/",-1)-("++Any",-1)-("++d",1)-("++diakopter",-2)-("++\\/o__o\\/",2)-("+when",1)-(",",-1)-(",<",-1)-(",c",1)-("-",-720)-("--",-79)-("--+--",-1)-("---",-237)-("---(((---(((-------",-1)-("---()-",-1)-("----",-18)-("-----",-15)-("------",-7)-("-------",-15)-("--------",-12)-("---------",-20)-("----------",-16)-("-----------",-7)-("------------",-6)-("-------------",-5)-("--------------",-4)-("----------------",-9)-("-----------------",-8)-("------------------",-4)-("-------------------",-3)-("--------------------",-6)-("---------------------",-4)-("----------------------",-4)-("-----------------------",-3)-("------------------------",-5)-("-------------------------",-6)-("--------------------------",-2)-("---------------------------",-4)-("----------------------------",-1)-("-----------------------------",-10)-("-------------------------------",-3)-("--------------------------------",-1)-("----------------------------------",-3)-("------------------------------------",-4)-("--------------------------------------",-1)-("---------------------------------------",-1)-("-------------------------------------------",-3)-("--------------------------------------------",-8)-("---------------------------------------------",-1)-("------------------------------------------------",-1)-("--------------------------------------------------",-1)-("---------------------------------------------------",-1)-("----------------------------------------------------",-1)-("----------------------------------------------------------",-1)-("------------------------------------------------------------",-12)-("---------------------------------------------------------------",-1)-("--------------------------------------------------------------------",-1)-("---------------------------------------------------------------------",-2)-("----------------------------------------------------------------------",-9)-("-------------------------------------------------------------------------",-1)-("--------------------------------------------------------------------------",-1)-("-----------------------------------------------------------------------------",-7)-("------------------------------------------------------------------------------",-1)-("------------------------------------------------------------------------------------",-2)-("---------------------------------------------------------------------------------------------------------------------------------",-1)-("------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------",-1)-("-----------memory--------",-1)-("--------8<------",-1)-("-----io--",-1)-("----cpu--",-1)-("----total-cpu-usage--",-1)-("---...-",-1)-("---///-",-1)-("--->[freebsd]--",-1)-("---paging",-1)-("---swap",-1)-("---system",-1)-("---until-",-1)-("---~----~---",-1)-("--.",-5)-("--.--//=++.++||++.++//=--.",-1)-("--.--//=++.++||++.++\\\\=--.",-1)-("--.--==++.",1)-("--.--==++.++|++.++!=--.",-2)-("--..",-2)-("--..-",-2)-("--=|=",-1)-("--><",-1)-("--Any",1)-("--but",-1)-("--diakopter",1)-("--enable-languages=c,objc,c++,obj-c",1)-("--end",-2)-("--INSERT",-1)-("--More",-4)-("--o",-1)-("--really",-1)-("--rwx----",-1)-("--sigh",-1)-("--TEXTAREA",-1)-("--VISUAL",-1)-("--with-gcc=g",1)-("--worry",-1)-("-.",-1)-("-.--",-1)-("-0L--",-1)-("-<>",-1)-("->--------[f]-",-1)-("->--------[g]-",-1)-("->--[f]-------",-1)-("->--[g]-------",-1)-("-i",-1)-("-lstd",1)-("-lstdc",12)-("-m",-1)-("-r------",-1)-("-r--r--r",-17)-("-r-sr-x-",-2)-("-rw-----",-28)-("-rw-r---",-4)-("-rw-r--r",-84)-("-rw-rw--",-8)-("-rw-rw-r",-8)-("-rwx----",-2)-("-rwxrw-r",-1)-("-system",-1)-("-Weff-c",2)-("-Weffc",4)-("-_",-2)-("-_--",-1)-(".",-5)-("..",-1)-("./Debug/bin/clang",1)-("./Foreign/C/Types.hs",-1)-(".ai",1)-(".ast",1)-(".c",1)-(".map",1)-(".TheInternets",1)-("/---",-1)-("//<",-2)-("//<!",-2)-("//\\",-1)-("/<!",-1)-("/b/",-1)-("/c",1)-("/me",1)-("/o",-1)-("/usr/bin/g",5)-("/usr/lib/libstdc",1)-("/usr/local/bin/g",2)-("/\\<",-16)-("/~\\_/",-1)-("0",0)-("0)",-1)-("1",0)-("1-",-1)-("1/",1)-("1000",1)-("1000+",1)-("160",2)-("167772-",-1)-("18",-1)-("1Password",1)-("2.m",1)-("20%",-2)-("2012",1)-("2359",1)-("24",1)-("279",1)-("2pac",1)-("3",-1)-("3)",1)-("3)>>",4)-("3)>>>>>>>>>>>>>>>>>>>>>>>>>>",1)-("3)\194\187",1)-("3)\194\187.",1)-("30$-",-1)-("30+++",1)-("3g",-1)-("4",1)-("4)>>",2)-("40->20--------",-1)-("420chan",-2)-("4chan",-2)-("5",1)-("5+",1)-("50%---",-1)-("6",1)-("6)",3)-("6.4",-1)-("64bit",1)-("70",1)-("70%-----",-1)-(";)",-1)-(";D",1)-("<",-3875)-("<!",-32)-("<!-",-1)-("<#",-1)-("<-",-534)-("<--",-78)-("<---",-17)-("<----",-9)-("<-----",-3)-("<------",-3)-("<----------",-1)-("<-----------",-1)-("<------------",-1)-("<-------------",-1)-("<-----------------------------",-1)-("<-------------------------------------------",-1)-("<--f",-1)-("<.>+++++++++++[<++++++++>-]<-.--------.+",2)-("<<",-5)-("<<-",-12)-("<<--",-1)-("<<---",-1)-("<<----",-2)-("<<<",-1)-("<<<-",-4)-("<<<<-------",-1)-("<<<<==--",-1)-("<=",-1)-("<=-",-1)-("<=---",-1)-("<?>",1)-("<C",1)-("<name>",0)-("===-",-4)-("======|>--",-1)-("=_+",1)-("=_+++++",1)-(">",-3)-(">-",-1)-(">----",-1)-(">--o",-1)-(">f+++++",1)-("@pl",2)-("a",17)-("a)",-2)-("A+",1)-("A++",3)-("A+++",3)-("A++++",1)-("A+++++",1)-("A++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++",1)-("a-",-1)-("AAC",2)-("aalib",1)-("aavogt",6)-("ab5tract",1)-("abajo",-1)-("abbe",1)-("abbreviations",-1)-("absolut",1)-("abstraction",1)-("abusing-grad-borrowing-privileges",1)-("acabar",1)-("access)",-1)-("ack",2)-("ack.pl",1)-("actors",1)-("actually",-1)-("Ada",1)-("adamk",1)-("Adams)",1)-("adamvo",1)-("adaptors",-1)-("add",-1)-("added",-1)-("addition",1)-("adiabatic",1)-("adium",-1)-("adu",2)-("aff",1)-("again-",-1)-("age(br1)",1)-("agent",1)-("agentbleubleu",2)-("aggregate",1)-("ago",-1)-("ago!\"",-1)-("agustin",1)-("ah\195\173",1)-("ajavid",1)-("ajax",-1)-("alester",2)-("alexeevg",1)-("alexlea",-1)-("alex___",1)-("align-regexp",1)-("Alii",-2)-("AliiCat",1)-("AliiCat+",2)-("allan_holdsworth",1)-("allison",4)-("almost\"",1)-("along",-1)-("alpounet",1)-("altmattr",1)-("amazon",-1)-("amd64",1)-("amendola",1)-("amounts",-1)-("amstan",1)-("anagramas",-1)-("analogies",1)-("analworm",1)-("analysis",-2)-("anarchy)",1)-("AndrewBC",1)-("AndroidIRC",1)-("andun",1)-("andy",-7)-("andy_gilmore",1)-("angel_tears",1)-("anibal",7)-("anibal_",1)-("animaniacs-",-1)-("anime",1)-("anonymous",1)-("answer-",-1)-("answers",1)-("antel",1)-("anteldata",-11)-("antelmierda",-1)-("anti-C",5)-("antiguos",-1)-("anton",2)-("any",0)-("anything",-1)-("anything-c",1)-("apart",-1)-("apfelmus",1)-("APL",1)-("Apocalisp",2)-("apple",-3)-("Apple-MFS",1)-("AppleCare",1)-("Applicative",1)-("aqua",-1)-("araujo",2)-("arch",0)-("ARD",1)-("are-",-1)-("argentina",0)-("arglist",-1)-("argument",-1)-("ARIAN",4)-("aristid",2)-("arity)",1)-("arjanb",1)-("arnold",1)-("arnsholt",1)-("artem",3)-("artem.pilas",1)-("arthur",-1)-("artigas",1)-("artzoyd",1)-("ascii",2)-("asdasd",1)-("ash",1)-("asm/C",1)-("assertions)",-1)-("assholes",1)-("assignment",-1)-("assurance",1)-("AST",1)-("astoriakidd@something.com<-",-1)-("astrolabe",1)-("AT&T",-1)-("ATH+",1)-("atkins",1)-("ATL/C",1)-("atomicallyModifyIORef",1)-("ats/c/c",1)-("atwood",0)-("Audrey",2)-("audreyt",19)-("augustss",4)-("autarch",50)-("automobiles",1)-("automysqlbackup",1)-("autounfudge",1)-("Auzon",8)-("avar",1)-("avena",1)-("avr-g",2)-("awesome",3)-("awesomegifs.com",-1)-("awhile",-1)-("axionix",1)-("Axman6",10)-("azawawi",149)-("azn",2)-("B",5)-("b)",1)-("B---------",-1)-("b-04",9)-("b0o-yeah",1)-("baba",1)-("bacek",62)-("bacek_",1)-("backlog",1)-("backticks)",1)-("backtrace)",1)-("bacon",1)-("bad",1)-("badass",1)-("baest",3)-("balancer<-",-1)-("bang-patterns",1)-("Banshee",1)-("barefoot",1)-("Barnerd",1)-("bash",1)-("basic",1)-("batman",1)-("Baughn",6)-("bayes",1)-("BBEdit",-1)-("be",-1)-("be1",0)-("beauty",1)-("Beelsebob",-2)-("beer",13)-("beer++",1)-("behaviour)",1)-("belen",1)-("benalene",2)-("BendersGame",1)-("benmachine",8)-("ben_m",1)-("Berends)",1)-("Berengal",4)-("bernardo",2)-("berndardo",1)-("bernhard",10)-("Berzerker",1)-("better",-2)-("betterworld",1)-("BHSPitMonkey",0)-("binary",-1)-("binary-strict",-3)-("bind9",1)-("Bingham)",1)-("bip",-2)-("bisect)",1)-("bizarreness",1)-("bkeeler",5)-("Blackbook",-1)-("blackdog",2)-("blanca",1)-("ble",1)-("bless",-2)-("Blitz",1)-("Blixtor",3)-("blocks",1)-("bloonix",1)-("blow",1)-("blub",1)-("BMeph",1)-("bnijk",-5)-("boegel.",1)-("bogons",-1)-("bolingbroke)",1)-("bong\195\179s",1)-("bonie",1)-("bonnie",34)-("bonsaikitten",-3)-("BONUS",7)-("boolify",1)-("bored",-1)-("bos",9)-("Botje",3)-("bouncer",1)-("bpetering",5)-("br",-1)-("br1",159)-("br1_age",1)-("brainfuck",1)-("branching)",1)-("Branes",1)-("break19",1)-("bremner",1)-("brent+",1)-("brevity",1)-("brimstone",-1)-("Broadwell)",2)-("brou",-1)-("browniePoints",1)-("brucelee",1)-("bruno",1)-("brunox",1)-("bsd",3)-("bsd.xen-",-1)-("btrfs",1)-("btw",-1)-("bubulein",1)-("BUILD)",1)-("bullets-",-1)-("bump",0)-("Burke)",1)-("busy",1)-("BUT",-2)-("but-",-1)-("but--erm",-1)-("BUTT",2)-("butt-",-1)-("Butta",3)-("buttbot",1)-("buttbot2",5)-("buttbott",0)-("Buttcidicbunny",-1)-("butter<",-1)-("buttobt",0)-("button",-1)-("buttpad",1)-("buu",2)-("buubot",3)-("buy",-1)-("byorgey",23)-("byorgrey",0)-("bytestring",1)-("bz@",1)-("bzr",1)-("b_jonas",0)-("B|-----------------2--3--2------------2--3--2----------",-1)-("C",3)-("C#",-1)-("C#/C",2)-("C+",4)-("c++",0)-("C++++",2)-("C++++++",1)-("c,c",2)-("C--",4)-("C--++--",1)-("C--->C",-1)-("C-/C",-1)-("C-to-C",1)-("C.",3)-("c/",12)-("C/C",485)-("C/C++/Objective-C/Objective-C",1)-("c/obj-c/c",1)-("c/obj-c/c++/obj-c",1)-("C99",-1)-("c99/c",1)-("cabal",4)-("cabal-1.8",1)-("cabal-install",3)-("cabling",1)-("caca",1)-("cache",1)-("cacti",1)-("cadillac_",1)-("cads",1)-("cafe",1)-("caf\195\169",1)-("Cagada",2)-("cairo",1)-("calamaro",-1)-("calarval",2)-("calcomania",1)-("Cale",42)-("caleskell",0)-("Caleskell+",1)-("Cale_",1)-("callcc",1)-("calor",-1)-("camargo",1)-("canada",1)-("candidate_count",1)-("candy",1)-("canteras",1)-("captain_beefheart",1)-("captain_beyond",1)-("care",-1)-("carli",0)-("carlin",85)-("carlin+",1)-("carlin++",2)-("carlos",-1)-("carlos_oficina",1)-("carnaval",-1)-("carped",1)-("carrasco",-1)-("carrito",-1)-("case",-2)-("case)",-1)-("casmu",-1)-("cat",1)-("Catalyst",1)-("catamorphisms",1)-("categoryTheory",3)-("catpants",37)-("cats",1)-("cdavaz",1)-("cdsmith",2)-("centrinia",-1)-("centrinia-is-evil",1)-("CERTIFICATE---",-1)-("chameleon",4)-("chameloon",0)-("champagne",1)-("changes_in_ghc",-1)-("chanserv",-11)-("chaos_theory",1)-("chatroulette",1)-("chavez",0)-("checos",1)-("cheeser",3)-("cheezey",-117)-("chef/puppet",1)-("chelo",2)-("Cheshire",1)-("chessguy",1)-("chia",1)-("ChilliX",1)-("chizitos",1)-("chmeee",1)-("chowder",1)-("chris",-1)-("chris2",1)-("chrisdolan",1)-("chrisdone",2)-("chromatic",32)-("chrome",3)-("chuck_moore",1)-("chuelmo",1)-("churrasco",1)-("ch\195\169vere",0)-("cimplemente",1)-("circles",1)-("circumfix",1)-("cisco",-1)-("cizra",2)-("cjfields",3)-("cjs",1)-("clang",29)-("class=\"code\"><!",-1)-("ClaudiusMaximus",1)-("Clavijo",1)-("click....carpal",1)-("climategate",1)-("clinger",4)-("clinton",1)-("clipboard",-1)-("CLORO",-1)-("close",1)-("closure",-1)-("Cloud",1)-("cls_bsd",1)-("cmake",-2)-("cmake/vim/g",1)-("Cmd",-2)-("cnf",3)-("Coates",1)-("Cocoa/ObjC",1)-("code",1)-("codensity",1)-("code_reuse",1)-("coffee",3)-("Coke",9)-("coldfusion>php>c",1)-("Coleda)",1)-("Colemak",-1)-("Coleoid",1)-("colloguy.karma",1)-("colloquy",-1)-("colomon",175)-("colomon_",1)-("colonia",-1)-("colorline",-1)-("colors",-1)-("comb",1)-("combinators)",1)-("command)",1)-("commandline",-1)-("commands",1)-("comment",1)-("commitbit",1)-("committers",1)-("community",2)-("compare",1)-("compensate)",-1)-("compile",1)-("compilers",1)-("complete",1)-("component",-1)-("computers",0)-("conal",8)-("concepts.</C",1)-("concer",-1)-("concurrenthaskell",1)-("condorigo",1)-("condorito",1)-("conexion",-1)-("confluence",1)-("conor",2)-("consensus",1)-("consistency",2)-("consistently-buggy",1)-("contextuals",1)-("convergence",1)-("cool",0)-("copumpkin",10)-("copy-paste",1)-("Core/STG/C",-1)-("core/stg/grin/silly/c",-1)-("CoreInfo",-1)-("corruption",1)-("cosimo",1)-("cosmicnet",6)-("CosmicRay",1)-("cosmosophy",2)-("cotto",5)-("counter",1)-("cowie",1)-("cox",1)-("cpan",2)-("CPng|N",3)-("cps",1)-("CReal",1)-("create(andTrim)",1)-("creatina",1)-("credit",-2)-("Cross)",1)-("crsd",-1)-("crw-----",-2)-("crw--w--",-5)-("crw-r---",-9)-("crw-r--r",-1)-("crw-rw--",-5)-("crwSr-Sr",-1)-("crx-rw--",-1)-("CrypticS_",1)-("Crypto",9)-("Crypto-",1)-("CryWolf",1)-("cspencer",12)-("css",-2)-("cthulhon",-147)-("ctrl",1)-("ctrl-w",-1)-("cuarto",1)-("culo",1)-("CuriosTiger",1)-("curmudgeon",1)-("currentIndex",0)-("currentStaticObjectCounter",1)-("CXXC=clang",2)-("cybercobra",1)-("cycling",1)-("C\\C",1)-("c_wraith",4)-("d",3)-("d+",1)-("D+++",1)-("D-",-1)-("d--------",-1)-("d------------------------",-1)-("daemon",2)-("daf",1)-("dafis",2)-("daime",2)-("dairico",1)-("dalek",1)-("damian",3)-("damian--",1)-("dan",-2)-("dan--------------------------------",-1)-("dancor",2)-("danharaj",1)-("DanielC",9)-("danijami23",-1)-("dankogai",6)-("danl",3)-("darbelo",1)-("darcs",-1)-("Darcs/Patch/OldDate.hs",-2)-("darkcore",1)-("Darren_Duncan",2)-("darth_vader",1)-("Data.Foldable",1)-("Data.Foo.Pretty-",-1)-("Data.Traversable",1)-("datalog",1)-("datura",0)-("DaveXi",1)-("david.green",1)-("day)",1)-("days",-1)-("Day_",1)-("DB",1)-("db2",-1)-("dbertua",1)-("dc",12)-("dcouts",1)-("dcoutts",18)-("ddarius",16)-("ddrescue",1)-("deadbeat",1)-("debian",1)-("debug",1)-("decadentes",1)-("decobot",-1)-("Deepy",1)-("Deewiant",-1)-("default<-",-1)-("defaulting",-1)-("defun",1)-("delirant",-1)-("deniability)",1)-("density",1)-("dependent-types",1)-("dereference",-1)-("Descamps)",1)-("desktops",1)-("detection)",-1)-("dev-c",7)-("devc",1)-("Development)",2)-("DFOR",-1)-("dforstyh",2)-("dforsyth",-99)-("dho",3)-("dho_plan9",1)-("di.fm",1)-("diakopter",135)-("diakopter--",1)-("Dianora",3)-("dibblego",4)-("Dickie",46)-("DickieBo",-1)-("dickiepoo........<",-1)-("diego1",1)-("different",-1)-("digitalice",-24)-("dime",1)-("dirs",-1)-("distance",-1)-("distinctions",1)-("distracting",-1)-("dixie_dregs",1)-("djahandarie",1)-("django",-3)-("django_forms",1)-("djinn",1)-("dmwit",4)-("dmwit_",1)-("dnaumov",1)-("dns+",1)-("DoAndIfThenElse",-1)-("dobblego",1)-("docs)",1)-("documentation)",-1)-("documents",-2)-("does",1)-("dogs",-1)-("dolio",7)-("dons",14)-("doserj",1)-("dott",1)-("double_standards",1)-("Dowland",1)-("DPAN",1)-("dr",-1)-("draq1",1)-("dream_machine",1)-("DRMacIver",2)-("Dropbx",1)-("drudge`",1)-("DrunkGymnast",1)-("drw-----",-2)-("drw-r--r",-1)-("drw-rw-",-1)-("drw-rw--",-1)-("drwx----",-15)-("drwxr-x-",-2)-("drwxrwx-",-5)-("dryanta",3)-("dr_df0",3)-("dschoepe",1)-("DTRT",1)-("duckpunching",1)-("dude",1)-("duff",39)-("Duff)",2)-("dukeleto",7)-("dust",-1)-("dust-",-2)-("Dutch",2)-("dvl",1)-("dvorak",1)-("dwhipp",3)-("DWIM",1)-("dwm",3)-("dymons",1)-("eaten",-1)-("Ebert_",-2)-("eclipse",0)-("ecmuller",1)-("ecn",1)-("edfly",1)-("edgar",2)-("editline",-3)-("edit_distance",-1)-("eduardo",1)-("edwardk",9)-("Eelis",1)-("effc",1)-("effects",-1)-("eflister",-1)-("egh",-1)-("egypt",1)-("eip",1)-("Eirik",1)-("eiro",1)-("elcresta",1)-("elf",2)-("elpolilla",85)-("elpolillafan",1)-("elreg",1)-("Elsayed)",3)-("elsueco",1)-("emacs",5)-("emb",1)-("emerge",-1)-("emos",-1)-("en.wikipedia.org/wiki/C",-1)-("en0th",1)-("encoding",-1)-("end",0)-("enfermedades",-1)-("enfermo",-1)-("engineering)",1)-("english",1)-("EnglishGent",1)-("enough",-1)-("ensalada_de_frutas",1)-("enter",-1)-("entirely",-1)-("Entroacceptor",1)-("entry)",1)-("envaginada",2)-("envasados",1)-("enzo",1)-("epoxy",1)-("erasure",-1)-("ERC",-1)-("erdos",1)-("erg0t",114)-("erg0t+",1)-("erg0tpolux",1)-("erg0t_",2)-("eric256",5)-("Eridius",1)-("ernestor",1)-("erny",4)-("esmoquin",-1)-("estradasphere",1)-("etc",1)-("eternaleye",5)-("europe",1)-("EvaLuaTe",1)-("evangelists",-1)-("EvanR-work",1)-("evaryont",1)-("evening",1)-("EventEngine",1)-("everyone",5)-("evil",1)-("evil-danger-is-my-middle-name-mangler",1)-("EvilTerran",7)-("EvolPenguin",-1)-("ex-C",1)-("excel",-1)-("expectations)",1)-("Expr",1)-("ezjail",1)-("ezyang",3)-("f+++",1)-("f-",-3)-("F--",-1)-("F---",-2)-("fachoness",1)-("fachos",1)-("factor",1)-("fail",-1)-("fakegina",1)-("familiar",-1)-("family)",1)-("fanbois",-1)-("far)",-1)-("Fare",2)-("fas",-1)-("fasta",4)-("fatalnix",1)-("fax",2)-("faz",1)-("FC",12)-("fclabels",1)-("fcr",1)-("fdie",-1)-("feather",1)-("fedaykin",1)-("fedora",1)-("Felds)",12)-("Feuerbach",1)-("feydr",1)-("ff3<",-1)-("FFFFFF",-1)-("FFI",2)-("ffmpeg",1)-("fglock",15)-("fibbo",-1)-("files",-1)-("finals",-3)-("finanalyst",5)-("fingertree",1)-("firefox",-2)-("fish",0)-("fish+",1)-("flan",2)-("flash",-1)-("flazx",1)-("fleas",-2)-("flexbuilder",-1)-("FliPPeh",-1)-("Flowerbauer+",1)-("Fly)--------------------------------------------------------",-1)-("fmargmeads",1)-("foca",1)-("foldl",-1)-("foldl'",1)-("folks",2)-("fondu",1)-("foo",2)-("Foo)",1)-("Food)",1)-("fool",-1)-("forget",1)-("forget`)",1)-("forro",1)-("fort",1)-("FORTRAN",-1)-("Foster)",65)-("Fosters",-1)-("foxclocks",1)-("fperrad",1)-("fragcount",1)-("francas)",1)-("France",-1)-("fredrik",1)-("fredrin",2)-("freebsd",0)-("freenode",0)-("freenode/##c",1)-("frettled",26)-("frew",29)-("friend)",1)-("frogor",4)-("fromForeignPtr",1)-("fromIntegral",1)-("frooh",1)-("frooh_",1)-("frula",-2)-("frutas",1)-("frutigran",1)-("fryguy",-2)-("ftdi",1)-("fucktard",1)-("fuel",1)-("fun",2)-("functor",1)-("FunctorSalad",3)-("fuser",1)-("fusion",1)-("FW",1)-("fw-",-1)-("fyi",-1)-("g",313)-("g++",1)-("g++/c",1)-("g4",-1)-("gaal",1)-("GADTs",1)-("galactic",1)-("gallego",2)-("Gallomimia",1)-("gamebryo/C",1)-("gardel",1)-("Gary_Simat",1)-("gateway",-1)-("gay.pl",-1)-("gbacon",1)-("gcc",-1)-("gcc-c",1)-("GCC/G",10)-("gcc/libstdc",1)-("gdb",1)-("geant",1)-("GeDaMo",2)-("geeksquad",1)-("geheimdienst",1)-("gelatina",1)-("Genocidicbunny",-13)-("Gentoo",1)-("geoffb",2)-("GeometricAlgebra",1)-("geomi",1)-("germany",-1)-("gerryvdm",1)-("ghana",1)-("ghc",1)-("ghc+",1)-("ghc-6.10",1)-("ghc-team",1)-("GHC.Base.",1)-("ghci",1)-("ghci-multiline-input",1)-("gholms",1)-("ghost",1)-("gifs",1)-("gigantes",-1)-("giles",0)-("gilimanjaro",-1)-("gimp",1)-("ginkgo_biloba",1)-("girls",1)-("gist.github",1)-("git",13)-("github",1)-("GIZA",2)-("glare",-1)-("glassfish",1)-("glguy",2)-("Gluttony",1)-("gnole",1)-("gnomon",1)-("gnumeric",1)-("gnuplot",1)-("goals)",1)-("Goatee+++++++++++",1)-("god",3)-("godel",1)-("goes",-1)-("golf)",1)-("gonchuki",1)-("gongoputch",6)-("gongzilla",1)-("gonz",1)-("gonzalus",-1)-("good",-1)-("goog",-1)-("Google",0)-("goombas",1)-("GoSox",2)-("Gothenburg",1)-("Gothmog_",1)-("gotico",-1)-("GPL",-1)-("gr00vy",0)-("gra",-1)-("Gracenotes",4)-("GracjanPolak",1)-("grahamhutton",1)-("grail",1)-("grant",1)-("graphviz",1)-("gravity",1)-("gressvol",-1)-("greycat",1)-("groom",1)-("groupthink",1)-("growl",1)-("grub",-1)-("gtk",-2)-("gtk/C",2)-("guaran\195\161",1)-("Guava",1)-("guess",-2)-("guido",1)-("guido_suller",1)-("guis",0)-("gump",1)-("gwenview",1)-("gwern",8)-("hackage",2)-("hackage\"",1)-("hackage.haskell.org",-1)-("hacked",1)-("hackery+",1)-("hacking)",1)-("hackingshoes",1)-("hacks",0)-("hacks)",1)-("haddock",-3)-("Haffa",2)-("Hague)",1)-("halberd",1)-("halos+",1)-("haml",1)-("happen",-1)-("happstack",1)-("har",-1)-("hard",1)-("harrop",4)-("has",-1)-("haskaml",2)-("haskeline",-2)-("Haskell",60)-("haskell-",-1)-("Haskell-C",1)-("Haskellcidicbunny",-1)-("HaskellLllama",1)-("HaskellLove",1)-("Haskell\226\128\147C",1)-("Hasselbacher)",14)-("hateC",1)-("hatred",1)-("have",-2)-("haxml",1)-("hayoo",2)-("HCAR",2)-("head",-2)-("headache+",1)-("headphones",1)-("hector",1)-("Heffalump",4)-("heh",1)-("Helio",3)-("Hellige)",1)-("helped)",1)-("henderson",1)-("here",2)-("hexidigital",0)-("hexrays",1)-("hgabreu",2)-("hgolden",2)-("hi",-4)-("hibernacion",1)-("him",-1)-("hinrik",76)-("hint",1)-("history",1)-("hobobuttsex",1)-("home)",-1)-("homerj",1)-("homework",-1)-("honesty",1)-("hoogle",2)-("horacio",1)-("hotdogs",1)-("hotmail",-1)-("housenka",1)-("hoy",1)-("hp",1)-("hpaste",0)-("hpaste2search",1)-("hpc",2)-("HSOE",-1)-("html",-1)-("html5",1)-("http",-1)-("hudak",1)-("hudnix",1)-("hueovo",1)-("hueso",5)-("huesos",3)-("huevos",-1)-("HughesPJ",1)-("hugme",7)-("hugs",0)-("humans",0)-("humility",1)-("humor",1)-("hv2",1)-("Hyper-C",1)-("Hypftier",1)-("i",21)-("i++,a",1)-("i586-mingw-whatever-g",1)-("i586-mingw-whateverbutt",1)-("IBM",-3)-("IcanCU",1)-("iceWM<---",-1)-("icfp",-1)-("IdCPS",1)-("IDEA",3)-("idling",1)-("idnar",1)-("IE",1)-("if",1)-("if(i",3)-("IGAME/C",2)-("Igloo",5)-("ignore_list_size",1)-("ihrd",9)-("ijuma",1)-("ijuma_",1)-("Ikary",1)-("iLap",1)-("ilid",1)-("IllvilJa",3)-("iluminado",1)-("Ilya",1)-("image.<",-1)-("IMAP",-1)-("imdb",1)-("ImInYourMonad",-1)-("in--",-1)-("inference",1)-("Infinoid",14)-("ingles",1)-("ingy",15)-("iNick",1)-("inkscape",2)-("Innovation",1)-("insanity",1)-("insoddisfazione",1)-("installed",-1)-("instances",0)-("int-e",3)-("int80_h",-1)-("Integer",0)-("intel",0)-("inter",-1)-("intercal",1)-("internet",2)-("internets",1)-("interpretation)",1)-("intersect",-1)-("inverses",-1)-("IO",0)-("IOArray@Data/Array/IO/Internals.hs-",-1)-("iocor",-1)-("Ion3++",1)-("IOOIIIOIIO",1)-("iplayer",1)-("iPod",1)-("IQ",1)-("iran",-1)-("irc",3)-("IRC)",1)-("irc2samus",4)-("irclog.perlgeek.de)",1)-("Irix",-1)-("irony",1)-("irssi",5)-("is",-2)-("ishmal",-2)-("islands",21)-("iso-c",1)-("ISP",-1)-("iss",1)-("issue9",1)-("it",-5)-("itunes",0)-("ivan",1)-("ivanm",22)-("iverson",1)-("J",4)-("j#/j",1)-("J/J",1)-("j3camero",1)-("jafelds",14)-("Jafet",2)-("JaffaCake",3)-("JalenJade",1)-("jamiroquai",1)-("japhb",10)-("japon",1)-("jaspervdj",1)-("jav",1)-("java",-10)-("Java/C",17)-("Java/C#/C",3)-("Java/C/C",1)-("javascript",-1)-("jaynes",1)-("jbapple",2)-("jdlugosz",8)-("jdv79",2)-("jean_claude_van_damme",1)-("Jedai",0)-("jeffwheeler",0)-("jeffz",2)-("JEJEJE",1)-("jer",3)-("jeremiah",3)-("Jesus",1)-("jews",1)-("JFDI",3)-("jhell",5)-("jimmiejaz",1)-("jimmy",39)-("JimmyZ",1)-("jinja",1)-("jkeenan",1)-("jlibmpq/src/c",1)-("jmcarthur",3)-("jmcarthur.points",1)-("JNI",-1)-("jnth",1)-("jnthn",607)-("jnthn+",1)-("jnthn+++++++++++",1)-("jntn",1)-("jobs",1)-("jogla",1)-("JohnMeacham",1)-("john_cage",1)-("jojo",-1)-("jokes)",1)-("Jon",1)-("jonalv",2)-("jonathan",102)-("jonathanturner",1)-("Jonno_FTW",1)-("josette",1)-("jpaetzel",1)-("jpalmer",1)-("jrm",2)-("jrockway",1)-("js",1)-("jsn",1)-("jsoft",1)-("json",5)-("jsut",3)-("judah-jacobson",1)-("judahj",2)-("Judge",-2)-("Juerd",8)-("Juerd_",1)-("Jython",2)-("K",2)-("k-means",1)-("kadaver",-1)-("kalkin",-1)-("kaol",0)-("Karith",1)-("karlsruhe----",-1)-("karma",1)-("karmanaut",0)-("kashmir",1)-("kbateman",2)-("kcachegrind",1)-("kde4",-1)-("Ke",1)-("Kernel86",1)-("keyboards",1)-("keylogger",1)-("keynote",1)-("killing-flies-with-nuclear-weapons",1)-("king",1)-("KingCannibal",1)-("Kinos",4)-("kirby81",1)-("kjwcode",2)-("kleptones",1)-("kmc",5)-("kmc/kmc",1)-("kmc_",1)-("knots",-1)-("knowledge",1)-("koala_man",1)-("Kodi",8)-("koeien",1)-("koeien37",3)-("kolmodin",6)-("KonaB1end",3)-("kosmikus",1)-("kowey",2)-("kpreid",2)-("krunk",-1)-("krunk-",1)-("krzys",1)-("ksf",5)-("KSM",1)-("kulin",1)-("kuribas",1)-("kyle",107)-("KyleHa",29)-("kynky",1)-("k\195\184ns\195\184le",1)-("L",0)-("l-wx---",-1)-("l-wx----",-4)-("l-wx-----",-1)-("L.+",1)-("l0pht",1)-("labdabot",-1)-("LaBrassBanda",1)-("lacalle",2)-("ladyfeo",1)-("lambdabot",1)-("lamdbabot",1)-("lament",4)-("Laney",2)-("Language.Haskell.TH.Quote.QuasiQuoter",1)-("lanny",2)-("laptops)",1)-("LaraNYC",1)-("LaraTextual",-1)-("LaraX",1)-("larry",26)-("last",1)-("late",-1)-("later\"",1)-("lathos",1)-("Latin",2)-("Latvia",1)-("layouts)",-1)-("laz0r",1)-("laziness",7)-("LazyIO",-1)-("lazyness",1)-("leadnose",1)-("learning",1)-("learnyouahaskell.com",1)-("leche",0)-("lectrick",1)-("leet",1)-("legacy",1)-("leksah",-1)-("Lemmih",9)-("lennon",1)-("Lentczner)",1)-("Lenz)",63)-("LeoD",1)-("LeoD_",1)-("leopard<",-1)-("Lester)",2)-("Leto",6)-("Leto)",1)-("letrec",1)-("lhames",1)-("libc",4)-("libedit",-7)-("libperl",1)-("libpq",1)-("libpurple",-1)-("libraries/base/Foreign/C/Types.hs",-1)-("libres",1)-("libsdc",1)-("libsigc",1)-("libstd",4)-("libstdc",53)-("libstdcc",1)-("lichtkind",3)-("licuado",1)-("life",-2)-("life++",-1)-("liftM2",2)-("lighthazard",1)-("lighty",1)-("like",-1)-("like-",-1)-("lilac",2)-("lilstevey",3)-("lincoln",2)-("linenumbers++++++",1)-("Linkinus",1)-("linode",1)-("linux",-4)-("linux/c",1)-("lisp",-1)-("lisp->php->hiphop->c",1)-("lispy",15)-("List.",5)-("lists",-1)-("lists)",-1)-("listToMaybe",1)-("literal",9)-("literal_videos",1)-("Lithos",8)-("lithyum",1)-("liveusb",1)-("liwp",1)-("lizsac",1)-("lluvia",6)-("LLVM",1)-("llvm-1.5-g",1)-("llvm-c",1)-("LLVM-G",3)-("LoC",1)-("logic",-1)-("LogicT",1)-("logs",2)-("lol",3)-("LolDispatch",1)-("longboard",1)-("loopcount",2)-("loops",-1)-("LordRawK",1)-("lost)",1)-("los_simuladores",1)-("love",1)-("lowasser",1)-("lpsmith",0)-("lrw-r--r",-2)-("lrwx-----",-1)-("LSD`",1)-("lsof",1)-("lua",-1)-("lucs",1)-("luigi",1)-("luis",4)-("luite",1)-("lunabot",1)-("luqui",5)-("LurkingBM",1)-("lvj",1)-("LVM",1)-("lwall",530)-("lyah",1)-("Lyle",2)-("LylePerl",6)-("mac",-1)-("maceo_parker",1)-("MacinMan",1)-("macos",0)-("macosx",1)-("macports",2)-("macros",-2)-("macs",-1)-("macvim",2)-("made",-1)-("madhat",-1)-("mahogny",1)-("main",-1)-("make",1)-("makeprg=g",1)-("malcolmw",1)-("malta",1)-("maltem",1)-("MamboJUmbo",1)-("mamoul",1)-("management",1)-("manaleaks",1)-("ManateeLazyCat",-2)-("ManDog202",-1)-("mangang\195\161s",-1)-("mantecol_con_chocolte",1)-("mantraps",1)-("manuel",3)-("manufacturers",-1)-("Map.",2)-("mapreduce",1)-("mar",-1)-("marcelo",1)-("marcot",1)-("marc_feeley",1)-("mariana",2)-("MariusAZ",1)-("mariuzaz",-1)-("mark3l",2)-("marketing",1)-("markmont",5)-("mark_farina",1)-("Marshal)",1)-("Martijn",1)-("martin",5)-("masada",1)-("masak",457)-("Masak)",9)-("masak.list.elems",1)-("masakbot",0)-("Masamune",1)-("mask",1)-("mason-l",1)-("massak",1)-("Match)",1)-("matchers-",-1)-("math",1)-("maths",-1)-("mathw",17)-("matlab",-2)-("Matt-W",10)-("mattw",2)-("mauka",0)-("mauke",26)-("mauri",3)-("max",4)-("Maybe)",1)-("mberends",88)-("mcbride",1)-("mckinna",1)-("McManiaC",1)-("mdo-and-join-readSTRef-thesame-STRef-you're-defining",1)-("mdxi",1)-("me",-2)-("me\"",-2)-("mean",-1)-("medfly",-5)-("media",-3)-("Mehndi)",1)-("memes)",-1)-("mempty",1)-("menem",2)-("merca",-1)-("merijn",8)-("meta",1)-("meta)",1)-("metadata---",-1)-("metaop)",1)-("meth",1)-("mibbit.com",1)-("michael",-1)-("Michaud)",2)-("michel",1)-("microcenter",1)-("microondas",1)-("microsoft",0)-("midd",-1)-("miel",1)-("miguel",1)-("mikehh",1)-("mike_pall",1)-("mike_stern",1)-("mildew",1)-("milner",3)-("minds)",1)-("mine",-1)-("minimalist-c",1)-("minus)",-1)-("MissPiggy",4)-("mistakes)",1)-("mitchell",1)-("mixfix",-1)-("mixins",1)-("mixxx",-1)-("mi_vieja",1)-("mi_vpn",-1)-("mj41",4)-("mjard",4)-("mjrosenb",2)-("ml|",1)-("mmorrow",6)-("mmrg",1)-("mmrg5486",1)-("mncharity",2)-("MoALTz",1)-("mob_",1)-("moment",-1)-("monad",-1)-("monadLib",1)-("monitores",1)-("monkey",1)-("Monkey)",-1)-("monkeypatch",1)-("MONKEY_TYPING",1)-("monochrom",11)-("monotone",1)-("monty_python",1)-("moquete",1)-("more",-2)-("moritz",955)-("moritz++",1)-("moritz_",147)-("moritz__",2)-("mornfall",2)-("mosaic",1)-("moto",1)-("motos",1)-("mouse",-1)-("mpd",1)-("mrbungle",1)-("mrd",1)-("mreh",1)-("mrpolux",5)-("MS",-1)-("msbob",1)-("msn",-1)-("mssql",0)-("mst",12)-("msvc",18)-("mtnviewmark",4)-("mttxr",-4)-("mtvdlb",1)-("Mu",-1)-("mubot",6)-("mueval",-1)-("Munchkin",1)-("music",1)-("musica",1)-("musicanna",1)-("mutability",-1)-("mutar",1)-("mutt",1)-("mux",4)-("mvt",1)-("mxc",1)-("MyCatVerbs",2)-("mysql",-5)-("myst",1)-("myVoidPtr",1)-("m\195\169xico",1)-("n",1)-("n00b",1)-("nachof",5)-("Nafai",1)-("Naggum",1)-("nagiosql",1)-("names",1)-("nano",1)-("nanobsd",1)-("napolitana",-1)-("nat",1)-("nationalgeographic.com",-1)-("NBN",1)-("nbrown",2)-("nbrown_",1)-("ncmpc",1)-("ncmpcc",1)-("ndm",3)-("ndmitchell",1)-("neck",-1)-("Necrosan",1)-("NEEDMOAR",16)-("negative-margins",0)-("nestl\195\169",1)-("netbeans",-1)-("netherlands",1)-("netstat",1)-("network",-2)-("newbie008",1)-("newsham",1)-("ng",3)-("Nicholas",1)-("nick",1)-("Nightwish",1)-("nixon",-2)-("njan",1)-("NLindberg",1)-("no",-1)-("no-",-1)-("nodepad",1)-("noise)",1)-("nomeata",1)-("nominolo",0)-("nominolo_",1)-("NoMonomorphismRestriction",1)-("non-C",1)-("non-c/c",1)-("Noob",1)-("NoScript",1)-("nosotros",1)-("notDooinItRong",1)-("notedpad",1)-("notElem",1)-("Notepad",67)-("notepad's",1)-("Notepad++",0)-("notepadd",1)-("notepoad",1)-("NotFound",2)-("nothing",-1)-("nothingmuch",1)-("notmasakbug",1)-("now",-2)-("nox",1)-("nox-",6)-("np",7)-("npmap",1)-("NQP)",1)-("NSClient",1)-("NSString",-1)-("NT+",1)-("nt1",1)-("ntsc",-1)-("null",-2)-("nulls)",1)-("Num",0)-("nursery",-1)-("nv",-1)-("nvi",1)-("obama",-1)-("Obj",2)-("obj-c",19)-("ObjC",24)-("objc/c/c",1)-("ObjC/ObjC",1)-("object)",-1)-("Objective-C",22)-("Objective-H#",1)-("obra",2)-("obra_",2)-("obscurity)",-1)-("OBSD",1)-("observation",1)-("ofC",1)-("oh",-2)-("ok-",-1)-("Olathe",1)-("old",1)-("oldfag",1)-("oldmemes",1)-("oleg",8)-("olveyra",1)-("omegix",1)-("omnet",1)-("on",2)-("one",-2)-("onion",1)-("Ontolog",4)-("OO",-1)-("openid-for-npaste",1)-("OpenLDAP",0)-("openmp",1)-("openoffice",1)-("openvpn",3)-("OPERA",3)-("opinions",-1)-("opportunities\"",-1)-("opqdonut",1)-("opticron",1)-("optimizations",1)-("Option",1)-("OR",-1)-("Oracle",-1)-("orbitz",1)-("Oslo",1)-("other",-1)-("otherwise",-1)-("otto",3)-("OUTPUT\194\171-",-1)-("overdesign",-1)-("ownuniversity",1)-("ozric_tentacles",1)-("ozy`",1)-("p",1)-("p6eval",0)-("pablo",-2)-("paige",-1)-("pairs",1)-("paja",1)-("palpteta",1)-("paludis",1)-("pancake",3)-("panflauta",1)-("PANIC+",2)-("Panties",1)-("paolino",1)-("papermachine",1)-("parallels",1)-("parametric-polymorphism",1)-("paranoia",1)-("paros_bancarios",-1)-("parrot",-3)-("Parrot/Rakudo/MSVC",1)-("parse)",1)-("parsec",-2)-("participants)",1)-("particle",48)-("partition",-1)-("pastebin",1)-("pastebin.me",-1)-("paste_rompetodo",1)-("pastie",0)-("pastie.org",-1)-("pastorn",-2)-("patata",1)-("paterson",2)-("Paths_foo",1)-("patterns\"",-1)-("patterson",0)-("paulp",1)-("payload",1)-("pct",1)-("pdftk",1)-("Peaker",3)-("pela",1)-("pentium",1)-("people",1)-("Perl",2)-("perl5",-1)-("perl6",5)-("Perl6)",0)-("perl6advent",16)-("Perlis",1)-("PerlJam",34)-("perlmonks",-2)-("perltidy",1)-("Perl\226\128\130\&6",1)-("permissions",-1)-("pescado",2)-("pfloyd+",1)-("PGE",1)-("phantomcircuit",1)-("phantomTypes",1)-("PhatEddy",4)-("phenny",6)-("Philippa",1)-("Philippa__",1)-("Philonous",2)-("Philonous1",1)-("philosophical",-1)-("phonetically",-1)-("php",-1)-("php->C",1)-("php-to-C",3)-("picky",-1)-("pictures)",1)-("Pietro",1)-("pink",-1)-("pipas",1)-("pixeImator",1)-("pixelmator",1)-("pl",2)-("places",-1)-("plan",-1)-("plan9",1)-("planet)",1)-("planetx",1)-("platform",-2)-("player",-1)-("player\"",-1)-("PLP",1)-("pmichaud",1017)-("pmurias",404)-("pnate",2)-("pochi",1)-("poco",1)-("pococ",1)-("pointer",1)-("pointers",-1)-("pointme",2)-("polaco",1)-("polakitos",1)-("Polarina",1)-("pollo",1)-("polonia",1)-("polux",9)-("population",1)-("porro",2)-("portability",1)-("portenias",1)-("porticus",-1)-("portmaster",0)-("ports/cc/c",1)-("portupgrade",-1)-("port_version",1)-("poss",-1)-("possible)",1)-("postfix",5)-("postgres",2)-("postgresql",2)-("postre_ser",1)-("poucet",2)-("pounds",1)-("PPM",1)-("pq",1)-("pragmatism",1)-("preaux_launch",1)-("precedence",-1)-("prefix",1)-("preflex",0)-("Prelude.",3)-("present",1)-("pretty",0)-("prettyprinter",-1)-("preview",1)-("pride",1)-("print(x",1)-("printf(\"c",1)-("printpdf",-1)-("prisms",1)-("privnote",-1)-("pro",1)-("problem",-1)-("problem-",-1)-("productividad_negativa",1)-("productivity",2)-("profiling",1)-("programming--",-1)-("progress",3)-("Prolog",-1)-("proto",1)-("protocool",0)-("prw-r--r",-1)-("pryor",6)-("psychology)",1)-("psykotic",1)-("psytrance",1)-("pthreads",-1)-("ptr",1)-("pugs",3)-("pulper\195\173a",1)-("pulpos",1)-("pumkin",1)-("pumpkin",6)-("Pun",2)-("punks",-1)-("puns",-1)-("purity",1)-("purple",1)-("putter",144)-("pyrimidine",1)-("Pythin,C",1)-("python",0)-("python)",1)-("python,c",1)-("python,ruby,c",1)-("python-to-C",1)-("Python/C",2)-("python/java/c",1)-("python/ruby/c",1)-("qc",-1)-("QMAKESPEC=macx-g",3)-("Qt/C",3)-("qtc",1)-("quagga",1)-("quake",1)-("quanticle",0)-("QuasiQuotes",1)-("Quassel",-1)-("queso",1)-("question",-2)-("questioning",1)-("QuickCheck",5)-("quicksilver",21)-("quienfuera",-1)-("quietfanatic",7)-("quodlibet",-1)-("R",-2)-("r--r--r",-1)-("rada",-1)-("rafl",2)-("RAGE",1)-("rail",1)-("rails",1)-("rakudo",27)-("rakudo-parrot-split",-1)-("Ralith",2)-("ram",1)-("random",1)-("Range)",1)-("ranguard",2)-("rasmus",2)-("ration",-1)-("ray",1)-("rblasch",1)-("readabler",1)-("readCount",3)-("readHtml",-1)-("readline",1)-("ReadP",3)-("really",-1)-("rebootitis",-1)-("reddit",1)-("redditbot",-2)-("ref",1)-("references",1)-("refraction",1)-("regex)",0)-("regexes",1)-("regexes)",1)-("reified",1)-("reliable_data_storage",1)-("remains",-1)-("remodel",1)-("remyo_",1)-("renormalist",3)-("rep",1)-("repl",1)-("replace",1)-("reppie",16)-("req",-1)-("REQUEST---",-1)-("resaca",-1)-("resbalosa",1)-("resources",-1)-("resto",-1)-("retorcidas",1)-("retronym",1)-("return",-1)-("rg",1)-("rgrau_",1)-("rgs",3)-("Riastradh",2)-("ricardo_fort",1)-("richard",1)-("RichardO",1)-("ricky+",1)-("riconosciuto",1)-("right-",-1)-("rindolf",1)-("Ripple)",1)-("rjbs",1)-("Robert');DROP_TABLE_Students;",-1)-("RobPike",1)-("rob|",1)-("rock",1)-("rocket",4)-("roconnor",9)-("rody",2)-("rofl--",-1)-("rog",1)-("rollers",1)-("rolls",1)-("ron",6)-("ron.koerner",1)-("RoR",0)-("rorx",2)-("rorya",1)-("RossPaterson",1)-("RSchulz",1)-("rsync",3)-("ruby",-2)-("ruoso",164)-("ruoso/progress",1)-("rurban",4)-("russians",1)-("rw-----",-1)-("rw-------",-1)-("rw--rw--",-1)-("rw-r---",-1)-("rw-r--r",-6)-("rwbarton",6)-("rwh",1)-("rwx----",-5)-("rwx-------",-1)-("rwx--------------------",-1)-("rwxrwx-",-1)-("ryan[WIN]",5)-("ryan[WTF]",0)-("S",1)-("s/",-1)-("s/C++/C",1)-("s/c/c",2)-("S05",1)-("S07",1)-("S08",1)-("s1n",15)-("S29",1)-("sad.",-1)-("safari",0)-("SAHChandler",2)-("Saizan",14)-("Saizan_",6)-("Sal",-26)-("salvatore",1)-("salvia",1)-("SamB",1)-("SamB++++",1)-("sambay\195\179n",1)-("SamB_XP",2)-("SamB_XP_",1)-("saml",-1)-("samus",2)-("samus.viejata",1)-("Samus_",11)-("Samy",1)-("sandniggismo",1)-("sanga",-3)-("sanguinetti",1)-("sanity",2)-("santander",-1)-("Saran",5)-("sass",1)-("satisfacho",3)-("Savagedlight",1)-("say)",1)-("say-",-1)-("sbahra",1)-("sbp",5)-("sc68cal",1)-("scala",6)-("Scheme/C",1)-("schwarzer",2)-("Scite/Notepad",1)-("scrapy",-3)-("screen",0)-("Scriptor",2)-("scrollback",1)-("scrot",1)-("Sean_McG",2)-("search",1)-("search-replace",1)-("sebasmagri",2)-("sebazzz",11)-("sec",-1)-("security",2)-("sed",2)-("sed++++",1)-("SEE",1)-("segfaults",-1)-("self",-1)-("semifinals",-1)-("sensitive",-1)-("Seq",0)-("sequence",1)-("sereven",1)-("serve",-1)-("server",-1)-("service.<--",-1)-("SethTisue",1)-("setrlimit",1)-("SF",3)-("sgml",1)-("shachaf",0)-("shaft",1)-("shapr",5)-("sharkhat",1)-("shawn_lane",3)-("shi",-3)-("sholt",1)-("shorter",1)-("SICP",1)-("sijmen",1)-("sil",-1)-("silence",1)-("silence---",-1)-("SilentAgony",2)-("silentAgony-----------------------",-1)-("silla",-1)-("silverlight",1)-("silvio",1)-("simoncpu",2)-("simoncpu__",1)-("SimonMarlow",1)-("simplicity",2)-("Simpson",1)-("sinelaw--",1)-("single-points-of-failure",-2)-("singleton",1)-("site)",1)-("sixthgear",2)-("sjanssen",5)-("sjn",5)-("sjohnson",4)-("ski",10)-("skids",14)-("skin",1)-("ski_",3)-("skorpan",1)-("skype",-1)-("slang",1)-("slashdot",1)-("slava",5)-("slavik",3)-("slightly-slower-than-C",1)-("slow",1)-("sm",1)-("Smalltalk/C",1)-("smart",-1)-("smash",1)-("smash_",1)-("SMBC",3)-("smegma_covered_cocks",1)-("smokers+",1)-("snap",-1)-("snarkyboojum",3)-("Snausages",1)-("snes",1)-("Snow-",1)-("sockets/c",1)-("socks",1)-("software",-2)-("sohum",1)-("solaris",-1)-("solidsnack",1)-("solrize_",1)-("som",-1)-("someone",3)-("something)",1)-("sony",-1)-("sopa",1)-("sort",1)-("source-based-distributions",-1)-("spaceghost",2)-("spectests",1)-("speed",1)-("speling",-1)-("spelling",-1)-("Spencer)",4)-("spinclad",2)-("SPJ",4)-("spline",2)-("spook327",1)-("spoon",1)-("Spotify",1)-("sproingie",2)-("spx2",1)-("Spy",1)-("sqlalchemy",-2)-("sqlite",4)-("squ",1)-("Srw--x-",-1)-("ss",-1)-("SSE2",-1)-("sshirokov",3)-("ssssssssssss",-1)-("ST",1)-("stackoverflow",1)-("stallone",1)-("startup)",-1)-("statistics",1)-("std",7)-("std)",1)-("stdc",23)-("stdlib",1)-("steele",1)-("stella_artois",1)-("stepcut",1)-("StephenPollei",1)-("still",1)-("store",-1)-("strace",1)-("stravinsky",1)-("strings)",1)-("str[i]",1)-("studio",1)-("studio/C",1)-("stuff)",1)-("stupidity",1)-("Su-Shee",3)-("substitution",0)-("sucia",-1)-("sudoku",-1)-("sueco",2)-("sugar",1)-("suggestion",-1)-("sun",-1)-("supernovus",1)-("superSerious",1)-("SuperSnail",1)-("supp-",-1)-("support",1)-("support\"<",-1)-("suse",-1)-("SVG",2)-("svn",-5)-("svn)",-1)-("svn--)",1)-("svnsync",1)-("swt",-1)-("swulf",-1)-("synergy",1)-("syntaxglitch",1)-("SyntaxNinja",2)-("synx`",1)-("sysadmin",-2)-("sysadmins",-1)-("system",1)-("system''`",-1)-("System.out.println(x",1)-("szabgab",75)-("s[$0]",1)-("tab-is-not-a-valid-token",1)-("tabcompletefishing",1)-("TabCounter",1)-("tables;",-1)-("tadeo",1)-("Taejo",0)-("tagsoup",1)-("takadonet",2)-("TAPL",1)-("TARBALL--",-1)-("tati",1)-("TDD",1)-("tea",1)-("tedv",1)-("teledildonics",1)-("Tene",70)-("tennis)",2)-("tensorpudding",1)-("terminal)",-1)-("Terminus",-1)-("termites",-1)-("test",-1)-("testing",1)-("testing)",1)-("testingThisJunk",1)-("tests",7)-("tests)",0)-("texas",-1)-("texmante",1)-("text",1)-("Text.XHtml.Strict.+",1)-("textmate",1)-("TextWrangler",1)-("th",-2)-("Thanks",-2)-("that",-1)-("that)",1)-("THC",1)-("TheDamian",6)-("TheNavyBear",1)-("theonion",2)-("theorbtwo",1)-("there",-1)-("theRightWay",1)-("TheZapzupNZ",1)-("thing",-1)-("things",-1)-("things)",1)-("think",1)-("third",-1)-("this",-3)-("this.age",1)-("tho",-1)-("thoug",-1)-("though",-1)-("thoughtpolice",3)-("thowe",1)-("ticholos",1)-("tickets)",1)-("ticoz",1)-("Tiger",-1)-("TikZ",1)-("timbres",1)-("time",-1)-("time)",1)-("TiMidity",1)-("timoreilly",1)-("TimToady",95)-("timtowtdi",1)-("tinderbox",1)-("tinelli",1)-("Tinned_Tuna",143)-("Tinned_Tuna#",0)-("tintin",1)-("tizoc",103)-("tizoc_",-1)-("tj-",-1)-("tj--",-1)-("tjcarter",-1)-("tmclaugh1",1)-("tnks",-1)-("to-",-1)-("todd",-2)-("tolkad",-2)-("tomberek",1)-("Tomis",5)-("tommd",1)-("tonight",-1)-("too",-1)-("toolbars",-1)-("topic",0)-("tormenta",1)-("tortas_fritas",1)-("touchpad",-2)-("Toxaris",2)-("tr",1)-("trac",-1)-("trace",-1)-("tracker",-1)-("transistors",-1)-("transmission",1)-("transpose",1)-("trapito",4)-("trashguy",2)-("tree",1)-("treed",1)-("treeSort",1)-("tricky",-2)-("trie",1)-("trippa",0)-("tromp__",1)-("tronik",1)-("ttt",-1)-("Turbo-C",1)-("TurboC",1)-("turtle",2)-("tusho",1)-("tu_gente",-1)-("tu_viejo",1)-("twanvl",2)-("Twey",7)-("twifkak",3)-("twisted",-1)-("twitterBrilliance",1)-("typeclasses",1)-("typeclassopedia",1)-("types",2)-("typing",-1)-("typos",1)-("t_j",3)-("U4",1)-("uasi",3)-("Ubuntu",0)-("uClibc",2)-("uds",-2)-("Ugarte",1)-("ugh...C",1)-("Ultimate",1)-("ultramage",1)-("ultraviolence",1)-("UML",-1)-("undef",1)-("undef.",1)-("undo",0)-("unfoldr",2)-("Unicode",2)-("uniplate",1)-("universe",1)-("universo",-1)-("unix",-1)-("UNIXgod",1)-("unlambda",1)-("unobe",1)-("unsafeChrom",1)-("untyped",-1)-("up",-1)-("upboats",1)-("up_the_irons",1)-("UQlev",1)-("uruguay",-1)-("uruguay.internet",-1)-("urxvt",2)-("usb",-1)-("useful-",-1)-("userfriendly",1)-("User_4574",-1361)-("use]",-1)-("usr",1)-("ute",-1)-("UTF-8",1)-("utf8",1)-("Util",15)-("v",0)-("v------",-1)-("vaio",1)-("Valodim",1)-("vamped",1)-("vanadium",1)-("var",4)-("var++++",1)-("vbox",1)-("VC",51)-("vc++/g",1)-("vecino",1)-("vegai",1)-("Vellos",2)-("Velociraptors",-1)-("venison",1)-("verdelyi",0)-("vic_",1)-("vieja",1)-("vienna.pm",4)-("viklund",6)-("vim",8)-("vimperator",1)-("vimscript",-1)-("vindaloo",1)-("virtualbox",5)-("VIsta",-2)-("visualC",1)-("vixen",-1)-("vixey",5)-("vlc",-2)-("vlc_",0)-("vmbrasseur",2)-("vms",1)-("vos",-2)-("voted",1)-("Vq^",1)-("VS",1)-("v_",1)-("w0ls0n",1)-("w3",1)-("waern",1)-("wagnerrp",1)-("Wait\"",-1)-("wallet",1)-("walterbright",1)-("Warc",-1)-("ware",2)-("warewolf",1)-("water",1)-("wayland",55)-("wayland76",11)-("ways-",-1)-("wchogg",1)-("wdf",2)-("we",0)-("web",-2)-("webfag",1)-("weed",333)-("weed++",-1)-("weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed++weed",1)-("weekend",1)-("Weeks)",11)-("Well",-1)-("Weredickie",2)-("WEST",1)-("wet",1)-("WetTowel",1)-("wharrgarble",1)-("whi",-1)-("Whipp)",1)-("White\"",1)-("White)",1)-("whiteknight",6)-("whoever",1)-("whores",1)-("why----------",-2)-("wife)",1)-("wijnand",1)-("Wikipedia",3)-("wil",1)-("will_clinger",1)-("Wilson)",1)-("Windows",-3)-("windows)",1)-("wine",1)-("wing",-1)-("winter",1)-("wireless",1)-("wit",1)-("wli",4)-("wlirants",1)-("Wolfman2000",21)-("wollmers",20)-("wonderfuel",-1)-("wonderful-",-1)-("Woodi",2)-("wool",1)-("WootKit",-1)-("WOOTS",1)-("words",1)-("work",-2)-("work)",1)-("work-",-1)-("workflow",1)-("working",-1)-("wormhole",1)-("Worthington)",7)-("wow",-1)-("wreck'd)",1)-("wtf",2)-("x",11)-("x->C",1)-("X<szabgab>",1)-("xaoslaad",1)-("xavura",1)-("xchat",1)-("XD",-1)-("xdie",-1)-("xen",1)-("xerox",1)-("xiu",1)-("xkcd",2)-("xml",0)-("xmonad",3)-("xorg-modular",1)-("xp",0)-("xplat",1)-("xrandr",1)-("XSLT1.0",-1)-("xyz",-1)-("yaml",1)-("Yay",1)-("yayo",1)-("ye",-1)-("Yea",-3)-("yesterday-",-1)-("yi",2)-("yitz",1)-("yo",4)-("Yorgey",1)-("you",0)-("you)",2)-("youtube",-1)-("z",-1)-("Zao",4)-("zappa",1)-("zaslon",1)-("zec@",1)-("zed",3)-("zelda",1)-("zeno",1)-("zev",2)-("zfs",1)-("zipAll",1)-("zipios",1)-("znc",2)-("zomg",1)-("zooko",1)-("zsh",2)-("zygoloid",6)-("zzorn",1)-("[",-2)-("[\"",-1)-("[\"C",1)-("[\"q\"",1)-("[a..z]",1)-("[ctcpa]",1)-("[ctcpa]++",1)-("[internet]--->[modem]--",-1)-("[particle]",12)-("[swift]",1)-("[x+y]",1)-("[]]",-1)-("\\\"++intercalate\"+l*31+\"\\\",\"+l*31+\"\\\"(c(\"+l*31+\"\\\"brainfuck\"+l*64+\"n++++++++[>++",1)-("\\13\\10",0)-("\\bot",1)-("\\r\\n",-2)-("\\s",-1)-("]]]--------------------",-1)-("^",-24)-("^-",-9)-("^--",-1)-("^-------",-1)-("^/",-1)-("^^",3)-("_",-2)-("_anibal",1)-("_Jonas_",12)-("_MaK_",1)-("_Steve_",2)-("__,",-1)-("__ash__",1)-("__ash___",1)-("__name__",1)-("___-__-",-1)-("`",-8)-("`(",1)-("`+",1)-("`-",-1)-("`--",-1)-("{",-2)-("|'-'--------'--",-1)-("|--",-1)-("|---",-1)-("|-----",-1)-("|------",-1)-("|-r-sr-x-",-2)-("|<",-1)-("|orbit|",2)-("~artgoeshere",1)-("~AryehGregor",1)-("~eclipse",-1)-("~kadaver",1)-("~maven",1)-("\148\228\184\128\227\129\140\233\187\146\230\156\168\227\129\149\227\130\147\227\130\146\231\180\185\228\187\139\227\129\153\227\130\139\228\186\136\229\174\154\227\128\130<",-1)-("\171-",-2)-("\226\128\152",1)-("\226\128\152C",1)-("\226\128\158C/C",1)-("\226\152\173",2)-("\227\129\169\227\130\130",1)-("\195\164\195\165\195\163\195\184\203\155\196\145\197\130\195\186\195\188\195\182\195\161`\195\159\194\180\194\168\203\135\195\177\195\169\195\173\195\166^\195\167\197\147\203\152\203\154\194\175<-",-1)-("\230\173\169\227\129\132\227\129\159\227\130\137\227\128\129\233\155\187\232\187\138\227\129\171\233\129\133\227\130\140\227\129\190\227\129\153\227\128\130\227\128\128<",-1)-("\231\130\173\231\191\191",-1)-("\239\189\183\239\190\128--",-1)-("http://en.wikipedia.org/wiki/C",-2)-("http://img75.imageshack.us/img75/6274/photo111608001gu9.jpg<",-1)-("http://www.fastimport.com.uy/detalle.asp?prd=2392++++++++++++++",1)-("http://www.haskell.org/haskellwiki/Keywords#",-1)-("say\226\144\164WHERE:/\\<",-1)-("sa\226\144\164WHERE:/\\<",-2)-("src/ByteStringUtils.hs:452",-1)-("s\226\144\164WHERE:/\\<",-2)-("used:-",-1)-("}.perl\226\144\164WHERE:/\\<",-1)-("\226\144\164WHERE:/\\<",-5)
− State/poll 
@@ -1,12 +0,0 @@-"blah"-(True,[("no",0),("yes",0)])-food-(True,[("quesadilla",1),("meatball-sub",0)])-logoVotingMethod-(True,[("Schulze",1)])-naming-(False,[("Lovelace",1),("Babbage",0)])-remove@src-(False,[("no",1),("yes",1)])-threeway-(False,[("method3",3),("method2",0),("method1",1)])
− State/quote

binary file changed (86388 → absent bytes)

− State/seen

file too large to diff

− State/state 
@@ -1,1 +0,0 @@-"This page intentionally left blank."
− State/system 
@@ -1,1 +0,0 @@-((1290244648,781347000000),TimeDiff {tdYear = 0, tdMonth = 0, tdDay = 0, tdHour = 0, tdMin = 0, tdSec = 3368669, tdPicosec = 0})
− State/tell 
@@ -1,155 +0,0 @@-("#haskell",(Nothing,[Note {noteSender = "Baughn", noteContents = "Have any of you seen parse errors when using haskell-indentation.el? (Kuribas' mode)", noteTime = (1257180374,821670000000), noteType = Ask}]))-("10",(Nothing,[Note {noteSender = "Badger", noteContents = "", noteTime = (1233224836,492094000000), noteType = Tell}]))-("10d6",(Nothing,[Note {noteSender = "soupdragon", noteContents = "", noteTime = (1274809408,952653000000), noteType = Tell}]))-("1300000d6",(Nothing,[Note {noteSender = "roconnor", noteContents = "", noteTime = (1243308045,49710000000), noteType = Tell}]))-("1d2",(Nothing,[Note {noteSender = "shepheb", noteContents = "", noteTime = (1270765117,287764000000), noteType = Tell}]))-("1d42",(Nothing,[Note {noteSender = "soupdragon", noteContents = "", noteTime = (1274809312,28668000000), noteType = Tell}]))-("2",(Nothing,[Note {noteSender = "roconnor", noteContents = "", noteTime = (1281402690,323149000000), noteType = Tell}]))-("6",(Nothing,[Note {noteSender = "jmcarthur", noteContents = "", noteTime = (1281998772,795390000000), noteType = Tell}]))-("?",(Nothing,[Note {noteSender = "dons", noteContents = "", noteTime = (1226294785,851959000000), noteType = Tell},Note {noteSender = "jnthn", noteContents = "", noteTime = (1238021728,464315000000), noteType = Tell}]))-("about",(Nothing,[Note {noteSender = "Jafet", noteContents = "awkward", noteTime = (1261725986,329110000000), noteType = Tell}]))-("akahige",(Nothing,[Note {noteSender = "twifkak", noteContents = "hehe, i bet you need to hit mod-shift-space to reset the layout. the config looks fine.", noteTime = (1226477584,255828000000), noteType = Tell}]))-("alester",(Just (1237050669,6146000000),[Note {noteSender = "masak", noteContents = "nice logo. in my browser, its background is white -- would it be possible to make it transparent?", noteTime = (1237023700,619227000000), noteType = Tell}]))-("andy753421",(Just (1259042211,827265000000),[Note {noteSender = "rob|", noteContents = "regarding your mouse button patch, did you check out experimental? we do have something very similar in there but with the ability to bind buttons to any action", noteTime = (1259004230,615685000000), noteType = Tell}]))-("arian",(Nothing,[Note {noteSender = "tizoc", noteContents = "te sacamos toda la ficha gil!", noteTime = (1258762604,729003000000), noteType = Tell}]))-("Arrgh`Check",(Nothing,[Note {noteSender = "RSchulz", noteContents = "out http://www.jetbrains.net/devnet/thread/289036", noteTime = (1276609676,257670000000), noteType = Tell}]))-("ask",(Nothing,[Note {noteSender = "nus", noteContents = "", noteTime = (1264847846,48993000000), noteType = Tell}]))-("Aww.",(Nothing,[Note {noteSender = "Baughn", noteContents = "You /agreed/ with making the indentation broken by default, too..", noteTime = (1282482897,752686000000), noteType = Tell}]))-("Baugn",(Nothing,[Note {noteSender = "ivanm", noteContents = "good-o", noteTime = (1279528162,785533000000), noteType = Tell}]))-("black",(Nothing,[Note {noteSender = "ivanm", noteContents = "wow, I didn't realise you were only 20! :p http://blacksapphire.com/letter-to-bush.html", noteTime = (1281003864,814562000000), noteType = Tell}]))-("BONUS",(Just (1282690459,469712000000),[Note {noteSender = "zygoloid", noteContents = "at the end of the 'Modules' section in LYAH you give the filenames cube.hs, cuboid.hs and sphere.hs. these need to start with captial letters!", noteTime = (1278679328,493936000000), noteType = Tell},Note {noteSender = "roconnor", noteContents = "do you know Andrej Bauer?", noteTime = (1280839206,983515000000), noteType = Ask}]))-("BONUS_",(Nothing,[Note {noteSender = "chrisdone", noteContents = "bump me", noteTime = (1266787958,976395000000), noteType = Tell}]))-("brimstone",(Just (1257884729,883725000000),[Note {noteSender = "Weredickie", noteContents = "Shhhhhh.....", noteTime = (1257883681,506600000000), noteType = Tell}]))-("bringert",(Just (1224261286,487280000000),[Note {noteSender = "kolmodin", noteContents = "har du n\229gon aning om hur l\228nge man f\229r ha kvar sin @dtek.c.se-adress efter examen?", noteTime = (1223732529,162582000000), noteType = Tell}]))-("byorgey",(Just (1276416364,825894000000),[Note {noteSender = "edwardk", noteContents = "i may wind up adopting your functional convex hull trick for some generalized taylor models", noteTime = (1276357709,609603000000), noteType = Tell}]))-("CakeProphet",(Just (1278961661,432218000000),[Note {noteSender = "quicksilver", noteContents = "you use @tell", noteTime = (1278931541,18767000000), noteType = Tell}]))-("cdsmithus",(Nothing,[Note {noteSender = "quicksilver", noteContents = "IsAOrBButNotC x => WidgetType x; you can probably think of a good name for the class. There must be some *reason* why it can be A or B but not C, and that reason can probably be made into a class.", noteTime = (1281946178,431562000000), noteType = Tell}]))-("cgizmo",(Nothing,[Note {noteSender = "bremner", noteContents = "that was two lines of Xdefault", noteTime = (1254843364,732058000000), noteType = Tell},Note {noteSender = "Botje", noteContents = "If you still have that program that ran out of fds (we discussed it yesterday), can you put the full version somewhere? I'm having difficulty reproducing it.", noteTime = (1256921889,719235000000), noteType = Tell}]))-("ChanServ",(Nothing,[Note {noteSender = "gonz", noteContents = "Boton", noteTime = (1225995464,430302000000), noteType = Tell}]))-("che,",(Nothing,[Note {noteSender = "tizoc", noteContents = "est\195\161 m\195\161s barato que em amazon :\\ (y mir\195\161 el precio de lista en amazon, wtf mil d\195\179lares)", noteTime = (1242933396,466162000000), noteType = Tell}]))-("daf",(Nothing,[Note {noteSender = "Twey", noteContents = "Congratulations!", noteTime = (1255330270,160224000000), noteType = Tell}]))-("danielvf",(Just (1283996047,204662000000),[Note {noteSender = "ulope", noteContents = "some msg", noteTime = (1283996009,37311000000), noteType = Tell}]))-("dccouts",(Nothing,[Note {noteSender = "MarcWeber", noteContents = "In which way do hackport and cabal-install handle flags?", noteTime = (1239678367,9442000000), noteType = Tell}]))-("doc_bolle",(Nothing,[Note {noteSender = "lispy", noteContents = "I'll happily mention your thesis, but I couldn't find it", noteTime = (1227740925,72727000000), noteType = Tell}]))-("dons.",(Nothing,[Note {noteSender = "Lemmih", noteContents = "Yes, I read it. It is a subset of closed world grin. It seems to be half way between the implicit laziness of core and explicit thunk layout of grin.", noteTime = (1243137226,122642000000), noteType = Tell}]))-("drdozer",(Just (1271960510,178580000000),[Note {noteSender = "Apocalisp", noteContents = "Pure[F] just provides a function (A => F[A]) for all A. Think of putting a value in a container, e.g. creating a singleton list (A => List[A]), the Some constructor for Option (A => Option[A]), or the constant function ([A,B] (a: A) => (b: B) => a): (A => B => A). Pointed is just Functor with Pure.", noteTime = (1271889987,528470000000), noteType = Tell}]))-("ebering",(Nothing,[Note {noteSender = "dbelange", noteContents = "dicks", noteTime = (1268693988,499599000000), noteType = Tell}]))-("elpolillla",(Nothing,[Note {noteSender = "tizoc", noteContents = "ya se porque es el \"jaja\", es para no poner \"xD\"", noteTime = (1226023882,744897000000), noteType = Tell}]))-("ezyang",(Nothing,[Note {noteSender = "benmachine", noteContents = "hey, remind me to talk to you about the SRCF (although I might not be around for a few days)", noteTime = (1285897874,239737000000), noteType = Tell}]))-("finanalyst",(Just (1241767176,462044000000),[Note {noteSender = "ruoso", noteContents = "run \"make CORE\" (I suspect make all is missing a dependency on CORE)", noteTime = (1238519443,963578000000), noteType = Tell}]))-("fish_xmonad",(Nothing,[Note {noteSender = "asgaroth", noteContents = "perhaps your haskell x11-bindings are too old", noteTime = (1237061596,598917000000), noteType = Tell}]))-("flintf",(Just (1281341420,466806000000),[Note {noteSender = "islands", noteContents = "hello", noteTime = (1281341389,301864000000), noteType = Tell}]))-("for",(Nothing,[Note {noteSender = "azawawi", noteContents = "a testcase try 'perl t/00-syntax.t' in $PUGS_HOME/misc/Syntax*", noteTime = (1229892110,471962000000), noteType = Tell}]))-("frwmanners",(Nothing,[Note {noteSender = "Baughn", noteContents = "[..no version of filterE could work with...] <-- Could you expand on this?", noteTime = (1243190790,684486000000), noteType = Tell}]))-("FUJISAN",(Just (1274720159,547442000000),[Note {noteSender = "Axman6", noteContents = "haha, thanks for the link, i feel kind of honoured, even if it is linkinus :P", noteTime = (1274614536,739982000000), noteType = Tell}]))-("gauss",(Nothing,[Note {noteSender = "mmorrow", noteContents = "kthx", noteTime = (1256902976,603740000000), noteType = Tell}]))-("Generating",(Nothing,[Note {noteSender = "Lemmih", noteContents = "LLVM IR directly should also alleviate any problems you had on Mac.", noteTime = (1243674675,518577000000), noteType = Tell}]))-("ghc-updater",(Nothing,[Note {noteSender = "kolmodin", noteContents = "finds the directory /usr/lib64/ghc-6.10.1 amongst all other ghc directories it finds", noteTime = (1230056907,593949000000), noteType = Tell}]))-("gilimanjaro",(Nothing,[Note {noteSender = "mberends", noteContents = "Hallo Gilion, kijk even in je email voor wat IRC tips en trucs!", noteTime = (1239550977,868618000000), noteType = Tell}]))-("god",(Nothing,[Note {noteSender = "ben_m", noteContents = "\"Why exactly 42?\"", noteTime = (1257180415,151928000000), noteType = Ask}]))-("Gracenotes",(Just (1269026062,765891000000),[Note {noteSender = "edwardk", noteContents = "the haskell-soc wiki seems to be broken. if you don't already have an account, I can't make you one, at the moment. If you want to register, send me your full name and email. In the meantime, I'll follow up and see what the status is on getting it fixed.", noteTime = (1269025997,167776000000), noteType = Tell}]))-("green",(Just (1261356400,336531000000),[Note {noteSender = "sereven", noteContents = "try turning off num lock to enable grid select key nav -- should be fixed in darcs soon (today is 19 Oct)", noteTime = (1255949372,801708000000), noteType = Tell}]))-("green_",(Nothing,[Note {noteSender = "sereven", noteContents = "For now, make sure numLock, etc. are off to have key navigation in grid select.", noteTime = (1255949721,228199000000), noteType = Tell}]))-("Guest10026",(Nothing,[Note {noteSender = "luqui", noteContents = "Thanks for the bug report. Fixed!", noteTime = (1264517255,886795000000), noteType = Tell}]))-("gunnarahlberg",(Nothing,[Note {noteSender = "vav", noteContents = "If you can idle longer in irc someone may be able to help real time. See Actions.CopyWindow (keybind copyToAll is simplest way, but could with some work use in manageHook too) Hooks.UrgencyHook has some notification tools, but pidgin might have notify plugin to use with libNotify too, or some people grep logs and put them into dzen slave lines, osd_cat, or notify-send.", noteTime = (1252958239,448553000000), noteType = Tell}]))-("haskellbot",(Just (1277180249,993045000000),[Note {noteSender = "jbapple", noteContents = "@tell lambdabot", noteTime = (1277180241,187154000000), noteType = Tell}]))-("hello?",(Nothing,[Note {noteSender = "scan", noteContents = "", noteTime = (1264560017,421344000000), noteType = Tell}]))-("help",(Nothing,[Note {noteSender = "Phyx-", noteContents = "", noteTime = (1272054093,575273000000), noteType = Ask}]))-("hey,",(Nothing,[Note {noteSender = "chessguy", noteContents = "out of curiousity, do you have any examples of using your astar hackage lying around?", noteTime = (1234627123,79317000000), noteType = Tell}]))-("hicks`",(Nothing,[Note {noteSender = "sereven", noteContents = "if you pastebin xmonad.hs and can idle in channel a little while someone can check for problems and perhaps help.", noteTime = (1253394044,196266000000), noteType = Tell}]))-("how",(Just (1279827211,378450000000),[Note {noteSender = "pmurias", noteContents = "should i checkout the smopp5?", noteTime = (1227436985,494985000000), noteType = Tell}]))-("Igloo",(Just (1280968308,80911000000),[Note {noteSender = "benmachine", noteContents = "does th-lift have a source repository, or any work more recent than version 0.3 on hackage? I was planning to extend it with newtype/record constructor support", noteTime = (1280411070,870096000000), noteType = Ask},Note {noteSender = "lispy", noteContents = "do you know if there is a policy on c.h.org about how/when to upgrade software. Do I just email support@c.h.o?", noteTime = (1280968241,138118000000), noteType = Tell}]))-("in",(Nothing,[Note {noteSender = "lilac", noteContents = "the glory", noteTime = (1232047714,417870000000), noteType = Ask}]))-("ivman",(Nothing,[Note {noteSender = "mpiechotka", noteContents = "Is it possible to update of ebuild of haskell-updater to depends on 7.0.x not only 6.12.x?", noteTime = (1285593554,512590000000), noteType = Tell}]))-("j3camero",(Nothing,[Note {noteSender = "Zaphus", noteContents = "Put me down as a committer, I can't promise I'll do it (damn, will need to install SVN too won't I) but some small improvements might come from me if I get the time :-)", noteTime = (1283997121,247316000000), noteType = Tell},Note {noteSender = "jmcarthur", noteContents = "coventry wants to know if he's allowed to use custom C extension modules in his python submission. this seems to me to be equivalent to allowing arbitrary binaries, which you know i would like to see as well :)", noteTime = (1284048667,234429000000), noteType = Ask},Note {noteSender = "jmcarthur", noteContents = "coventry reports that there are ssh keys in planet_wars/backend, including private ones. i'm not sure what's up with that", noteTime = (1284050821,26364000000), noteType = Tell},Note {noteSender = "jmcarthur", noteContents = "does the server have kvm and does the install qemu use it? it would be much faster for the sandboxes than plain qemu", noteTime = (1284051389,347590000000), noteType = Ask}]))-("ja_ordent",(Just (1274068569,287609000000),[Note {noteSender = "aavogt", noteContents = "you only have to change xmonad.hs, where you can use the layout mouseResizableTile{ draggerType = BordersDragger }", noteTime = (1272575395,922769000000), noteType = Tell}]))-("jcpetruzz",(Nothing,[Note {noteSender = "nominolo", noteContents = "here's a small snippet of transition guide: http://hpaste.org/11076", noteTime = (1223747840,840565000000), noteType = Tell}]))-("jfreddet",(Nothing,[Note {noteSender = "ivanm", noteContents = "yay for line endings! boo for sending three times :p", noteTime = (1254024107,848368000000), noteType = Tell}]))-("jfredett",(Nothing,[Note {noteSender = "ivanm", noteContents = "there, I've provided you with more content for the next HWN; happy now? :p", noteTime = (1268135399,478687000000), noteType = Tell}]))-("jhowitz",(Nothing,[Note {noteSender = "slavik1", noteContents = "give me mod_perl6 or give me death! I would really like the former though. :)", noteTime = (1236445861,916204000000), noteType = Tell}]))-("JoeyA",(Nothing,[Note {noteSender = "ski", noteContents = "would `Applicative DB', together with things like `(.==.) :: DB (a -> a -> Bool)' be any more sensible ?", noteTime = (1285826425,495375000000), noteType = Ask}]))-("johngoerzen",(Nothing,[Note {noteSender = "vegai", noteContents = "Hey. You mentioned in August wanting to build an imap library", noteTime = (1227347415,424271000000), noteType = Tell},Note {noteSender = "vegai", noteContents = "Have you got any code yet?", noteTime = (1227347434,422437000000), noteType = Tell}]))-("juhp",(Nothing,[Note {noteSender = "ManateeLazyCat", noteContents = "I have push new patches to gio and manatee. From now, except bug, I won't touch gtk2hs code.... enjoy! :)", noteTime = (1285561309,333553000000), noteType = Tell}]))-("jyp",(Nothing,[Note {noteSender = "ivanm", noteContents = "are you going to make a new hgal version with those 4 patches? I actually _might_ have a use for the vertex colouring aspect...", noteTime = (1239099756,122265000000), noteType = Ask}]))-("kaizoku",(Just (1228900322,616823000000),[Note {noteSender = "dcoutts", noteContents = "we didn't mean that you had to leave, just asking to turn off the YARRR", noteTime = (1225705145,866729000000), noteType = Tell}]))-("kiit",(Nothing,[Note {noteSender = "sereven", noteContents = "to use xmonad-0.9 you might have to change preferred versions (there is some setting that says use lower versions) and enable multiverse or community repos in synaptics settings too.", noteTime = (1257864880,516655000000), noteType = Tell}]))-("koewy",(Nothing,[Note {noteSender = "mornfall", noteContents = "it might be a good idea to distribute some op privileges.", noteTime = (1264706001,135698000000), noteType = Tell}]))-("kolmodin",(Just (1284755769,775333000000),[Note {noteSender = "slyfox_", noteContents = "how about this one? http://slyfox.ath.cx:8080/~slyfox/haskell/ldflags-for-cabal.dpatch.txt", noteTime = (1283448455,115256000000), noteType = Tell},Note {noteSender = "ivanm", noteContents = "we going to delay bumping haddock until the bugs in the 2.8 branch are fixed?", noteTime = (1283504657,901960000000), noteType = Ask},Note {noteSender = "slyfox", noteContents = "https://bugs.gentoo.org/show_bug.cgi?id=242056", noteTime = (1283578408,497288000000), noteType = Tell},Note {noteSender = "ivanm", noteContents = "why mask QC-2.3 rather than making the deps on QC stricter?", noteTime = (1283745335,308345000000), noteType = Ask},Note {noteSender = "slyfox", noteContents = "we will likely have problems to stabilize 6.10.4 for ppc and sparc - they require gcc-4.1 (or we will have to rebuild them unregisterised. i can rebuild for sparc), but 6.12.3 is ok for them as they both switched to NCG", noteTime = (1284007717,170681000000), noteType = Tell},Note {noteSender = "ivanm", noteContents = "should we bump haddock to 2.8.1?", noteTime = (1284717404,130325000000), noteType = Ask},Note {noteSender = "ivanm", noteContents = "also, you OK with dev-haskell/jail being removed (which will let us get rid of monads-fd-0.0.0.1) ?", noteTime = (1284717989,773770000000), noteType = Ask}]))-("korstya",(Nothing,[Note {noteSender = "ManateeLazyCat", noteContents = "See http://paste2.org/get/713834 , source code you need to develop Webkit browser with gtk2hs, you need install uzbl first to compile this program, i think this solution can works on Windows. Bye, i need off now. :)", noteTime = (1268422025,437913000000), noteType = Tell}]))-("kowey,",(Nothing,[Note {noteSender = "C-Keen", noteContents = "no the tests that fail for me are hidden_conflict.sh issue157_rollback_conflict.sh issue279_get_extra.sh and pull.sh", noteTime = (1226228808,725215000000), noteType = Tell},Note {noteSender = "thorkilnaur", noteContents = "About tn9: Sorry to belabour this, but I don't get it: tn9 currently passes the configure step (which is one possible mystery, because HTTP is missing, as you say). And fails the build step because of the --count matter. I just want to understand this.", noteTime = (1237469207,950366000000), noteType = Tell}]))-("lucaspost",(Nothing,[Note {noteSender = "sereven", noteContents = "darcs version of xmobar has modified pipereader plugin that can handle eof -- uses this change: http://www.haskell.org/pipermail/xmonad/2009-March/007576.html", noteTime = (1257957988,988351000000), noteType = Tell}]))-("lunabot",(Just (1233856705,319338000000),[Note {noteSender = "sbahra", noteContents = "You smell funny", noteTime = (1233856698,278013000000), noteType = Tell}]))-("mae_",(Just (1241986793,938969000000),[Note {noteSender = "gwern", noteContents = "you ever finish the filestore blog entry? I await the feedback curiously!", noteTime = (1241986659,637138000000), noteType = Ask}]))-("malcomw",(Nothing,[Note {noteSender = "Alpounet", noteContents = "the gsoc wiki is being updated by edwardk but account registration seems to be locked ; i don't know if you are its official \"maintainer\" but ask you anyway if it could be possible to unlock it so that students can start putting themselves there, together with their ideas ? thanks !", noteTime = (1268361236,552756000000), noteType = Tell}]))-("manjunath",(Nothing,[Note {noteSender = "byorgey", noteContents = "Actually, when I get a round tuit, I am planning to put out an updated, standalone version of the Typeclassopedia", noteTime = (1268322017,16299000000), noteType = Tell}]))-("marcusU",(Nothing,[Note {noteSender = "Psy|", noteContents = "that's because Xcode needs to launch GDB which needs to enter the guts of your software to work", noteTime = (1260701774,503407000000), noteType = Tell}]))-("marrah",(Nothing,[Note {noteSender = "jsuereth", noteContents = "I'm getting the continuations plugin into scala-tools.org. Ping me when you're in, I think we need to discuss automatic inclusion of it", noteTime = (1268400099,778322000000), noteType = Tell}]))-("masaks",(Nothing,[Note {noteSender = "eric256", noteContents = "now i need a git tutorial!! ;)", noteTime = (1229890885,911591000000), noteType = Tell}]))-("mason",(Nothing,[Note {noteSender = "rob|", noteContents = "then paste 'o' -> <Ctrl>v (@bind <Ctrl>v = sh 'echo \"event INJECT_KEYCMD $(xclip -selection clipboard -o)\" > \"$4\"')", noteTime = (1259702768,913586000000), noteType = Tell}]))-("mathijsje",(Just (1281137968,306356000000),[Note {noteSender = "Botje", noteContents = "randoms geeft een oneindige lijst van random getallen", noteTime = (1280747220,521727000000), noteType = Tell}]))-("max",(Nothing,[Note {noteSender = "elpolilla", noteContents = "aguante maxy", noteTime = (1284380813,475195000000), noteType = Tell}]))-("McManiaC",(Just (1274305022,362268000000),[Note {noteSender = "ivanm", noteContents = "cool! Axman6 and I have been discussing using gloss to make plots (or just opengl proper)!", noteTime = (1274305008,663499000000), noteType = Tell}]))-("messages",(Nothing,[Note {noteSender = "Guenni", noteContents = "", noteTime = (1233929308,223155000000), noteType = Ask}]))-("meuna",(Nothing,[Note {noteSender = "dschoepe", noteContents = "you need to find out the hexadecimal value of the key with xev and use that instead of a name.", noteTime = (1239377753,73951000000), noteType = Tell},Note {noteSender = "vav", noteContents = "http://hackage.haskell.org/packages/archive/X11/1.4.5/doc/html/Graphics-X11-ExtraTypes-XorgDefault.html -- if you have recent (I think > 1.4.2) version of haskell-x11 those keys may be in `import Graphics.X11.ExtraTypes' (need Xorg name for them, i.e. xK_ogonek or what it really is)", noteTime = (1239390905,625742000000), noteType = Tell}]))-("misc/elfish/AST",(Nothing,[Note {noteSender = "pmurias", noteContents = "is supposed to contain the description of the IRx1 in Perl 6 as opposed to a strange \"DSL\"", noteTime = (1223717098,60453000000), noteType = Tell}]))-("mjheagle",(Nothing,[Note {noteSender = "vav", noteContents = "tint2 actually seems to work really well with dual monitors here (xmonad-0.9 using Ewmh and tint2-0.7.1) thanks for tip to try it out! Please pastebin xmonad.hs to see if maybe something's missing in your Ewmh setup.", noteTime = (1261172836,459814000000), noteType = Tell}]))-("mmorrow",(Nothing,[Note {noteSender = "aavogt", noteContents = "can lunabot import Control.Monad.Writer please?", noteTime = (1264472532,258505000000), noteType = Ask},Note {noteSender = "Saizan_", noteContents = "ohai, hpaste's DB is locked, please unlock, kthx ;)", noteTime = (1265297384,406730000000), noteType = Tell},Note {noteSender = "tibbe", noteContents = "hpaste.org is down", noteTime = (1271239133,515809000000), noteType = Tell}]))-("moritz",(Nothing,[Note {noteSender = "masak", noteContents = "ping from dtr2 who has trouble installing ilbot.", noteTime = (1230894634,525964000000), noteType = Tell},Note {noteSender = "skids", noteContents = "backlog, re: split", noteTime = (1239983300,422122000000), noteType = Tell},Note {noteSender = "pmichaud", noteContents = "my analysis of the xml parsing problem: http://nopaste.snit.ch/16427", noteTime = (1240952553,760602000000), noteType = Tell}]))-("nachof",(Nothing,[Note {noteSender = "elpolilla", noteContents = "pow(3, 10) == 30", noteTime = (1284402237,307870000000), noteType = Tell}]))-("ndm",(Nothing,[Note {noteSender = "gwern", noteContents = "so I was reading your supero paper and you mentioned ghc's isSpace function had a performance bug. was that ever fixed?", noteTime = (1239226105,267196000000), noteType = Ask},Note {noteSender = "ivanm", noteContents = "the link to the haddock docs for cmdargs on its homepage links to cs.york.blah (and doesn't work/exist)", noteTime = (1252756100,937351000000), noteType = Tell},Note {noteSender = "gwern", noteContents = "I was rereading http://neilmitchell.blogspot.com/2006/11/systemfilepath-automated-testing.html and I thought I'd mention in case you didn't know that I cabalized smallcheck a while ago", noteTime = (1254080425,534620000000), noteType = Tell},Note {noteSender = "Cale", noteContents = "I've found the following simple infix function really useful with TagSoup: ss /> f = ss >>= partitions f", noteTime = (1256045849,272383000000), noteType = Tell}]))-("nytek",(Nothing,[Note {noteSender = "dmwit", noteContents = "I recommend the \"Download Tab-bar\" extension. ...or using chromium ;-)", noteTime = (1269669828,639695000000), noteType = Tell}]))-("odp",(Nothing,[Note {noteSender = "jsuereth_work", noteContents = "Sorry stepped out for lunch. Nexus has some nice features other repository managers do not. It actually is integrating with p2 (if you care about eclipse). I actually use archiva at work though", noteTime = (1239642690,117480000000), noteType = Tell}]))-("Ok,",(Nothing,[Note {noteSender = "ManateeLazyCat", noteContents = "that's all template you need notice, if you have any problem, please ask in gtk2hs list. Good luck!", noteTime = (1284978366,128594000000), noteType = Tell}]))-("oxymor00n",(Nothing,[Note {noteSender = "ivanm", noteContents = "I notice on the emacs wiki that you were going to examine how to get gmail's \"All Mail\", etc. folders showing up in gnus... did you work anything out?", noteTime = (1237553263,772138000000), noteType = Ask}]))-("paczesiowa",(Just (1278849708,372259000000),[Note {noteSender = "ivanm", noteContents = "I was going to solve it by not having it compile anymore...", noteTime = (1278756398,281116000000), noteType = Tell},Note {noteSender = "ivanm", noteContents = "we can't use -dynamic by default since it only works with 6.12+ (though it might be possible to use an if statement to use that when it can be used), and we can't use the runhaskell approach by default since apparently some architectures don't support it :s", noteTime = (1278766224,467604000000), noteType = Tell}]))-("paolino",(Just (1255634369,769662000000),[Note {noteSender = "byorgey", noteContents = "http://hpaste.org/fastcgi/hpaste.fcgi/view?id=10787#a10789", noteTime = (1255633519,609386000000), noteType = Tell}]))-("pelotom",(Just (1269475947,688575000000),[Note {noteSender = "RSchulz", noteContents = "see scala.util.parsing.combinator.Parsers.positioned(...)", noteTime = (1269440831,949290000000), noteType = Tell}]))-("phreeza",(Just (1283957517,483913000000),[Note {noteSender = "jmcarthur", noteContents = "like this!", noteTime = (1283957508,36244000000), noteType = Tell}]))-("posta?",(Nothing,[Note {noteSender = "tizoc", noteContents = "do want, pasale mi mail para que me muestre que tiene", noteTime = (1244156978,318357000000), noteType = Tell}]))-("preflex",(Just (1228089783,224897000000),[Note {noteSender = "andrewsw", noteContents = "hi", noteTime = (1228089773,824689000000), noteType = Tell}]))-("pumpkinbot",(Just (1233854140,107829000000),[Note {noteSender = "ski_", noteContents = "@tell lambdabot hi", noteTime = (1233852234,396328000000), noteType = Tell}]))-("rapidlyEmptyingDiskSpace",(Nothing,[Note {noteSender = "Olathe", noteContents = "hello", noteTime = (1231386908,641774000000), noteType = Tell}]))-("retronym",(Just (1284958178,647305000000),[Note {noteSender = "dibblego", noteContents = "Scalala doesn't seem to build (sbt update fails getting junit-3.8.1)", noteTime = (1284942598,551470000000), noteType = Tell}]))-("romildo",(Nothing,[Note {noteSender = "kolmodin", noteContents = "so far no version of haddock has been released that works with ghc-7. and we disable the one that comes with ghc, as we want to allow the user to upgrade", noteTime = (1285776015,589144000000), noteType = Tell}]))-("RPS",(Nothing,[Note {noteSender = "Taejo", noteContents = "how're things going?", noteTime = (1232175988,774853000000), noteType = Tell}]))-("Rwerwe",(Just (1255105568,898595000000),[Note {noteSender = "allbery_b", noteContents = "you should ask in #haskell, not #haskell-overflow.", noteTime = (1255005806,330423000000), noteType = Tell}]))-("ryan[WIN]",(Just (1273014242,640287000000),[Note {noteSender = "sixthgear", noteContents = "apply http://www.bungie.net/Inside/jobs.aspx#job25768", noteTime = (1273012185,158129000000), noteType = Tell}]))-("SamB_XP",(Just (1232072266,847832000000),[Note {noteSender = "gwern", noteContents = "re long filenames in errors - with ghc 6.10 hint, the temp files aren't used at all (it was just a hack around a 6.8 bug) so I regard it as a moot issue not worth fixing", noteTime = (1231626040,678622000000), noteType = Tell}]))-("scalabot",(Just (1265743977,961453000000),[Note {noteSender = "JamesIry", noteContents = "\"you're so slow\"", noteTime = (1265735751,358444000000), noteType = Tell}]))-("schmooo",(Nothing,[Note {noteSender = "hgolden", noteContents = "please try https://bugs.gentoo.org/show_bug.cgi?id=299709 workaround and see if ghci works better (when compiling syb-with-class).", noteTime = (1281987993,536673000000), noteType = Tell}]))-("sclv",(Nothing,[Note {noteSender = "dons", noteContents = "truncate -> double2int via RULES in ghc 6.12.x", noteTime = (1279564893,132555000000), noteType = Tell}]))-("sebazzz",(Nothing,[Note {noteSender = "elpolilla", noteContents = "nos saliste falladito :S", noteTime = (1262958466,544438000000), noteType = Tell}]))-("secrets",(Nothing,[Note {noteSender = "islands", noteContents = "", noteTime = (1285710248,159897000000), noteType = Tell}]))-("seyday",(Nothing,[Note {noteSender = "DBAlex", noteContents = "hello!", noteTime = (1236200245,11263000000), noteType = Tell}]))-("sfvisser_",(Nothing,[Note {noteSender = "copumpkin", noteContents = "have you considered giving fclabels users the opportunity to provide their own update function, as well as the getters and setters? I have a situation in which I can perform an update more efficiently than a set + get", noteTime = (1283922488,558773000000), noteType = Ask}]))-("shapr",(Just (1285949071,439378000000),[Note {noteSender = "ivanm", noteContents = "in case you weren't aware: http://us.macmillan.com/Book.aspx?isbn=9781429920575", noteTime = (1285948028,115133000000), noteType = Tell}]))-("shapr,",(Nothing,[Note {noteSender = "jfredett", noteContents = "Just curious about logistics for tomorrow. let me know, email is jfredett@gmail.com", noteTime = (1235771914,997506000000), noteType = Tell}]))-("shepheb",(Nothing,[Note {noteSender = "ivanm", noteContents = "are the docs for XMonad.Util.Scratchpad complete? it doesn't seem to say how to use it...", noteTime = (1281263430,502678000000), noteType = Ask}]))-("sinelaw_",(Just (1261594461,771588000000),[Note {noteSender = "sinelaw", noteContents = "koko", noteTime = (1261594446,849069000000), noteType = Tell}]))-("skottish",(Nothing,[Note {noteSender = "dmwit", noteContents = "Use swapMaster in your manageHook. z-ordering is tied to stack ordering in xmonad (somewhat unfortunately).", noteTime = (1275794710,995293000000), noteType = Tell}]))-("smedge",(Nothing,[Note {noteSender = "dmwit", noteContents = "You're in the right place for Haskell critiques. You just have to hang around a bit longer after you ask your questions, especially late at (USA's) night.", noteTime = (1282370708,30724000000), noteType = Tell}]))-("smitty1e",(Nothing,[Note {noteSender = "sereven", noteContents = "In case you didn't work it out you'll probably have to keyword lots of haskell bits, cabal downgrade is probably cause not in package.keywords or whatever paludis uses (many use paludis, but not me, too lazy) ;)", noteTime = (1232875223,679383000000), noteType = Tell}]))-("So",(Nothing,[Note {noteSender = "ManateeLazyCat", noteContents = "you project like a real-time edit/execute editor?", noteTime = (1279124573,704716000000), noteType = Tell}]))-("Spockz",(Just (1264187542,293721000000),[Note {noteSender = "kosmikus|n900", noteContents = "had je niet gezegd dat caprica dit weekend komt?", noteTime = (1264187171,632171000000), noteType = Tell}]))-("ssalkin",(Nothing,[Note {noteSender = "dmwit", noteContents = "You can extract the package yourself (with tar or whatever), then modify it and run cabal install inside the unpacked directory (with no arguments).", noteTime = (1261355740,266088000000), noteType = Tell}]))-("stableable",(Nothing,[Note {noteSender = "sjanssen", noteContents = "xmonad doesn't support window groups at this time, but it would not be at all hard to add. See the docs for ManageHook", noteTime = (1233011526,668293000000), noteType = Tell}]))-("stoick",(Just (1243653110,956205000000),[Note {noteSender = "dibblego", noteContents = "@pl \\f g a -> f a || g a -- here is an example of flatMap and map being called on ||", noteTime = (1243653101,495200000000), noteType = Tell}]))-("test",(Nothing,[Note {noteSender = "s_denchev", noteContents = "", noteTime = (1283957731,241443000000), noteType = Ask}]))-("testing",(Nothing,[Note {noteSender = "DeathSkull", noteContents = "plox", noteTime = (1252996760,533439000000), noteType = Tell}]))-("thanks",(Nothing,[Note {noteSender = "abuiles", noteContents = "to you :).", noteTime = (1270554679,853775000000), noteType = Tell}]))-("tibbel",(Nothing,[Note {noteSender = "dons", noteContents = "http://gregorycollins.net/posts/2010/03/12/attoparsec-iteratee#comment-39671374 they're rolling their own epoll event manager", noteTime = (1268597465,660831000000), noteType = Tell}]))-("tmitt",(Just (1266573085,393259000000),[Note {noteSender = "dmwit", noteContents = "what video card you're using", noteTime = (1264740142,898607000000), noteType = Ask}]))-("trofi^w",(Just (1274261129,618451000000),[Note {noteSender = "ivanm", noteContents = "new xmobar ebuild (and improved live one) pushed!", noteTime = (1274260992,671709000000), noteType = Tell}]))-("trygvis",(Just (1240138794,36805000000),[Note {noteSender = "dibblego", noteContents = "I have moved branches/scalaz4 to trunk and altered the directory structure for maven", noteTime = (1240138727,750863000000), noteType = Tell}]))-("tutorial",(Nothing,[Note {noteSender = "Mathnerd314", noteContents = "", noteTime = (1269974922,103284000000), noteType = Tell},Note {noteSender = "Mathnerd314", noteContents = "", noteTime = (1269974986,516677000000), noteType = Ask}]))-("tux_rocker,",(Nothing,[Note {noteSender = "kowey", noteContents = "it's worth noting that darcs-roundup integration only works if you push < 20 patches at a time due to 1000K limit on posthook environment", noteTime = (1277729813,51967000000), noteType = Tell}]))-("vegai",(Just (1264495145,596425000000),[Note {noteSender = "dons", noteContents = "do you still follow arch-haskell@ ?", noteTime = (1264461808,722498000000), noteType = Tell}]))-("what",(Nothing,[Note {noteSender = "slyfox", noteContents = "do you think about splittig ghc-wrapper to another package? (maybe, with 'eselect' feature) then we could play easier with stuff like this: http://slyfox.ath.cx:8080/~slyfox/ghc/ghc.sh.txt", noteTime = (1283403195,160258000000), noteType = Ask}]))-("xmonoob",(Nothing,[Note {noteSender = "asfethan", noteContents = "use .xinitrc or spawn in xmonad.hs for auto-start and W.shift by className, or other window parameters to move windows to another workspace...", noteTime = (1265628262,952008000000), noteType = Tell}]))-("yurinotigor",(Nothing,[Note {noteSender = "mmorrow", noteContents = "here're some useful haskell-src-exts functions http://hpaste.org/fastcgi/hpaste.fcgi/view?id=5512", noteTime = (1243990237,476330000000), noteType = Tell}]))-("zekus",(Nothing,[Note {noteSender = "dmwit", noteContents = "You can ignore that error. However, don't \"exec\" xmonad. Don't background it, either. Just run it normally at the end of your .xinitrc.", noteTime = (1229987338,36629000000), noteType = Tell}]))-("zooko,",(Nothing,[Note {noteSender = "C-Keen", noteContents = "sorry for this :)", noteTime = (1226436517,676473000000), noteType = Tell}]))-("zygoloid,",(Nothing,[Note {noteSender = "luqui", noteContents = "thanks, known bug, we can't reproduce it, which makes it very hard to debug.", noteTime = (1264511793,961023000000), noteType = Tell}]))-("[1,",(Nothing,[Note {noteSender = "Tinned_Tuna", noteContents = "2, 3]", noteTime = (1253050775,857464000000), noteType = Tell}]))-("_Ray_.",(Nothing,[Note {noteSender = "hgolden", noteContents = "FYI, here's a simpler searchLongest: http://hpaste.org/fastcgi/hpaste.fcgi/view?id=11376#a11495", noteTime = (1257223811,825870000000), noteType = Tell}]))-("member:revenantphx",(Nothing,[Note {noteSender = "revenantphx_", noteContents = "you are one handsome gentleman", noteTime = (1283662806,473563000000), noteType = Tell}]))
− State/todo

binary file changed (1328 → absent bytes)

− State/url 
@@ -1,1 +0,0 @@-True
− State/where

binary file changed (11595 → absent bytes)

lambdabot.cabal view
@@ -1,74 +1,219 @@-Name:                lambdabot-Version:             4.2.3.3-License:             GPL-License-file:        LICENSE-Author:              Don Stewart-Maintainer:          Cale Gibbard <cgibbard@gmail.com>-Category:            Development, Web-Synopsis:            Lambdabot is a development tool and advanced IRC bot-Description:         Lambdabot is an IRC bot written over several years by-                     those on the #haskell IRC channel.-                     .-                     It operates as a command line tool, embedded in an editor,-                     embedded in GHCi, via internet relay chat and on the web.-Homepage:            http://haskell.org/haskellwiki/Lambdabot+name:                   lambdabot+version:                4.3 -build-type:          Simple-cabal-version:       >= 1.6+license:                GPL+license-file:           LICENSE -extra-source-files: Modules.hs-boot, State/imports.h, Plugin/Hello.hs, Modules.hs-data-files:         State/djinn, State/url, State/haddock, State/source,-                    State/L.hs, State/seen, State/state, State/Pristine.hs,-                    State/poll, State/quote, State/todo, State/vixen,-                    State/fresh, State/tell, State/system, State/where,-                    State/karma, State/fact,-                    -- Needed for @type-                    State/imports.h,-                    online.rc, online2.rc+author:                 Don Stewart+maintainer:             James Cook <mokus@deepbondi.net> --- flag eval---     description: Use mueval to evaluate pure Haskell expressions at runtime+category:               Development, Web+synopsis:               Lambdabot is a development tool and advanced IRC bot+description:            Lambdabot is an IRC bot written over several years by+                        those on the #haskell IRC channel.+                        .+                        It operates as a command line tool, embedded in an editor,+                        embedded in GHCi, via internet relay chat and on the web. -Library-    build-depends: base == 4.*, mtl>2, bytestring, unix, filepath-    exposed-modules: Config, IRCBase, File,-                     LBState, LMain, Lambdabot, Message,-                     NickEq, Plugin, Plugin.Activity, Plugin.BF,-                     Plugin.Babel, Plugin.Base, Plugin.Check, Plugin.Code, Plugin.Compose,-                     Plugin.DarcsPatchWatch, Plugin.Dice, Plugin.Dict, Plugin.Dict.DictLookup, Plugin.Djinn,-                     Plugin.Dummy, Plugin.Dummy.DocAssocs, Plugin.Dynamic, Plugin.Elite, Plugin.Eval,-                     Plugin.FT, Plugin.Fact, Plugin.Filter, Plugin.Free, Plugin.Free.Expr,-                     Plugin.Free.FreeTheorem, Plugin.Free.Parse, Plugin.Free.Test, Plugin.Free.Theorem, Plugin.Free.Type,-                     Plugin.Free.Util, Plugin.Fresh, Plugin.Haddock, Plugin.Help,-                     Plugin.Hoogle, Plugin.IRC, Plugin.Instances, Plugin.Karma, Plugin.Localtime,-                     Plugin.Log, Plugin.More, Plugin.OEIS, Plugin.OfflineRC,-                     Plugin.Pl, Plugin.Pl.Common, Plugin.Pl.Names, Plugin.Pl.Optimize, Plugin.Pl.Parser,-                     Plugin.Pl.PrettyPrinter, Plugin.Pl.RuleLib, Plugin.Pl.Rules, Plugin.Pl.Transform,-                     Plugin.Pointful, Plugin.Poll, Plugin.Pretty, Plugin.Quote, Plugin.Quote.Fortune,-                     Plugin.Quote.Text, Plugin.Search, Plugin.Seen, Plugin.Slap, Plugin.Scheck-                     Plugin.Source, Plugin.Spell, Plugin.State, Plugin.System, Plugin.Tell,-                     Plugin.Ticker, Plugin.Todo, Plugin.Topic, Plugin.Type, Plugin.UnMtl,-                     Plugin.Undo, Plugin.Unlambda, Plugin.Url, Plugin.Version, Plugin.Vixen,-                     Plugin.Where, Shared-    ghc-options: -fno-warn-missing-methods-    buildable:   False+homepage:               http://haskell.org/haskellwiki/Lambdabot --- Lambdabot main-Executable          lambdabot-    Build-depends:       base == 4.*, containers, directory, pretty, parsec, old-time, random, array, network, syb,-                         unix, mtl>2, bytestring, regex-compat, readline, binary>0.2, haskell-src, haskell-src-exts>=0.4.8,-                         oeis>=0.2, lambdabot-utils, show>=0.3, utf8-string, template-haskell, filepath, tagsoup, HTTP,-                         -- runtime dependencies - for eval etc.-                         brainfuck, unlambda, template-haskell, numbers, logict>=0.4.2, IOSpec, vector-space, MonadRandom,-                         data-memocombinators, arrows-    -- if flag(eval)-    --     Build-depends: mueval>=0.8+build-type:             Simple+cabal-version:          >= 1.8+tested-with:            GHC==7.4.1, GHC == 7.6.3 -    Main-is:             Main.hs-    -- For a faster build, use -Onot-    extensions:          FlexibleInstances-    ghc-options:         -funbox-strict-fields -fno-warn-incomplete-patterns-                         -fno-warn-missing-methods -fno-warn-orphans-                         -- Apparently needed to work around zombie & IRC connection issues-                         -threaded-    include-dirs:        .+extra-source-files:     AUTHORS.md+                        COMMANDS+                        COMMENTARY.md+                        README.md+                        main/Modules.hs+                        scripts/ghci.sh+                        scripts/vim/bot+                        scripts/vim/pl+                        scripts/vim/README+                        scripts/vim/run+                        scripts/vim/runwith+                        scripts/vim/typeOf+                        src/Lambdabot/Plugin/Free/Test.hs++data-files:             scripts/online.rc,+                        State/djinn,+                        State/haddock,+                        State/L.hs,+                        State/Pristine.hs,+                        State/source,+                        State/vixen++source-repository head+  type:                 git+  location:             https://github.com/mokus0/lambdabot.git++library+  hs-source-dirs:       src+  ghc-options:          -Wall+                        -funbox-strict-fields++  exposed-modules:      Lambdabot+                        Lambdabot.ChanName+                        Lambdabot.Command+                        Lambdabot.Compat.AltTime+                        Lambdabot.Compat.FreenodeNick+                        Lambdabot.Compat.PackedNick+                        Lambdabot.Config+                        Lambdabot.Config.Core+                        Lambdabot.File+                        Lambdabot.IRC+                        Lambdabot.Logging+                        Lambdabot.Main+                        Lambdabot.Message+                        Lambdabot.Module+                        Lambdabot.Monad+                        Lambdabot.Nick+                        Lambdabot.NickEq+                        Lambdabot.OutputFilter+                        Lambdabot.Plugin+                        Lambdabot.Plugin.Activity+                        Lambdabot.Plugin.Base+                        Lambdabot.Plugin.BF+                        Lambdabot.Plugin.Check+                        Lambdabot.Plugin.Check.ShowQ+                        Lambdabot.Plugin.Compose+                        Lambdabot.Plugin.Dice+                        Lambdabot.Plugin.Dict+                        Lambdabot.Plugin.Djinn+                        Lambdabot.Plugin.Dummy+                        Lambdabot.Plugin.Elite+                        Lambdabot.Plugin.Error+                        Lambdabot.Plugin.Eval+                        Lambdabot.Plugin.Eval.Trusted+                        Lambdabot.Plugin.Filter+                        Lambdabot.Plugin.Free+                        Lambdabot.Plugin.Fresh+                        Lambdabot.Plugin.Haddock+                        Lambdabot.Plugin.Hello+                        Lambdabot.Plugin.Help+                        Lambdabot.Plugin.Hoogle+                        Lambdabot.Plugin.Instances+                        Lambdabot.Plugin.IRC+                        Lambdabot.Plugin.Karma+                        Lambdabot.Plugin.Localtime+                        Lambdabot.Plugin.Log+                        Lambdabot.Plugin.More+                        Lambdabot.Plugin.Numberwang+                        Lambdabot.Plugin.OEIS+                        Lambdabot.Plugin.OfflineRC+                        Lambdabot.Plugin.Pl+                        Lambdabot.Plugin.Pointful+                        Lambdabot.Plugin.Poll+                        Lambdabot.Plugin.Pretty+                        Lambdabot.Plugin.Quote+                        Lambdabot.Plugin.Search+                        Lambdabot.Plugin.Seen+                        Lambdabot.Plugin.Slap+                        Lambdabot.Plugin.Source+                        Lambdabot.Plugin.Spell+                        Lambdabot.Plugin.Stats+                        Lambdabot.Plugin.System+                        Lambdabot.Plugin.Tell+                        Lambdabot.Plugin.Ticker+                        Lambdabot.Plugin.Todo+                        Lambdabot.Plugin.Topic+                        Lambdabot.Plugin.Type+                        Lambdabot.Plugin.Undo+                        Lambdabot.Plugin.Unlambda+                        Lambdabot.Plugin.UnMtl+                        Lambdabot.Plugin.Url+                        Lambdabot.Plugin.Version+                        Lambdabot.Plugin.Vixen+                        Lambdabot.Plugin.Where+                        Lambdabot.State+                        Lambdabot.Util+                        Lambdabot.Util.Browser+                        Lambdabot.Util.Parser+                        Lambdabot.Util.Process+                        Lambdabot.Util.Serial+                        Lambdabot.Util.Signals++  other-modules:        Paths_lambdabot+                        Lambdabot.Plugin.Dict.DictLookup+                        Lambdabot.Plugin.Dummy.DocAssocs+                        Lambdabot.Plugin.Free.Expr+                        Lambdabot.Plugin.Free.FreeTheorem+                        Lambdabot.Plugin.Free.Parse+                        Lambdabot.Plugin.Free.Theorem+                        Lambdabot.Plugin.Free.Type+                        Lambdabot.Plugin.Free.Util+                        Lambdabot.Plugin.Pl.Common+                        Lambdabot.Plugin.Pl.Names+                        Lambdabot.Plugin.Pl.Optimize+                        Lambdabot.Plugin.Pl.Parser+                        Lambdabot.Plugin.Pl.PrettyPrinter+                        Lambdabot.Plugin.Pl.RuleLib+                        Lambdabot.Plugin.Pl.Rules+                        Lambdabot.Plugin.Pl.Transform+                        Lambdabot.Plugin.Seen.StopWatch+                        Lambdabot.Plugin.Seen.UserStatus++  build-depends:        array                   >= 0.4,+                        base                    >= 4.4,+                        binary                  >= 0.5,+                        bytestring              >= 0.9,+                        containers              >= 0.4,+                        dependent-map           == 0.1.*,+                        dependent-sum           == 0.2.*,+                        dependent-sum-template  >= 0.0.0.1,+                        dice                    >= 0.1,+                        directory               >= 1.1,+                        edit-distance           >= 0.2,+                        filepath                >= 1.3,+                        haskeline               >= 0.7,+                        haskell-src-exts        >= 1.12.0,+                        hstatsd                 >= 0.1,+                        hslogger                >= 1.2.1,+                        HTTP                    >= 4000,+                        lifted-base             >= 0.2,+                        misfortune              >= 0.1,+                        monad-control           >= 0.3,+                        mtl                     >= 2,+                        network                 >= 2.3.0.13,+                        oeis                    >= 0.3.1,+                        time                    >= 1.4,+                        parsec                  >= 3,+                        pretty                  >= 1.1,+                        process                 >= 1.1,+                        QuickCheck              >= 2,+                        random                  >= 1,+                        random-fu               >= 0.2,+                        random-source           >= 0.3,+                        regex-tdfa              >= 1.1,+                        SafeSemaphore           >= 0.9,+                        show                    >= 0.4,+                        split                   >= 0.2,+                        syb                     >= 0.3,+                        tagsoup                 >= 0.12,+                        template-haskell        >= 2.7,+                        transformers            >= 0.2,+                        transformers-base       >= 0.4,+                        unix                    >= 2.5,+                        utf8-string             >= 0.3,+                        zlib                    >= 0.5,++                        -- runtime dependencies - for eval etc.+                        arrows                  >= 0.4,+                        brainfuck               == 0.1,+                        data-memocombinators    >= 0.4,+                        hoogle                  >= 4.2,+                        IOSpec                  >= 0.2,+                        logict                  >= 0.5,+                        MonadRandom             >= 0.1,+                        mueval                  >= 0.9,+                        numbers                 >= 3000,+                        unlambda                >= 0.1,+                        vector-space            >= 0.8++executable lambdabot+  hs-source-dirs:       main+  main-is:              Main.hs++  ghc-options:          -Wall -threaded+  build-depends:        base                 >= 3 && < 5,+                        lambdabot
+ main/Main.hs view
@@ -0,0 +1,63 @@+--+-- | Let's go lambdabot!+--+module Main where++import Lambdabot.Main+import Modules      (modulesInfo)++import Control.Applicative+import Control.Monad+import Data.Char+import Data.Version+import System.Console.GetOpt+import System.Environment+import System.Exit+import System.IO++flags :: [OptDescr (IO (DSum Config))]+flags = +    [ Option "h?" ["help"]  (NoArg (usage []))                      "Print this help message"+    , Option "e"  []        (arg "<command>" onStartupCmds   strs)  "Run a lambdabot command instead of a REPL"+    , Option "l"  []        (arg "<level>"   consoleLogLevel level) "Set the logging level"+    , Option "t"  ["trust"] (arg "<package>" trustedPackages strs)  "Trust the specified packages when evaluating code"+    ] where +        arg :: String -> Config t -> (String -> IO t) -> ArgDescr (IO (DSum Config))+        arg descr key fn = ReqArg (fmap (key :=>) . fn) descr+        +        strs = return . (:[])+        +        level str = case reads (map toUpper str) of+            (lv, []):_ -> return lv+            _          -> usage+                [ "Unknown log level."+                , "Valid levels are: " ++ show [DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY]+                ]+                +                ++usage :: [String] -> IO a+usage errors = do+    cmd <- getProgName+    +    let isErr = not (null errors)+        out = if isErr then stderr else stdout+    +    mapM_ (hPutStrLn out) errors+    when isErr (hPutStrLn out "")+    +    hPutStrLn out ("lambdabot " ++ showVersion lambdabotVersion)+    hPutStr   out (usageInfo (cmd ++ " [options]") flags)+    +    exitWith (if isErr then ExitFailure 1 else ExitSuccess)++-- do argument handling+main :: IO ()+main = do+    (config, nonOpts, errors) <- getOpt Permute flags <$> getArgs+    when (not (null errors && null nonOpts)) (usage errors)+    exitWith =<< lambdabotMain modulesInfo =<< sequence config++-- special online target for ghci use+online :: [String] -> IO ()+online strs = void (lambdabotMain modulesInfo [onStartupCmds :=> strs])
+ main/Modules.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE TemplateHaskell #-}++module Modules (modulesInfo) where++import Data.List+import Lambdabot.Main++-- to add a new plugin, one must first add a qualified import here, and also+-- add a string in the list below+import qualified Lambdabot.Plugin.Activity+import qualified Lambdabot.Plugin.Base+import qualified Lambdabot.Plugin.BF+import qualified Lambdabot.Plugin.Check+import qualified Lambdabot.Plugin.Compose+import qualified Lambdabot.Plugin.Dice+import qualified Lambdabot.Plugin.Dict+import qualified Lambdabot.Plugin.Djinn+import qualified Lambdabot.Plugin.Dummy+import qualified Lambdabot.Plugin.Elite+import qualified Lambdabot.Plugin.Eval+import qualified Lambdabot.Plugin.Filter+import qualified Lambdabot.Plugin.Free+import qualified Lambdabot.Plugin.Fresh+import qualified Lambdabot.Plugin.Haddock+import qualified Lambdabot.Plugin.Help+import qualified Lambdabot.Plugin.Hoogle+import qualified Lambdabot.Plugin.Instances+import qualified Lambdabot.Plugin.IRC+import qualified Lambdabot.Plugin.Karma+import qualified Lambdabot.Plugin.Localtime+import qualified Lambdabot.Plugin.More+import qualified Lambdabot.Plugin.OEIS+import qualified Lambdabot.Plugin.OfflineRC+import qualified Lambdabot.Plugin.Pl+import qualified Lambdabot.Plugin.Pointful+import qualified Lambdabot.Plugin.Poll+import qualified Lambdabot.Plugin.Pretty+import qualified Lambdabot.Plugin.Quote+import qualified Lambdabot.Plugin.Search+import qualified Lambdabot.Plugin.Seen+import qualified Lambdabot.Plugin.Slap+import qualified Lambdabot.Plugin.Source+import qualified Lambdabot.Plugin.Spell+import qualified Lambdabot.Plugin.System+import qualified Lambdabot.Plugin.Tell+import qualified Lambdabot.Plugin.Ticker+import qualified Lambdabot.Plugin.Todo+import qualified Lambdabot.Plugin.Topic+import qualified Lambdabot.Plugin.Type+import qualified Lambdabot.Plugin.Undo+import qualified Lambdabot.Plugin.Unlambda+import qualified Lambdabot.Plugin.UnMtl+import qualified Lambdabot.Plugin.Url+import qualified Lambdabot.Plugin.Version+import qualified Lambdabot.Plugin.Vixen+import qualified Lambdabot.Plugin.Where++modulesInfo :: Modules+modulesInfo = $(modules $ nub+                    -- these must be listed first.  Maybe.  Nobody really+                    -- knows, but better to be safe than sorry.+                    [ "Base"+                    , "System"+                    , "OfflineRC"++                    -- plugins also go in this list:+                    , "Activity"+                    , "BF"+                    , "Check"+                    , "Compose"+                    , "Dice"+                    , "Dict"+                    , "Djinn"+                    , "Dummy"+                    , "Elite"+                    , "Eval"+                    , "Filter"+                    , "Free"+                    , "Fresh"+                    , "Haddock"+                    , "Help"+                    , "Hoogle"+                    , "Instances"+                    , "IRC"+                    , "Karma"+                    , "Localtime"+                    , "More"+                    , "OEIS"+                    , "Pl"+                    , "Pointful"+                    , "Poll"+                    , "Pretty"+                    , "Quote"+                    , "Search"+                    , "Seen"+                    , "Slap"+                    , "Source"+                    , "Spell"+                    , "Tell"+                    , "Ticker"+                    , "Todo"+                    , "Topic"+                    , "Type"+                    , "Undo"+                    , "Unlambda"+                    , "UnMtl"+                    , "Url"+                    , "Version"+                    , "Vixen"+                    , "Where"+                    ])
− online.rc 
@@ -1,54 +0,0 @@-irc-connect freenode chat.freenode.net 6667 lambdabot Lambda_Robots:_100%_Loyal-rc passwd.rc-admin + freenode:Cale-admin + freenode:Igloo-admin + freenode:Lemmih-admin + freenode:Pseudonym-admin + freenode:mauke-admin + freenode:dons-admin + freenode:gwern-admin + freenode:igli-admin + freenode:int-e-admin + freenode:musasabi-admin + freenode:shapr-admin + freenode:sjanssen-admin + freenode:sorear-admin + freenode:vincenz-join freenode:##logic-join freenode:#arch-haskell-join freenode:#darcs-join freenode:#debian-es-join freenode:#dreamlinux-es-join freenode:#friendly-coders-join freenode:#gentoo-haskell-join freenode:#gentoo-uy-join freenode:#ghc-join freenode:#happs-join freenode:#haskell-join freenode:#haskell-blah-join freenode:#haskell-books-join freenode:#haskell-hac07-join freenode:#haskell-overflow-join freenode:#haskell-soc-join freenode:#haskell.cz-join freenode:#haskell.de-join freenode:#haskell.dut-join freenode:#haskell.es-join freenode:#haskell.fi-join freenode:#haskell.fr-join freenode:#haskell.hr-join freenode:#haskell.it-join freenode:#haskell.jp-join freenode:#haskell.no-join freenode:#haskell.ru-join freenode:#haskell.se-join freenode:#haskell_ru-join freenode:#jhc-join freenode:#jtiger-join freenode:#macosx-join freenode:#perl6-join freenode:#rosettacode-join freenode:#scala-join freenode:#scannedinavian-join freenode:#unicycling-join freenode:#xmonad
− online2.rc 
@@ -1,33 +0,0 @@-irc-connect freenode chat.freenode.net 6667 lambdabot2 Lambda_Robots:_100%_Loyal-rc passwd.rc-admin + freenode:Cale-admin + freenode:Igloo-admin + freenode:Lemmih-admin + freenode:Pseudonym-admin + freenode:mauke-admin + freenode:dons-admin + freenode:gwern-admin + freenode:int-e-admin + freenode:musasabi-admin + freenode:shapr-admin + freenode:sjanssen-admin + freenode:sorear-admin + freenode:vincenz-join freenode:#debian-es-join freenode:#dreamlinux-es-join freenode:#friendly-coders-join freenode:#gentoo-uy-join freenode:#haskell-hac07-join freenode:#haskell.de-join freenode:#haskell.dut-join freenode:#haskell.es-join freenode:#haskell.fi-join freenode:#haskell.fr-join freenode:#haskell.hr-join freenode:#haskell.it-join freenode:#haskell.jp-join freenode:#haskell.no-join freenode:#haskell.ru-join freenode:#haskell.se-join freenode:#haskell_ru-join freenode:#thunks
+ scripts/ghci.sh view
@@ -0,0 +1,29 @@+#!/bin/bash++# Copyright (c) 2006 Don Stewart - http://www.cse.unsw.edu.au/~dons+# GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)+++if [ ! -e "lambdabot.cabal" ] ; then+  echo "You must run this script from the root directory of lambdabot package."+  echo "Change your current path to the directory containing lambdabot.cabal"+  echo "file and type:"+  echo ""+  echo "./scripts/ghci.sh"+  echo ""+  echo "Make also sure you've done a full compiled build of lambdabot recently."+  exit+fi++echo "Make sure you've done a full compiled build of lambdabot recently."+echo ""++# find possible .o files+if [ -e "dist/build/lambdabot/lambdabot-tmp/" ] ; then+    Odir=dist/build/lambdabot/lambdabot-tmp/+else+    Odir=.+fi++# run ghci with the right command line flags to launch lambdabot+ghci -cpp -Wall -I. -isrc -idist/build/autogen/ -fno-warn-incomplete-patterns -fno-warn-missing-methods -fno-warn-orphans -DGHCi -hidir $Odir -odir $Odir $* -XCPP -XDeriveDataTypeable -XExistentialQuantification -XFlexibleContexts -XFlexibleInstances -XImplicitParams -XMultiParamTypeClasses -XNoMonomorphismRestriction -XPatternGuards -XRank2Types -XScopedTypeVariables -XStandaloneDeriving -XTemplateHaskell -XTypeOperators -XTypeSynonymInstances -XUndecidableInstances -XViewPatterns
+ scripts/online.rc view
@@ -0,0 +1,46 @@+irc-connect freenode chat.freenode.net 6667 lambdabot Lambda_Robots:_100%_Loyal+rc passwd.rc+admin + freenode:Cale+admin + freenode:Igloo+admin + freenode:Lemmih+admin + freenode:Pseudonym+admin + freenode:mauke+admin + freenode:dons+admin + freenode:gwern+admin + freenode:igli+admin + freenode:int-e+admin + freenode:musasabi+admin + freenode:shapr+admin + freenode:sjanssen+admin + freenode:sorear+admin + freenode:vincenz+join freenode:##logic+join freenode:#arch-haskell+join freenode:#darcs+join freenode:#debian-es+join freenode:#friendly-coders+join freenode:#gentoo-haskell+join freenode:#ghc+join freenode:#happs+join freenode:#haskell+join freenode:#haskell-blah+join freenode:#haskell-books+join freenode:#haskell-overflow+join freenode:#haskell-soc+join freenode:#haskell.cz+join freenode:#haskell.de+join freenode:#haskell.dut+join freenode:#haskell.es+join freenode:#haskell.fi+join freenode:#haskell.fr+join freenode:#haskell.it+join freenode:#haskell.jp+join freenode:#haskell.se+join freenode:#haskell_ru+join freenode:#lessswrong+join freenode:#macosx+join freenode:#perl6+join freenode:#rosettacode+join freenode:#scala+join freenode:#unicycling+join freenode:#xmonad
+ scripts/vim/README view
@@ -0,0 +1,11 @@+Vim support for lambdabot++To use, +    * install these scripts into your path somewhere+    +From within Vim, type:+    !!foo++where 'foo' is the script to run, and it will replace the contents of+the current line, with the result filtered through that lambdabot+command.
+ scripts/vim/bot view
@@ -0,0 +1,19 @@+#!/bin/sh++# Copyright (c) 2006 Don Stewart - http://www.cse.unsw.edu.au/~dons+# GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++#+# Generic lambdabot binding+#+# Select the expression you want to refactor, on a line of its own, and+# in vim, type:+#       !!bot cmd+#+# (Assuming your lambdabot is installed in $HOME/lambdabot, it will+# replace the expression with the pointfree version+#++DECL=`cat`+cd $HOME/lambdabot/+echo "$* $DECL" | ./lambdabot | sed '$d;s/lambdabot> //'
+ scripts/vim/pl view
@@ -0,0 +1,21 @@+#!/bin/sh++# Copyright (c) 2006 Don Stewart - http://www.cse.unsw.edu.au/~dons+# GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++#+# A shell script to be called from vim, to automatically refactor a code+# fragment.+#+# Select the expression you want to refactor, on a line of its own, and+# in vim, type:+#       !!pl+#+# (Assuming your lambdabot is installed in $HOME/lambdabot, it will+# replace the expression with the pointfree version+#++DECL=`cat`+cd $HOME/lambdabot/+echo "pl $DECL" | ./lambdabot 2> /dev/null | sed '$d;/Irc/d;s/lambdabot> //'+
+ scripts/vim/run view
@@ -0,0 +1,21 @@+#!/bin/sh++# Copyright (c) 2006 Don Stewart - http://www.cse.unsw.edu.au/~dons+# adapted by Gareth Smith+# GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++#+# A shell script to be called from vim, to use the awsesome power of haskell+# string processing in everyday editing.+#+# Select the line you want to edit, and in vim, type:+#       !!run+#+# (Assuming your lambdabot is installed in $HOME/lambdabot) it will+# run the line as a haskell expression.+#++DECL=`cat`+cd $HOME/lambdabot+echo "run $DECL" | ./lambdabot 2> /dev/null | sed '$d;/Irc/d;s/lambdabot> //'+
+ scripts/vim/runwith view
@@ -0,0 +1,32 @@+#!/bin/sh++# Copyright (c) 2006 Don Stewart - http://www.cse.unsw.edu.au/~dons+# adapted by Gareth Smith+# GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++#+# A shell script to be called from vim, to use the awsesome power of haskell+# string processing in everyday editing.+#+# Select the line you want to edit, and in vim, type:+#       !!runwith f+#+# where f :: (Show a) => String -> a+#+# (Assuming your lambdabot is installed in $HOME/lambdabot) it will+# replace the line with (f line)+#+# Hint: If you find yourself using a particular function a lot, use:+#       !!bot let+# to define it in lambdabot's local namespace.+#+# Isn't perfect yet - I'd like it if for functions f :: String -> String, that+# the returned String didn't have to pass through the show function, so we+# didn't get extraneous quote marks. For now, you can s/"//g them away though+# :)+#++DECL=`cat`+cd $HOME/lambdabot+echo "run $* \"$DECL\"" | ./lambdabot 2> /dev/null | sed '$d;/Irc/d;s/lambdabot> //'+
+ scripts/vim/typeOf view
@@ -0,0 +1,12 @@+#!/bin/sh++# Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons+# GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++# input is a top level .hs decls++FILE=$*+DECL=`cat`+ID=`echo $DECL | sed 's/^\([^ ]*\).*/\1/'`+echo ":t $ID" | ghci -v0 -cpp -fglasgow-exts -w $FILE+echo $DECL
+ src/Lambdabot.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+-- | The guts of lambdabot.+--+-- The LB/Lambdabot monad+-- Generic server connection,disconnection+-- The module typeclass, type and operations on modules+module Lambdabot+    ( ircLoadModule+    , ircUnloadModule+    , ircSignalConnect+    , ircInstallOutputFilter+    , checkPrivs+    , checkIgnore+    +    , ircGetChannels+    , ircQuit+    , ircReconnect+    , ircPrivmsg+    , ircPrivmsg'+    ) where++import Lambdabot.ChanName+import Lambdabot.Command+import Lambdabot.IRC+import Lambdabot.Logging+import Lambdabot.Message+import Lambdabot.Module+import Lambdabot.Monad+import Lambdabot.Nick+import Lambdabot.OutputFilter+import Lambdabot.State+import Lambdabot.Util++import Control.Concurrent+import Control.Exception.Lifted+import Control.Monad.Error+import Control.Monad.Reader+import Control.Monad.State+import qualified Data.Map as M+import Data.Random.Source+import qualified Data.Set as S+import System.IO++------------------------------------------------------------------------+--+-- | Register a module in the irc state+--+ircLoadModule :: Module st -> String -> LB ()+ircLoadModule m modname = do+    infoM ("Loading module " ++ show modname)+    savedState <- readGlobalState m modname+    state'     <- maybe (moduleDefState m) return savedState+    ref        <- io $ newMVar state'+    +    let modref = ModuleRef  m ref modname+        cmdref = CommandRef m ref modname+    +    mbCmds <- flip runReaderT (ref, modname) . runModuleT $ do+        initResult <- try (moduleInit m)+        case initResult of+            Left e  -> return (Left e)+            Right{} -> try (moduleCmds m)+    +    case mbCmds of+        Left e@SomeException{} -> do+            errorM ("Module " ++ show modname ++ " failed to load.  Exception thrown: " ++ show e)+            +            fail "Refusing to load due to a broken plugin"+        Right cmds -> do+            s <- get+            let modmap = ircModules s+                cmdmap = ircCommands s+            put s {+              ircModules = M.insert modname modref modmap,+              ircCommands = M.union (M.fromList [ (name,cmdref cmd) | cmd <- cmds, name <- cmdNames cmd ]) cmdmap+            }++--+-- | Unregister a module's entry in the irc state+--+ircUnloadModule :: String -> LB ()+ircUnloadModule modname = do+    infoM ("Unloading module " ++ show modname)+    +    withModule modname (error "module not loaded") $ \m -> do+        when (moduleSticky m) $ fail "module is sticky"+        +        exitResult <- try (moduleExit m)+        case exitResult of+            Right{} -> return ()+            Left e@SomeException{} -> errorM ("Module " ++ show modname ++ " threw the following exception in moduleExit: " ++ show e)+        +        writeGlobalState m modname+    +    s <- get+    let modmap = ircModules s+        cmdmap = ircCommands s+        cbs    = ircCallbacks s+        svrs   = ircServerMap s+        ofs    = ircOutputFilters s+    put s+        { ircCommands      = M.filter (\(CommandRef _ _ name _) -> name /= modname) cmdmap+        , ircModules       = M.delete modname modmap+        , ircCallbacks     =   filter ((/=modname) . fst) `fmap` cbs+        , ircServerMap     = M.filter ((/=modname) . fst) svrs+        , ircOutputFilters =   filter ((/=modname) . fst) ofs+        }++------------------------------------------------------------------------++ircSignalConnect :: String -> Callback -> ModuleT mod LB ()+ircSignalConnect str f = do+    s <- lift get+    let cbs = ircCallbacks s+    name <- getModuleName+    case M.lookup str cbs of -- TODO: figure out what this TODO is for+        Nothing -> lift (put s { ircCallbacks = M.insert str [(name,f)]    cbs})+        Just fs -> lift (put s { ircCallbacks = M.insert str ((name,f):fs) cbs})++ircInstallOutputFilter :: OutputFilter LB -> ModuleT mod LB ()+ircInstallOutputFilter f = do+    name <- getModuleName+    lift . modify $ \s ->+        s { ircOutputFilters = (name, f): ircOutputFilters s }++-- | Checks if the given user has admin permissions and excecute the action+--   only in this case.+checkPrivs :: IrcMessage -> LB Bool+checkPrivs msg = gets (S.member (nick msg) . ircPrivilegedUsers)++-- | Checks if the given user is being ignored.+--   Privileged users can't be ignored.+checkIgnore :: IrcMessage -> LB Bool+checkIgnore msg = liftM2 (&&) (liftM not (checkPrivs msg))+                  (gets (S.member (nick msg) . ircIgnoredUsers))++------------------------------------------------------------------------+-- Some generic server operations++ircGetChannels :: LB [Nick]+ircGetChannels = (map getCN . M.keys) `fmap` gets ircChannels++-- Send a quit message, settle and wait for the server to drop our+-- handle. At which point the main thread gets a closed handle eof+-- exceptoin, we clean up and go home+ircQuit :: String -> String -> LB ()+ircQuit svr msg = do+    modify $ \state' -> state' { ircStayConnected = False }+    send  $ quit svr msg+    liftIO $ threadDelay 1000+    io $ hPutStrLn stderr "Quit"++ircReconnect :: String -> String -> LB ()+ircReconnect svr msg = do+    send $ quit svr msg+    liftIO $ threadDelay 1000++-- | Send a message to a channel\/user. If the message is too long, the rest+--   of it is saved in the (global) more-state.+ircPrivmsg :: Nick      -- ^ The channel\/user.+           -> String        -- ^ The message.+           -> LB ()++ircPrivmsg who msg = do+    filters   <- gets ircOutputFilters+    sendlines <- foldr (\f -> (=<<) (f who)) ((return . lines) msg) $ map snd filters+    mapM_ (\s -> ircPrivmsg' who (take textwidth s)) (take 10 sendlines)++-- A raw send version+ircPrivmsg' :: Nick -> String -> LB ()+ircPrivmsg' who ""  = ircPrivmsg' who " "+ircPrivmsg' who msg = send $ privmsg who msg++------------------------------------------------------------------------++monadRandom [d|++    instance MonadRandom LB where+        getRandomWord8          = LB (lift getRandomWord8)+        getRandomWord16         = LB (lift getRandomWord16)+        getRandomWord32         = LB (lift getRandomWord32)+        getRandomWord64         = LB (lift getRandomWord64)+        getRandomDouble         = LB (lift getRandomDouble)+        getRandomNByteInteger n = LB (lift (getRandomNByteInteger n))++ |]
+ src/Lambdabot/ChanName.hs view
@@ -0,0 +1,20 @@+module Lambdabot.ChanName+    ( ChanName+    , mkCN+    , getCN+    ) where++import Lambdabot.Nick++import Control.Applicative+import Data.Char++newtype ChanName = ChanName Nick -- always lowercase+  deriving (Eq, Ord)++mkCN :: Nick -> ChanName+mkCN = ChanName . liftA2 Nick nTag (map toLower . nName)++getCN :: ChanName -> Nick+getCN (ChanName n) = n+
+ src/Lambdabot/Command.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Lambdabot.Command +    ( Command(..)+    , cmdNames+    , command+    , runCommand+    , Cmd+    , execCmd+    , getCmdName+    , withMsg+    , readNick+    , showNick+    , getServer+    , getSender+    , getTarget+    , getLambdabotName+    , say+    ) where++import Lambdabot.Config+import Lambdabot.Logging+import qualified Lambdabot.Message as Msg+import Lambdabot.Nick++import Control.Applicative+import Control.Monad.Base+import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Control.Monad.Writer++data CmdArgs = forall a. Msg.Message a => CmdArgs+    { _message  :: a+    , target    :: Nick+    , invokedAs :: String+    }++newtype Cmd m a = Cmd { unCmd :: ReaderT CmdArgs (WriterT [String] m) a }+instance Functor f => Functor (Cmd f) where+    fmap f (Cmd x) = Cmd (fmap f x)+instance Applicative f => Applicative (Cmd f) where+    pure = Cmd . pure+    Cmd f <*> Cmd x = Cmd (f <*> x)+instance Monad m => Monad (Cmd m) where+    return = Cmd . return+    Cmd x >>= f = Cmd (x >>= (unCmd . f))+    fail = lift . fail+instance MonadIO m => MonadIO (Cmd m) where+    liftIO = lift . liftIO+instance MonadBase b m => MonadBase b (Cmd m) where+    liftBase = lift . liftBase+instance MonadTrans Cmd where+    lift = Cmd . lift . lift+instance MonadTransControl Cmd where+    newtype StT Cmd a = StCmd {unStCmd :: (a, [String])}+    liftWith f = do+        r <- Cmd ask+        lift $ f $ \t -> liftM StCmd (runWriterT (runReaderT (unCmd t) r))+    restoreT = Cmd . lift . WriterT . liftM unStCmd+    {-# INLINE liftWith #-}+    {-# INLINE restoreT #-}+instance MonadBaseControl b m => MonadBaseControl b (Cmd m) where+    newtype StM (Cmd m) a = StMCmd {unStMCmd :: ComposeSt Cmd m a}+    liftBaseWith = defaultLiftBaseWith StMCmd+    restoreM     = defaultRestoreM     unStMCmd+    {-# INLINE liftBaseWith #-}+    {-# INLINE restoreM #-}+instance MonadConfig m => MonadConfig (Cmd m) where+    getConfig = lift . getConfig+instance MonadLogging m => MonadLogging (Cmd m) where+    getCurrentLogger = do+        parent <- lift getCurrentLogger+        self   <- getCmdName+        return (parent ++ ["Command", self])+    logM a b c = lift (logM a b c)++data Command m = Command+    { cmdName       :: String+    , aliases       :: [String]+    , privileged    :: Bool+    , help          :: Cmd m ()+    , process       :: String -> Cmd m ()+    }++cmdNames :: Command m -> [String]+cmdNames c = cmdName c : aliases c++command :: String -> Command Identity+command name = Command+    { cmdName       = name+    , aliases       = []+    , privileged    = False+    , help          = bug "they haven't created any help text!"+    , process       = const (bug "they haven't implemented this command!")+    } where+        bug reason = say $ unwords [ "You should bug the author of the", show name, "command, because", reason]++runCommand :: (Monad m, Msg.Message a) => Command m -> a -> Nick -> String -> String -> m [String]+runCommand cmd msg tgt arg0 args = execCmd (process cmd args) msg tgt arg0++execCmd ::  (Monad m, Msg.Message a) => Cmd m t -> a -> Nick -> String -> m [String]+execCmd cmd msg tgt arg0 = execWriterT (runReaderT (unCmd cmd) (CmdArgs msg tgt arg0))++getTarget :: Monad m => Cmd m Nick+getTarget = Cmd (asks target)++getCmdName :: Monad m => Cmd m String+getCmdName = Cmd (asks invokedAs)++say :: Monad m => String -> Cmd m ()+say [] = return ()+say it = Cmd (tell [it])++withMsg :: Monad m => (forall a. Msg.Message a => a -> Cmd m t) -> Cmd m t+withMsg f = Cmd ask >>= f'+    where f' (CmdArgs msg _ _) = f msg++readNick :: Monad m => String -> Cmd m Nick+readNick nick = withMsg (\msg -> return (parseNick (Msg.server msg) nick))++showNick :: Monad m => Nick -> Cmd m String+showNick nick = withMsg (\msg -> return (fmtNick (Msg.server msg) nick))++getServer :: Monad m => Cmd m String+getServer = withMsg (return . Msg.server)++getSender :: Monad m => Cmd m Nick+getSender = withMsg (return . Msg.nick)++getLambdabotName :: Monad m => Cmd m Nick+getLambdabotName = withMsg (return . Msg.lambdabotName)
+ src/Lambdabot/Compat/AltTime.hs view
@@ -0,0 +1,192 @@+-- | Time compatibility layer+-- (stuff to support old lambdabot state serialization formats)+--+-- TODO: trim this down to just the explicitly serialization-related stuff+module Lambdabot.Compat.AltTime +    ( ClockTime+    , getClockTime+    , diffClockTimes+    , addToClockTime+    , timeDiffPretty+    +    , TimeDiff(..)+    , noTimeDiff+    ) where++import Control.Arrow (first)++import Data.Binary++import Data.List+import Data.Time+import Text.Read hiding (get, lexP, readPrec)+import Text.Read.Lex++-- | Wrapping ClockTime (which doesn't provide a Read instance!) seems+-- easier than talking care of the serialization of UserStatus+-- ourselves.+--+newtype ClockTime = ClockTime UTCTime+    deriving Eq++newtype TimeDiff = TimeDiff NominalDiffTime+    deriving (Eq, Ord)++noTimeDiff :: TimeDiff+noTimeDiff = TimeDiff 0++epoch :: UTCTime+epoch = UTCTime (fromGregorian 1970 1 1) 0++-- convert to/from the format in old-time, so we can serialize things +-- in the same way as older versions of lambdabot.+toOldTime :: ClockTime -> (Integer, Integer)+toOldTime (ClockTime t) = round (diffUTCTime t epoch * 1e12) `divMod` 1000000000000++fromOldTime :: Integer -> Integer -> ClockTime+fromOldTime x y = ClockTime (addUTCTime (fromIntegral x + fromIntegral y * 1e-12) epoch)++instance Show ClockTime where+    showsPrec p = showsPrec p . toOldTime++instance Read ClockTime where+    readsPrec p = map (first (uncurry fromOldTime)) . readsPrec p++instance Show TimeDiff where+    showsPrec p td = showParen (p > 10) $+        ( showString "TimeDiff {tdYear = "+        . showsPrec 11 ye+        . showString ", tdMonth = "+        . showsPrec 11 mo+        . showString ", tdDay = "+        . showsPrec 11 da+        . showString ", tdHour = "+        . showsPrec 11 ho+        . showString ", tdMin = "+        . showsPrec 11 mi+        . showString ", tdSec = "+        . showsPrec 11 se+        . showString ", tdPicosec = "+        . showsPrec 11 ps+        . showString "}")+        where (ye, mo, da, ho, mi, se, ps) = toOldTimeDiff td++instance Read TimeDiff where+    readsPrec = readPrec_to_S $ parens+        (prec 11 (do+            let lexP = lift Text.Read.Lex.lex+                readPrec :: Read a => ReadPrec a+                readPrec = readS_to_Prec readsPrec+            Ident "TimeDiff"    <- lexP+            Punc "{"            <- lexP+            Ident "tdYear"      <- lexP+            Punc "="            <- lexP+            ye                  <- reset readPrec+            Punc ","            <- lexP+            Ident "tdMonth"     <- lexP+            Punc "="            <- lexP+            mo                  <- reset readPrec+            Punc ","            <- lexP+            Ident "tdDay"       <- lexP+            Punc "="            <- lexP+            da                  <- reset readPrec+            Punc ","            <- lexP+            Ident "tdHour"      <- lexP+            Punc "="            <- lexP+            ho                  <- reset readPrec+            Punc ","            <- lexP+            Ident "tdMin"       <- lexP+            Punc "="            <- lexP+            mi                  <- reset readPrec+            Punc ","            <- lexP+            Ident "tdSec"       <- lexP+            Punc "="            <- lexP+            se                  <- reset readPrec+            Punc ","            <- lexP+            Ident "tdPicosec"   <- lexP+            Punc "="            <- lexP+            ps                  <- reset readPrec+            Punc "}"            <- lexP+            return (fromOldTimeDiff ye mo da ho mi se ps)))+    readList = readListDefault+    readListPrec = readListPrecDefault++-- | Retrieve the current clocktime+getClockTime :: IO ClockTime+getClockTime = ClockTime `fmap` getCurrentTime++-- | Difference of two clock times+diffClockTimes :: ClockTime -> ClockTime -> TimeDiff+diffClockTimes (ClockTime ct1) (ClockTime ct2) = TimeDiff (diffUTCTime ct1 ct2)++-- | @'addToClockTime' d t@ adds a time difference @d@ and a -- clock+-- time @t@ to yield a new clock time.+addToClockTime :: TimeDiff -> ClockTime -> ClockTime+addToClockTime (TimeDiff td) (ClockTime ct) = ClockTime (addUTCTime td ct)++-- | Pretty-print a TimeDiff. Both positive and negative Timediffs produce+--   the same output.+--+-- 14d 17h 8m 53s+--+timeDiffPretty :: TimeDiff -> String+timeDiffPretty td = concat . intersperse " " $ filter (not . null)+    [ prettyP ye "y"+    , prettyP mo "m"+    , prettyP da "d"+    , prettyP ho "h"+    , prettyP mi "m"+    , prettyP se "s"+    ]+  where+    prettyP 0 _ = []+    prettyP i s = show i ++ s+    +    (ye, mo, da, ho, mi, se, _) = toOldTimeDiff td++toOldTimeDiff :: TimeDiff -> (Int, Int, Int, Int, Int, Int, Integer)+toOldTimeDiff (TimeDiff td) = (fromInteger ye, fromInteger mo, fromInteger da, fromInteger ho, fromInteger mi, fromInteger se, ps)+    where+        (a,  ps) = round (td * 1e12) `divMod` 1000000000000+        (b,  se) = a `divMod` 60+        (c,  mi) = b `divMod` 60+        (d,  ho) = c `divMod` 24+        (e,  da) = d `divMod` 28+        (ye, mo) = e `divMod` 12++fromOldTimeDiff :: Int -> Int -> Int -> Int -> Int -> Int -> Integer -> TimeDiff+fromOldTimeDiff ye mo da ho mi se ps =+    TimeDiff+        (1e-12 * fromIntegral (ps +            + 1000000000000 * (toInteger se +                + 60 * (toInteger mi +                    + 60 * (toInteger ho+                        + 24 * (toInteger da+                            + 28 * (toInteger mo+                                + 12 * toInteger ye)))))))++------------------------------------------------------------------------++instance Binary ClockTime where+        put t = put i >> put j+            where (i, j) = toOldTime t+        get = do +            i <- get+            j <- get+            return (fromOldTime i j)++instance Binary TimeDiff where+        put td = do+            put ye; put mo; put da; put ho; put mi; put se; put ps+            where (ye, mo, da, ho, mi, se, ps) = toOldTimeDiff td+        get = do+            ye <- get+            mo <- get+            da <- get+            ho <- get+            mi <- get+            se <- get+            ps <- get+            return (fromOldTimeDiff ye mo da ho mi se ps)++
+ src/Lambdabot/Compat/FreenodeNick.hs view
@@ -0,0 +1,38 @@+-- | Backward-compatibility shim for (de-)serializing 'Nick's+-- using the old 'Read'/'Show' instances which gave freenode+-- special treatment.+module Lambdabot.Compat.FreenodeNick+    ( FreenodeNick(..)+    , freenodeNickMapSerial+    ) where++import Control.Arrow+import qualified Data.Map as M+import Lambdabot.Nick+import Lambdabot.Util.Serial++newtype FreenodeNick = FreenodeNick { getFreenodeNick :: Nick }+    deriving (Eq, Ord)++instance Show FreenodeNick where+    show (FreenodeNick x)+        | nTag x == "freenode" = show $ nName x+        | otherwise            = show $ pckStr x++instance Read FreenodeNick where+    readsPrec prec str = map (first (FreenodeNick . upckStr "freenode")) (readsPrec prec str)++-- Helper functions+upckStr :: String -> String -> Nick+upckStr def str+    | null ac   = Nick def str+    | otherwise = Nick bc (tail ac)+    where (bc, ac) = break (==':') str++pckStr :: Nick -> String+pckStr nck = nTag nck ++ ':' : nName nck++freenodeNickMapSerial :: (Show v, Read v) => Serial (M.Map Nick v)+freenodeNickMapSerial = Serial+    (serialize mapSerial . M.mapKeysMonotonic FreenodeNick)+    (fmap (M.mapKeysMonotonic getFreenodeNick) . deserialize mapSerial)
+ src/Lambdabot/Compat/PackedNick.hs view
@@ -0,0 +1,29 @@+module Lambdabot.Compat.PackedNick+    ( PackedNick+    , packNick+    , unpackNick+    ) where++import Lambdabot.Nick+import qualified Data.ByteString.Char8 as BS++-- | The type of nicknames+type PackedNick = BS.ByteString++-- Helper functions+upckStr :: String -> String -> Nick+upckStr def str | null ac   = Nick def str+                | otherwise = Nick bc (tail ac)+    where (bc, ac) = break (==':') str++pckStr :: Nick -> String+pckStr nck = nTag nck ++ ':' : nName nck++-- | Pack a nickname into a ByteString.  Note that the resulting strings are+-- not optimally formatted for human consumtion.+packNick :: Nick -> BS.ByteString+packNick = BS.pack . pckStr++-- | Unpack a nickname packed by 'packNick'.+unpackNick :: BS.ByteString -> Nick+unpackNick = upckStr "freenode" . BS.unpack
+ src/Lambdabot/Config.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+-- | Extensible configuration system for lambdabot+-- +-- TODO: there's notthing lambdabot-specific about this, it could be a useful standalone library.+module Lambdabot.Config+    ( Config+    , getConfigDefault+    , mergeConfig+    +    , MonadConfig(..)+    +    , config+    , configWithMerge+    ) where++import Control.Applicative+import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.State+import Data.Char+import Data.GADT.Compare+import Data.GADT.Compare.TH+import Data.Maybe+import Data.Typeable+import Language.Haskell.TH++data Config t where Config :: (Typeable1 k, GCompare k) => !(k t) -> t -> (t -> t -> t) -> Config t++cast1 :: (Typeable1 f, Typeable1 g) => f a -> Maybe (g a)+cast1 = fmap runIdentity . gcast1 . Identity++instance GEq Config where+    geq (Config k1 _ _) (Config k2 _ _) = do+        k2' <- cast1 k2+        geq k1 k2'++instance GCompare Config where+    gcompare (Config k1 _ _) (Config k2 _ _) = +        case compare t1 t2 of+            LT -> GLT+            EQ -> fromMaybe typeErr $ do+                k2'  <- cast1 k2+                return (gcompare k1 k2')+            GT -> GGT+        where+            t1 = typeOf1 k1+            t2 = typeOf1 k2+            +            typeErr = error "TypeReps claim to be equal but cast failed"++getConfigDefault :: Config t -> t+getConfigDefault (Config _ def _) = def++mergeConfig :: Config t -> t -> t -> t+mergeConfig (Config _ _ f) = f++class Monad m => MonadConfig m where+    getConfig :: Config a -> m a++instance  MonadConfig m            => MonadConfig (ReaderT r m) where getConfig = lift . getConfig+instance (MonadConfig m, Monoid w) => MonadConfig (WriterT w m) where getConfig = lift . getConfig+instance  MonadConfig m            => MonadConfig (StateT  s m) where getConfig = lift . getConfig++-- |Define a new configuration key with the specified name, type and +-- default value+-- +-- You should probably also provide an explicit export list for any+-- module that defines config keys, because the definition introduces+-- a few extra types that will clutter up the export list otherwise.+config :: String -> TypeQ -> ExpQ -> Q [Dec]+config = configWithMerge [| flip const |]++-- |Like 'config', but also allowing you to specify a \"merge rule\"+-- that will be used to combine multiple bindings of the same key.+-- +-- For example, in "Lambdabot.Config.Core", 'onStartupCmds' is+-- defined as a list of commands to execute on startup.  Its default+-- value is ["offlinerc"], so if a user invokes the default lambdabot+-- executable without arguments, they will get a REPL.  Each instance+-- of "-e" on the command-line adds a binding of the form:+--+-- > onStartupCmds :=> [command]+-- +-- So if they give one "-e", it replaces the default (note that it+-- is _not_ merged with the default - the default is discarded), and+-- if they give more than one they are merged using the specified+-- operation (in this case, `(++)`).+configWithMerge :: ExpQ -> String -> TypeQ -> ExpQ -> Q [Dec]+configWithMerge mergeQ nameStr tyQ defValQ = do+    let keyName = mkName nameStr+    tyName      <- newName (map toUpper nameStr)+    conName     <- newName (map toUpper nameStr)+    tyVarName   <- newName "a'"+    +    ty          <- tyQ+    defVal      <- defValQ+    mergeExpr   <- mergeQ+    let tyDec   = DataD [] tyName [PlainTV tyVarName] [ForallC [] [EqualP (VarT tyVarName) ty] (NormalC conName [])] [''Typeable]+        keyDecs =+            [ SigD keyName (AppT (ConT ''Config) ty)+            , ValD (VarP keyName) (NormalB (ConE 'Config `AppE` ConE conName `AppE` defVal `AppE` mergeExpr)) []+            ]+    +    concat <$> sequence+        [ return [tyDec]+        , return keyDecs+        , deriveGEq tyDec+        , deriveGCompare tyDec+        ]
+ src/Lambdabot/Config/Core.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}+module Lambdabot.Config.Core+    ( commandPrefixes+    , disabledCommands+    , evalPrefixes+    , onStartupCmds+    , outputDir+    , proxy+    , trustedPackages+    , uncaughtExceptionHandler+    +    , replaceRootLogger+    , lbRootLoggerPath+    , consoleLogHandle+    , consoleLogLevel+    , consoleLogFormat+    +    , aspellBinary+    , bfBinary+    , djinnBinary+    , ghcBinary+    , ghciBinary+    , hoogleBinary+    , muevalBinary+    , unlambdaBinary+    ) where++import Lambdabot.Config+import Lambdabot.Logging++import Control.Exception+import Network.HTTP.Proxy+import System.IO++-------------------------------------+-- Core configuration variables++config "commandPrefixes"    [t| [String]                |] [| ["@", "?"]    |]+config "disabledCommands"   [t| [String]                |] [| []            |]+config "evalPrefixes"       [t| [String]                |] [| [">"]         |]+configWithMerge [| (++) |] "onStartupCmds" [t| [String] |] [| ["offline"]   |]+config "outputDir"          [t| FilePath                |] [| "State/"      |]+config "proxy"              [t| Proxy                   |] [| NoProxy       |]++-- basic logging.  for more complex setups, configure directly using System.Log.Logger+config "replaceRootLogger"  [t| Bool                    |] [| True                        |]+config "lbRootLoggerPath"   [t| [String]                |] [| []                          |]+config "consoleLogHandle"   [t| Handle                  |] [| stderr                      |]+config "consoleLogLevel"    [t| Priority                |] [| NOTICE                      |]+config "consoleLogFormat"   [t| String                  |] [| "[$prio] $loggername: $msg" |]++-------------------------------------+-- Program names/locations++config "aspellBinary"       [t| String                  |] [| "aspell"      |]+config "bfBinary"           [t| String                  |] [| "bf"          |]+config "djinnBinary"        [t| String                  |] [| "djinn"       |]+config "ghcBinary"          [t| String                  |] [| "ghc"         |]+config "ghciBinary"         [t| String                  |] [| "ghci"        |]+config "hoogleBinary"       [t| String                  |] [| "hoogle"      |]+config "muevalBinary"       [t| String                  |] [| "mueval"      |]+config "unlambdaBinary"     [t| String                  |] [| "unlambda"    |]++--------------------------------------------+-- Default values with longer definitions++trustedPkgs :: [String]+trustedPkgs =+    [ "array"+    , "base"+    , "bytestring"+    , "containers"+    , "lambdabot"+    , "random"+    ]++configWithMerge [| (++) |] "trustedPackages"    [t| [String] |] [| trustedPkgs   |]++defaultIrcHandler :: SomeException -> IO ()+defaultIrcHandler = errorM . ("Main: caught (and ignoring) "++) . show++config "uncaughtExceptionHandler" [t| SomeException -> IO () |] [| defaultIrcHandler |]
+ src/Lambdabot/File.hs view
@@ -0,0 +1,122 @@+module Lambdabot.File+    ( findLBFile+    , findOrCreateLBFile+    , outputDir+    ) where++import Lambdabot.Config.Core+import Lambdabot.Monad+import Lambdabot.Util++import Control.Applicative+import Control.Monad+import Paths_lambdabot+import System.Directory+import System.FilePath++-- | Constants.+lambdabot :: FilePath+lambdabot = ".lambdabot"++stateDir :: LB FilePath+stateDir = (lambdabot </>) <$> getConfig outputDir++maybeFileExists :: FilePath -> IO (Maybe FilePath)+maybeFileExists path = do+    b <- doesFileExist path+    return $! if b then Just path else Nothing++-- | For a given file, look locally under State/. That is, suppose one is+-- running out of a Lambdabot darcs repository in /home/cale/lambdabot. Then+--+-- > lookLocally "fact" ~> "/home/cale/lambdabot/State/fact"+lookLocally :: FilePath -> LB (Maybe String)+lookLocally file = do+    local <- getConfig outputDir+    io $ maybeFileExists (local </> file)++-- | For a given file, look at the home directory. By default, we stash files in+-- ~/.lambdabot. So, running Lambdabot normally would let us do:+--+-- > lookHome "fact" ~> "/home/cale/lambdabot/State/fact"+--+-- (Note that for convenience we preserve the "State/foo" address pattern.)+lookHome :: FilePath -> LB (Maybe String)+lookHome f = do+    home    <- io getHomeDirectory+    state   <- stateDir+    io (maybeFileExists $ home </> state </> f)++-- | Do ~/.lambdabot & ~/.lambdabot/State exist?+isHome :: LB Bool+isHome = do+    home  <- io getHomeDirectory+    state <- stateDir+    io . fmap and . mapM (doesDirectoryExist . (home </>)) $ [lambdabot, state]++-- | Create ~/.lambdabot and ~/.lambdabot/State+mkdirL :: LB ()+mkdirL = do+    home  <- io getHomeDirectory+    state <- stateDir+    +    io . mapM_ (createDirectory . (home </>)) $ [lambdabot, state]++-- | Ask Cabal for the read-only copy of a file, and copy it into ~/.lambdabot/State.+-- if there isn't a read-only copy, create an empty file.+cpDataToHome :: FilePath -> LB ()+cpDataToHome f = do +    local   <- getConfig outputDir+    state   <- stateDir+    +    rofile  <- io (getDataFileName (local </> f))+    home    <- io getHomeDirectory+    -- cp /.../lambdabot-4.foo/State/foo ~/.lambdabot/State/foo+    +    let outFile = home </> state </> f+    exists  <- io (doesFileExist rofile)+    if exists+        then io (copyFile rofile outFile)+        else io (writeFile outFile "")++-- | Try to find a pre-existing file, searching first in ./State and then in +-- ~/.lambdabot/State+findLBFile :: FilePath -> LB (Maybe String)+findLBFile f = do+    first <- lookLocally f+    case first of+        -- With any luck we can exit quickly+        Just a -> return (Just a)+        -- OK, we didn't get lucky with local, so+        -- hopefully it's in ~/.lambdabot+        Nothing -> lookHome f++-- | Complicated. If a file exists locally, we return that. If a file exists in+-- ~/lambdabot/State, we return that. If neither the file nor ~/lambdabot/State+-- exist, we create the directories and then copy the file into it if a template+-- exists, or create an empty file if it does not.+-- Note that the return type is simple so we can just do a binding and stuff it+-- into the conventional functions easily; unfortunately, this removes+-- error-checking, as an error is now just \"\".+findOrCreateLBFile :: FilePath -> LB String+findOrCreateLBFile f = do+    mbFile <- findLBFile f+    case mbFile of+        Just file   -> return file+        -- Uh oh. We didn't find it locally, nor did we+        -- find it in ~/.lambdabot/State. So now we+        -- need to make ~/.lambdabot/State and copy it in.+        Nothing -> do+            exists <- isHome+            when (not exists) mkdirL+            cpDataToHome f+            -- With the file copied/created,+            -- a second attempt should work.+            g <- lookHome f+            case g of+                Just a -> return a+                Nothing -> do+                    home  <- io getHomeDirectory +                    state <- stateDir+                    fail $ "findOrCreateLBFile: couldn't find file " +                        ++ f ++ " in " ++ home </> state
+ src/Lambdabot/IRC.hs view
@@ -0,0 +1,115 @@+--+-- | The IRC module processes the IRC protocol and provides a nice API for sending+--   and recieving IRC messages with an IRC server.+--+module Lambdabot.IRC+    ( IrcMessage(..)+    , joinChannel+    , partChannel+    , getTopic+    , setTopic+    , privmsg+    , quit+    , timeReply+    , errShowMsg -- TODO: remove+    , user+    , setNick+    ) where++import Lambdabot.Message+import Lambdabot.Nick++import Data.Char (chr,isSpace)+import Data.List.Split++import Control.Monad (liftM2)++-- | An IRC message is a server, a prefix, a command and a list of parameters.+data IrcMessage+  = IrcMessage {+        ircMsgServer   :: !String,+        ircMsgLBName   :: !String,+        ircMsgPrefix   :: !String,+        ircMsgCommand  :: !String,+        ircMsgParams   :: ![String]+  }+  deriving (Show)++instance Message IrcMessage where+    nick                = liftM2 Nick ircMsgServer (takeWhile (/= '!') . ircMsgPrefix)+    server              = ircMsgServer+    fullName            = dropWhile (/= '!') . ircMsgPrefix+    channels msg        = +      let cstr = head $ ircMsgParams msg+        in map (Nick (server msg)) $+           map (\(x:xs) -> if x == ':' then xs else x:xs) (splitOn "," cstr)+               -- solves what seems to be an inconsistency in the parser+    lambdabotName msg   = Nick (server msg) (ircMsgLBName msg)++-- | 'mkMessage' creates a new message from a server, a cmd, and a list of parameters.+mkMessage :: String -- ^ Server+          -> String -- ^ Command+          -> [String] -- ^ Parameters+          -> IrcMessage -- ^ Returns: The created message++mkMessage svr cmd params = IrcMessage +    { ircMsgServer = svr+    , ircMsgPrefix = ""+    , ircMsgCommand = cmd+    , ircMsgParams = params+    , ircMsgLBName = "urk!<outputmessage>"+    }++joinChannel :: Nick -> IrcMessage+joinChannel loc     = mkMessage (nTag loc)  "JOIN"  [nName loc]++partChannel :: Nick -> IrcMessage+partChannel loc     = mkMessage (nTag loc)  "PART"  [nName loc]++getTopic :: Nick -> IrcMessage+getTopic chan       = mkMessage (nTag chan) "TOPIC" [nName chan]++setTopic :: Nick -> String -> IrcMessage+setTopic chan topic = mkMessage (nTag chan) "TOPIC" [nName chan, ':' : topic]++-- | 'privmsg' creates a private message to the person designated.+privmsg :: Nick -- ^ Who should recieve the message (nick)+        -> String -- ^ What is the message?+        -> IrcMessage -- ^ Constructed message+privmsg who msg = if action then mk [nName who, ':':(chr 0x1):("ACTION " ++ clean_msg ++ ((chr 0x1):[]))]+                            else mk [nName who, ':' : clean_msg]+    where mk = mkMessage (nTag who) "PRIVMSG"+          cleaned_msg = case filter (/= '\CR') msg of+              str@('@':_) -> ' ':str+              str         -> str+          (clean_msg,action) = case cleaned_msg of+              ('/':'m':'e':r) -> (dropWhile isSpace r,True)+              str             -> (str,False)++-- | 'quit' creates a server QUIT message. The input string given is the+--   quit message, given to other parties when leaving the network.+quit :: String -> String -> IrcMessage+quit svr msg = mkMessage svr "QUIT" [':' : msg]++-- | Construct a privmsg from the CTCP TIME notice, to feed up to+-- the @localtime-reply plugin, which then passes the output to+-- the appropriate client.+timeReply :: IrcMessage -> IrcMessage+timeReply msg = msg+    { ircMsgCommand = "PRIVMSG"+    , ircMsgParams  = [head (ircMsgParams msg)+                   ,":@localtime-reply " ++ (nName $ nick msg) ++ ":" +++                      (init $ drop 7 (last (ircMsgParams msg))) ]+    }++-- Only needed for Base.hs+errShowMsg :: IrcMessage -> String+errShowMsg msg = "ERROR> <" ++ ircMsgServer msg ++ (':' : ircMsgPrefix msg) +++      "> [" ++ ircMsgCommand msg ++ "] " ++ show (ircMsgParams msg)++user :: String -> String -> String -> String -> IrcMessage+user svr nick_ server_ ircname = mkMessage svr "USER" [nick_, "localhost", server_, ircname]++setNick :: Nick -> IrcMessage+setNick nick_ = mkMessage (nTag nick_) "NICK" [nName nick_]+
+ src/Lambdabot/Logging.hs view
@@ -0,0 +1,67 @@+module Lambdabot.Logging+    ( L.Priority(..)+    , MonadLogging(..)+    , debugM+    , infoM+    , noticeM+    , warningM+    , errorM+    , criticalM+    , alertM+    , emergencyM+    ) where++import Control.Monad+import Data.List+import qualified System.Log.Logger as L++class Monad m => MonadLogging m where+    getCurrentLogger :: m [String]+    logM :: String -> L.Priority -> String -> m ()++instance MonadLogging IO where+    getCurrentLogger = return []+    logM = L.logM++getCurrentLoggerName :: MonadLogging m => m String+getCurrentLoggerName = liftM (intercalate "." . filter (not . null)) getCurrentLogger++debugM :: MonadLogging m => String -> m ()+debugM msg = do+    logger <- getCurrentLoggerName+    logM logger L.DEBUG msg++infoM :: MonadLogging m => String -> m ()+infoM msg = do+    logger <- getCurrentLoggerName+    logM logger L.INFO msg++noticeM :: MonadLogging m => String -> m ()+noticeM msg = do+    logger <- getCurrentLoggerName+    logM logger L.NOTICE msg++warningM :: MonadLogging m => String -> m ()+warningM msg = do+    logger <- getCurrentLoggerName+    logM logger L.WARNING msg++errorM :: MonadLogging m => String -> m ()+errorM msg = do+    logger <- getCurrentLoggerName+    logM logger L.ERROR msg++criticalM :: MonadLogging m => String -> m ()+criticalM msg = do+    logger <- getCurrentLoggerName+    logM logger L.CRITICAL msg++alertM :: MonadLogging m => String -> m ()+alertM msg = do+    logger <- getCurrentLoggerName+    logM logger L.ALERT msg++emergencyM :: MonadLogging m => String -> m ()+emergencyM msg = do+    logger <- getCurrentLoggerName+    logM logger L.EMERGENCY msg
+ src/Lambdabot/Main.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE TemplateHaskell #-}+module Lambdabot.Main+    ( lambdabotVersion+    +    , Config+    , DSum(..)+    , lambdabotMain++    , Modules+    , modules++    , module Lambdabot.Config.Core+    , Priority(..)+    ) where++import Lambdabot+import Lambdabot.Config+import Lambdabot.Config.Core+import Lambdabot.Logging+import Lambdabot.Module+import Lambdabot.Monad+import Lambdabot.State+import Lambdabot.Util+import Lambdabot.Util.Signals++import Control.Exception.Lifted as E+import Data.Char+import Data.Dependent.Sum+import Data.Typeable+import Data.Version+import Language.Haskell.TH+import Paths_lambdabot+import System.Exit+import System.Log.Formatter+import qualified System.Log.Logger as L+import System.Log.Handler.Simple+import Network (withSocketsDo)++lambdabotVersion :: Version+lambdabotVersion = version++setupLogging :: LB ()+setupLogging = do+    stream <- getConfig consoleLogHandle+    level  <- getConfig consoleLogLevel+    format <- getConfig consoleLogFormat+    +    unformattedHandler <- io (streamHandler stream level)+    let consoleHandler = unformattedHandler+            { formatter = simpleLogFormatter format }+    +    setRoot <- getConfig replaceRootLogger+    +    io $ if setRoot+        then L.updateGlobalLogger L.rootLoggerName+            (L.setLevel level . L.setHandlers [consoleHandler])+        else L.updateGlobalLogger "Lambdabot"+            (L.setLevel level . L.addHandler consoleHandler)++-- | The Lambdabot entry point.+-- Initialise plugins, connect, and run the bot in the LB monad+--+-- Also, handle any fatal exceptions (such as non-recoverable signals),+-- (i.e. print a message and exit). Non-fatal exceptions should be dealt+-- with in the mainLoop or further down.+lambdabotMain :: LB () -> [DSum Config] -> IO ExitCode+lambdabotMain initialise cfg = withSocketsDo . withIrcSignalCatch $ do+    rost <- initRoState cfg+    r <- try $ evalLB (do setupLogging+                          noticeM "Initialising plugins"+                          initialise+                          noticeM "Done loading plugins"+                          reportInitDone rost+                          mainLoop+                          return ExitSuccess)+                       rost initRwState++    -- clean up and go home+    case r of+        Left (SomeException er) -> do+            case cast er of+                Just code -> return code+                Nothing -> do+                    putStrLn "exception:"+                    print er+                    return (ExitFailure 1)+        Right code -> return code++-- Actually, this isn't a loop anymore.  TODO: better name.+mainLoop :: LB ()+mainLoop = do+    waitForQuit `E.catch`+        (\e@SomeException{} -> errorM (show e)) -- catch anything, print informative message, and clean up+    +    withAllModules moduleExit+    flushModuleState+++------------------------------------------------------------------------++type Modules = LB ()++modules :: [String] -> Q Exp+modules xs = [| sequence_ $(listE $ map instalify xs) |]+    where+        instalify x =+            let module' = varE $ mkName $ concat $ ["Lambdabot.Plugin.", x, ".theModule"]+                low     = stringE $ map toLower x+             in [| ircLoadModule $module' $low |]
+ src/Lambdabot/Message.hs view
@@ -0,0 +1,25 @@+--+-- Provides interface to messages, message pipes+--+module Lambdabot.Message+    ( Message(..)+    ) where++import Lambdabot.Nick++-- TODO: probably remove "Show a" later (used only to implement @echo)+class Show a => Message a where+    -- | extracts the tag of the server involved in a given message+    server      :: a -> String++    -- | extracts the nickname involved in a given message.+    nick        :: a -> Nick++    -- | 'fullName' extracts the full user name involved in a given message.+    fullName    :: a -> String++    -- | 'channels' extracts the channels a Message operate on.+    channels    :: a -> [Nick]++    -- TODO: there must be a better way of handling this ...+    lambdabotName :: a -> Nick
+ src/Lambdabot/Module.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Lambdabot.Module+    ( Module(..)+    , newModule+    +    , ModuleT(..)++    , getRef+    , getModuleName+    , bindModule0+    , bindModule1+    , bindModule2+    ) where++import qualified Lambdabot.Command as Cmd+import Lambdabot.Config+import Lambdabot.Logging+import {-# SOURCE #-} Lambdabot.Monad+import Lambdabot.Util.Serial++import Control.Applicative+import Control.Concurrent (MVar)+import Control.Monad+import Control.Monad.Base+import Control.Monad.Reader (MonadReader(..), ReaderT(..))+import Control.Monad.Trans (MonadTrans(..), MonadIO(..))+import Control.Monad.Trans.Control+import System.Console.Haskeline.MonadException (MonadException)++------------------------------------------------------------------------++-- | The Module type class.+data Module st = Module {+        -- | If the module wants its state to be saved, this function should+        --   return a Serial.+        --+        --   The default implementation returns Nothing.+        moduleSerialize :: !(Maybe (Serial st)),++        -- | If the module maintains state, this method specifies the default state+        --   (for example in case the state can't be read from a state).+        --+        --   The default implementation returns an error and assumes the state is+        --   never accessed.+        moduleDefState  :: !(LB st),++        -- | Is the module sticky? Sticky modules (as well as static ones) can't be+        --   unloaded. By default, modules are not sticky.+        moduleSticky    :: !Bool,++        -- | The commands the module listenes to.+        moduleCmds      :: !(ModuleT st LB [Cmd.Command (ModuleT st LB)]),++        -- | Initialize the module. The default implementation does nothing.+        moduleInit      :: !(ModuleT st LB ()),++        -- | Finalize the module. The default implementation does nothing.+        moduleExit      :: !(ModuleT st LB ()),++        -- | Process contextual input. A plugin that implements 'contextual'+        -- is able to respond to text not part of a normal command.+        contextual+            :: !(String                           --  the text+             -> Cmd.Cmd (ModuleT st LB) ())       -- ^ the action+    }++------------------------------------------------------------------------++newModule :: Module st+newModule = Module+    { contextual         = \_ -> return ()+    , moduleCmds         = return []+    , moduleExit         = return ()+    , moduleInit         = return ()+    , moduleSticky       = False+    , moduleSerialize    = Nothing+    , moduleDefState     = return $ error "state not initialized"+    }++--+-- | This transformer encodes the additional information a module might+--   need to access its name or its state.+--+newtype ModuleT st m a = ModuleT { runModuleT :: ReaderT (MVar st, String) m a }+    deriving (Applicative, Functor, Monad, MonadTrans, MonadIO, MonadException, MonadConfig)++instance MonadLogging m => MonadLogging (ModuleT st m) where+    getCurrentLogger = do+        parent <- lift getCurrentLogger+        self   <- getModuleName+        return (parent ++ ["Plugin", self])+    logM a b c = lift (logM a b c)++instance MonadBase b m => MonadBase b (ModuleT st m) where+    liftBase = lift . liftBase++instance MonadTransControl (ModuleT st) where+    newtype StT (ModuleT st) a = StModule {unStModule :: a}+    liftWith f = do+        r <- ModuleT ask+        lift $ f $ \t -> liftM StModule (runReaderT (runModuleT t) r)+    restoreT = lift . liftM unStModule+    {-# INLINE liftWith #-}+    {-# INLINE restoreT #-}++instance MonadBaseControl b m => MonadBaseControl b (ModuleT st m) where+    newtype StM (ModuleT st m) a = StMModule {unStMModule :: ComposeSt (ModuleT st) m a}+    liftBaseWith = defaultLiftBaseWith StMModule+    restoreM     = defaultRestoreM     unStMModule+    {-# INLINE liftBaseWith #-}+    {-# INLINE restoreM #-}++getRef :: Monad m => ModuleT st m (MVar st)+getRef  = ModuleT $ ask >>= return . fst++getModuleName :: Monad m => ModuleT mod m String+getModuleName = ModuleT $ ask >>= return . snd++-- | bind an action to the current module so it can be run from the plain+--   `LB' monad.+bindModule0 :: ModuleT mod LB a -> ModuleT mod LB (LB a)+bindModule0 act = bindModule1 (const act) >>= return . ($ ())++-- | variant of `bindModule0' for monad actions with one argument+bindModule1 :: (a -> ModuleT mod LB b) -> ModuleT mod LB (a -> LB b)+bindModule1 act = ModuleT $+    ask >>= \st -> return (\val -> runReaderT (runModuleT $ act val) st)++-- | variant of `bindModule0' for monad actions with two arguments+bindModule2 :: (a -> b -> ModuleT mod LB c) -> ModuleT mod LB (a -> b -> LB c)+bindModule2 act = bindModule1 (uncurry act) >>= return . curry
+ src/Lambdabot/Monad.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+module Lambdabot.Monad+    ( IRCRState+    , initRoState+    , reportInitDone+    , waitForInit+    , waitForQuit+    +    , Callback+    , ModuleRef(..)+    , CommandRef(..)+    , IRCRWState(..)+    , initRwState+    +    , LB(..)+    , MonadLB(..)+    , evalLB+    +    , addServer+    , remServer+    , send+    , received+    +    , getConfig+    +    , withModule+    , withCommand+    , withAllModules+    ) where++import           Lambdabot.ChanName+import           Lambdabot.Command+import           Lambdabot.Config+import           Lambdabot.Config.Core+import           Lambdabot.IRC+import           Lambdabot.Logging+import           Lambdabot.Module+import qualified Lambdabot.Message as Msg+import           Lambdabot.Nick+import           Lambdabot.OutputFilter+import           Lambdabot.Util++import Control.Applicative+import Control.Concurrent.Lifted+import Control.Exception.Lifted as E (catch)+import Control.Monad.Base+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans.Control+import qualified Data.Dependent.Map as D+import Data.IORef+import qualified Data.Map as M+import qualified Data.Set as S+import System.Console.Haskeline.MonadException (MonadException)+import System.IO++------------------------------------------------------------------------+--+-- Lambdabot state+--++-- | Global read-only state.+data IRCRState = IRCRState+    { ircInitDoneMVar   :: MVar ()+    , ircQuitMVar       :: MVar ()+    , ircConfig         :: D.DMap Config+    }++-- | Default ro state+initRoState :: [D.DSum Config] -> IO IRCRState+initRoState configuration = do+    quitMVar     <- newEmptyMVar+    initDoneMVar <- newEmptyMVar+    +    return IRCRState +        { ircQuitMVar       = quitMVar+        , ircInitDoneMVar   = initDoneMVar+        , ircConfig         = D.fromListWithKey (flip . mergeConfig) configuration+        }++reportInitDone :: MonadIO m => IRCRState -> m ()+reportInitDone = io . flip putMVar () . ircInitDoneMVar++askLB :: MonadLB m => (IRCRState -> a) -> m a+askLB f  = lb . LB $ asks (f . fst)++waitForInit :: MonadLB m => m ()+waitForInit = readMVar =<< askLB ircInitDoneMVar++waitForQuit :: MonadLB m => m ()+waitForQuit = readMVar =<< askLB ircQuitMVar++type Callback = IrcMessage -> LB ()++data ModuleRef = forall st.+    ModuleRef (Module st) (MVar st) String++data CommandRef = forall st.+    CommandRef (Module st) (MVar st) String (Command (ModuleT st LB))++-- | Global read\/write state.+data IRCRWState = IRCRWState+    { ircServerMap       :: M.Map String (String, IrcMessage -> LB ())+    , ircPrivilegedUsers :: S.Set Nick+    , ircIgnoredUsers    :: S.Set Nick+    +    , ircChannels        :: M.Map ChanName String+    -- ^ maps channel names to topics+    +    , ircModules         :: M.Map String ModuleRef+    , ircCallbacks       :: M.Map String [(String,Callback)]+    , ircOutputFilters   :: [(String, OutputFilter LB)]+    -- ^ Output filters, invoked from right to left+    +    , ircCommands        :: M.Map String CommandRef+    , ircStayConnected   :: !Bool+    }++-- | Default rw state+initRwState :: IRCRWState+initRwState = IRCRWState+    { ircPrivilegedUsers = S.singleton (Nick "offlinerc" "null")+    , ircIgnoredUsers    = S.empty+    , ircChannels        = M.empty+    , ircModules         = M.empty+    , ircServerMap       = M.empty+    , ircCallbacks       = M.empty+    , ircOutputFilters   = +        [ ([],cleanOutput)+        , ([],lineify)+        , ([],cleanOutput)+        -- , ([],reduceIndent)+        , ([],checkRecip) ]+    , ircCommands        = M.empty+    , ircStayConnected   = True+    }+++-- The virtual chat system.+--+-- The virtual chat system sits between the chat drivers and the rest of+-- Lambdabot.  It provides a mapping between the String server "tags" and+-- functions which are able to handle sending messages.+--+-- When a message is recieved, the chat module is expected to call+-- `Lambdabot.Main.received'.  This is not ideal.++addServer :: String -> (IrcMessage -> LB ()) -> ModuleT mod LB ()+addServer tag sendf = do+    s <- lift get+    let svrs = ircServerMap s+    name <- getModuleName+    case M.lookup tag svrs of+        Nothing -> lift (put s { ircServerMap = M.insert tag (name,sendf) svrs})+        Just _ -> fail $ "attempted to create two servers named " ++ tag++remServer :: String -> LB ()+remServer tag = do+    s <- get+    let svrs = ircServerMap s+    case M.lookup tag svrs of+        Just _ -> do+            let svrs' = M.delete tag svrs+            put (s { ircServerMap = svrs' })+            when (M.null svrs') $ do+                quitMVar <- askLB ircQuitMVar+                io $ putMVar quitMVar ()+        Nothing -> fail $ "attempted to delete nonexistent servers named " ++ tag++send :: IrcMessage -> LB ()+send msg = do+    s <- gets ircServerMap+    case M.lookup (Msg.server msg) s of+        Just (_, sendf) -> sendf msg+        Nothing -> io $ hPutStrLn stderr $ "sending message to bogus server: " ++ show msg++received :: IrcMessage -> LB ()+received msg = do+    s       <- get+    handler <- getConfig uncaughtExceptionHandler+    case M.lookup (ircMsgCommand msg) (ircCallbacks s) of+        Just cbs -> mapM_ (\(_, cb) -> cb msg `E.catch` (liftIO . handler)) cbs+        _        -> return ()++-- ---------------------------------------------------------------------+--+-- The LB (LambdaBot) monad+--++-- | The IRC Monad. The reader transformer holds information about the+--   connection to the IRC server.+--+-- instances Monad, Functor, MonadIO, MonadState, MonadError+++newtype LB a = LB { runLB :: ReaderT (IRCRState,IORef IRCRWState) IO a }+    deriving (Functor, Applicative, Monad, MonadIO, MonadException)++instance MonadBase IO LB where+    liftBase = LB . liftBase++instance MonadBaseControl IO LB where+    newtype StM LB a = StLB { unStLB :: StM (ReaderT (IRCRState,IORef IRCRWState) IO) a }+    liftBaseWith action = LB (liftBaseWith (\run -> action (fmap StLB . run . runLB)))+    restoreM = LB . restoreM . unStLB++class (MonadIO m, MonadBaseControl IO m, MonadConfig m, MonadLogging m, Applicative m) => MonadLB m where+    lb :: LB a -> m a++instance MonadLB LB where lb = id+instance MonadLB m => MonadLB (ModuleT st m) where lb = lift . lb+instance MonadLB m => MonadLB (Cmd m)        where lb = lift . lb++instance MonadState IRCRWState LB where+    get = LB $ do+        ref <- asks snd+        lift $ readIORef ref+    put x = LB $ do+        ref <- asks snd+        lift $ writeIORef ref x++instance MonadConfig LB where+    getConfig k = liftM (maybe (getConfigDefault k) id . D.lookup k) (lb (askLB ircConfig))++instance MonadLogging LB where+    getCurrentLogger = getConfig lbRootLoggerPath+    logM a b c = io (logM a b c)++-- | run a computation in the LB monad+evalLB :: LB a -> IRCRState -> IRCRWState -> IO a+evalLB (LB lb') rs rws = do+    ref  <- newIORef rws+    lb' `runReaderT` (rs,ref)++------------------------------------------------------------------------+-- Module handling++-- | Interpret an expression in the context of a module.+-- Arguments are which map to use (@ircModules@ and @ircCommands@ are+-- the only sensible arguments here), the name of the module\/command,+-- action for the case that the lookup fails, action if the lookup+-- succeeds.+--+withModule :: String+           -> LB a+           -> (forall st. Module st -> ModuleT st LB a)+           -> LB a++withModule modname def f = do+    maybemod <- gets (M.lookup modname . ircModules)+    case maybemod of+      -- TODO stick this ref stuff in a monad instead. more portable in+      -- the long run.+      Just (ModuleRef m ref name) -> do+          runReaderT (runModuleT $ f m) (ref, name)+      _                           -> def++withCommand :: String+            -> LB a+            -> (forall st. Module st+                        -> Command (ModuleT st LB)+                        -> ModuleT st LB a)+            -> LB a++withCommand cmdname def f = do+    maybecmd <- gets (M.lookup cmdname . ircCommands)+    case maybecmd of+      -- TODO stick this ref stuff in a monad instead. more portable in+      -- the long run.+      Just (CommandRef m ref name cmd) -> do+          runReaderT (runModuleT $ f m cmd) (ref, name)+      _                           -> def++-- | Interpret a function in the context of all modules+withAllModules :: (forall st. Module st -> ModuleT st LB a) -> LB ()+withAllModules f = do+    mods <- gets $ M.elems . ircModules :: LB [ModuleRef]+    (`mapM_` mods) $ \(ModuleRef m ref name) -> do+        runReaderT (runModuleT $ f m) (ref, name)
+ src/Lambdabot/Monad.hs-boot view
@@ -0,0 +1,5 @@+{-# LANGUAGE RankNTypes #-}+module Lambdabot.Monad where++data LB a+instance Monad LB
+ src/Lambdabot/Nick.hs view
@@ -0,0 +1,46 @@+module Lambdabot.Nick+    ( Nick(..)+    , fmtNick+    , parseNick+    ) where++import Lambdabot.Util++import Data.Char++-- | The type of nicknames isolated from a message.+data Nick = Nick +    { nTag  :: !String -- ^ The tag of the server this nick is on+    , nName :: !String -- ^ The server-specific nickname of this nick+    }++-- This definition of canonicalizeName breaks strict RFC rules, but so does+-- freenode+-- TODO: server-specific rules should have server-specific implementations+canonicalizeName :: String -> String+canonicalizeName = dropSpace . map toUpper++instance Eq Nick where+  (Nick tag name) == (Nick tag2 name2) =+     (canonicalizeName name == canonicalizeName name2) && (tag == tag2)++instance Ord Nick where+  (Nick tag name) <= (Nick tag2 name2) =+     (tag, canonicalizeName name) <= (tag2, canonicalizeName name2)++-- | Format a nickname for display.  This will automatically omit the server+-- field if it is the same as the server of the provided message.+fmtNick :: String -> Nick -> String+fmtNick svr nck+    | nTag nck == svr = nName nck+    | otherwise       = nTag nck ++ ':' : nName nck++-- | Parse a nickname received in a message.  If the server field is not+-- provided, it defaults to the same as that of the message.+parseNick :: String -> String -> Nick+parseNick def str+    | null ac   = Nick def str+    | otherwise = Nick bc ac+    where +        (bc, ac') = break (==':') str+        ac = drop 1 ac'
+ src/Lambdabot/NickEq.hs view
@@ -0,0 +1,59 @@+--+-- | Nickname equality subsystem.+--+-- This component is responsible for deciding whether two nicknames+-- refer to the same person, for the purposes of @tell et al.  Nickname+-- equality must be monadic because it uses mutable state maintained+-- by the @link and @unlink commands.+--+-- Also provided is a concept of polynicks (by analogy to polytypes);+-- polynicks can refer to an (open) set of nicknames.  For instance '@tell+-- *lambdabot Why does X do Y' could tell a message to anyone who has+-- identified as a lambdabot maintainer.  A polynick consists of a+-- bar-separated list of (nicks or open terms); an open term is like a+-- nick but preceded with a star.++module Lambdabot.NickEq+    ( Polynick+    , nickMatches+    , readPolynick+    , showPolynick+    +    , lookupMononickMap+    , mononickToPolynick+    ) where++import Lambdabot.Message+import Lambdabot.Monad+import Lambdabot.Nick++import Data.List (intercalate)+import Data.List.Split (splitOn)+import qualified Data.Map as M+import Data.Maybe (mapMaybe)++data Polynick = Polynick [Nick] deriving (Eq) -- for now++-- |Determine if a nick matches a polynick.  The state is read at the+-- point of binding.+nickMatches :: LB (Nick -> Polynick -> Bool)+nickMatches = return m'+    where+      m' nck (Polynick nck2) = nck `elem` nck2++-- | Parse a read polynick.+readPolynick :: Message a => a -> String -> Polynick+readPolynick m = Polynick . map (parseNick (server m)) . splitOn "|"++-- | Format a polynick.+showPolynick :: Message a => a -> Polynick -> String+showPolynick m (Polynick n) = intercalate "|" $ map (fmtNick (server m)) n++-- | Convert a regular mononick into a polynick.+mononickToPolynick :: Nick -> Polynick+mononickToPolynick = Polynick . (:[])++-- | Lookup (using a polynick) in a map keyed on mononicks.+lookupMononickMap :: LB (Polynick -> M.Map Nick a -> [(Nick,a)])+lookupMononickMap = return $ look'+    where look' (Polynick ns) m = mapMaybe (\n -> (,) n `fmap` M.lookup n m) ns
+ src/Lambdabot/OutputFilter.hs view
@@ -0,0 +1,66 @@+module Lambdabot.OutputFilter+    ( OutputFilter+    , textwidth+    +    , cleanOutput+    , lineify+    , checkRecip+    ) where++import Lambdabot.Nick+import Lambdabot.Util++import Data.Char+import Data.List++type OutputFilter m = Nick -> [String] -> m [String]++textwidth :: Int+textwidth = 200 -- IRC maximum msg length, minus a bit for safety.++-- | For now, this just checks for duplicate empty lines.+cleanOutput :: Monad m => OutputFilter m+cleanOutput _ msg = return $ remDups True msg'+    where+        remDups True  ([]:xs) =    remDups True xs+        remDups False ([]:xs) = []:remDups True xs+        remDups _     (x: xs) = x: remDups False xs+        remDups _     []      = []+        msg' = map dropSpaceEnd msg++-- | wrap long lines.+lineify :: Monad m => OutputFilter m+lineify = const (return . mlines . unlines)++-- | break into lines+mlines :: String -> [String]+mlines = (mbreak =<<) . lines+    where+        mbreak :: String -> [String]+        mbreak xs+            | null bs   = [as]+            | otherwise = (as++cs) : filter (not . null) (mbreak ds)+            where+                (as,bs) = splitAt (w-n) xs+                breaks  = filter (not . isAlphaNum . last . fst) $ drop 1 $+                                  take n $ zip (inits bs) (tails bs)+                (cs,ds) = last $ (take n bs, drop n bs): breaks+                w = textwidth+                n = 10++-- | Don't send any output to alleged bots.+checkRecip :: Monad m => OutputFilter m+checkRecip who msg+--  TODO: this doesn't work with plugin protocols :(+--  | who == Config.name Config.config                  = return []+    | "bot" `isSuffixOf` map toLower (nName who)    = return []+    | otherwise                                         = return msg++-- | Divide the lines' indent by two+{-+reduceIndent :: OutputFilter+reduceIndent _ msg = return $ map redLine msg+    where+        redLine (' ':' ':xs)        = ' ':redLine xs+        redLine xs                  = xs+-}
+ src/Lambdabot/Plugin.hs view
@@ -0,0 +1,70 @@+--+-- Copyright (c) 2006 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)+--+-- Syntactic sugar for developing plugins.+-- Simplifies import lists, and abstracts over common patterns+--+module Lambdabot.Plugin+    ( Module(..)+    , ModuleT+    , newModule+    +    , getModuleName+    , bindModule0+    , bindModule1+    , bindModule2+    +    , LB+    , MonadLB(..)+    , lim80+    , ios80+    +    , ChanName+    , mkCN+    , getCN+    +    , Nick(..)+    , ircPrivmsg+    +    , module Lambdabot.Config+    , module Lambdabot.Config.Core+    , module Lambdabot.Command+    , module Lambdabot.State+    , module Lambdabot.File+    , module Lambdabot.Util+    , module Lambdabot.Util.Serial+    ) where++import Lambdabot+import Lambdabot.ChanName+import Lambdabot.Config+import Lambdabot.Config.Core+import Lambdabot.Command hiding (runCommand, execCmd)+import Lambdabot.File+import Lambdabot.Module+import Lambdabot.Monad+import Lambdabot.Nick+import Lambdabot.State+import Lambdabot.Util+import Lambdabot.Util.Serial++import Codec.Binary.UTF8.String+import Control.Monad+import Control.Monad.Trans+import Data.Char++lim80 :: Monad m => m String -> Cmd m ()+lim80 action = do+    to <- getTarget+    let lim = case nName to of+                  ('#':_) -> limitStr 80 -- message to channel: be nice+                  _       -> id          -- private message: get everything+        spaceOut = unlines . map (' ':) . lines+        removeControl = filter (\x -> isSpace x || not (isControl x))+    (say =<<) . lift $ liftM (lim . encodeString . spaceOut . removeControl . decodeString) action ++-- | convenience, similar to ios but also cut output to channel to 80 characters+-- usage:  @process _ _ to _ s = ios80 to (plugs s)@+ios80 :: MonadIO m => IO String -> Cmd m ()+ios80 = lim80 . io
+ src/Lambdabot/Plugin/Activity.hs view
@@ -0,0 +1,58 @@+-- | Logging an IRC channel..+module Lambdabot.Plugin.Activity (theModule) where++import Lambdabot.Plugin+import Lambdabot++import Control.Arrow ((&&&))+import Control.Exception (evaluate)+import Data.List+import Data.Maybe+import Data.Time++type ActivityState = [(UTCTime,Nick)]+type Activity       = ModuleT ActivityState LB++theModule :: Module [(UTCTime, Nick)]+theModule = newModule+    { moduleDefState = return []+    , moduleInit = bindModule2 activityFilter >>= ircInstallOutputFilter++    , moduleCmds = return+        [ (command "activity")+            { help = say helpStr+            , process = activity False+            }+        , (command "activity-full")+            { help = say helpStr+            , privileged = True+            , process = activity True+            }+        ]+    }++helpStr :: String+helpStr = "activity seconds. Find out where/how much the bot is being used"++activity :: Bool -> String -> Cmd Activity ()+activity full args = do+    let obscure nm+            | full || isPrefixOf "#" (nName nm) = return nm+            | otherwise = readNick "private"++    now <- io getCurrentTime+    let cutoff = addUTCTime (- fromInteger (fromMaybe 90 $ readM args)) now+    users <- mapM (obscure . snd) . takeWhile ((> cutoff) . fst) =<< readMS+    let agg_users = reverse . sort . map (length &&& head) . group . sort $ users+    fmt_agg <- fmap (intercalate " " . (:) (show (length users) ++ "*total"))+                    (mapM (\(n,u) -> do u' <- showNick u; return (show n ++ "*" ++ u')) $ agg_users)++    say fmt_agg++activityFilter :: Nick -> [String] -> Activity [String]+activityFilter target lns = do+    io $ evaluate $ foldr seq () $ map (foldr seq ()) $ lns+    withMS $ \ st wr -> do+        now <- io getCurrentTime+        wr (map (const (now,target)) lns ++ st)+    return lns
+ src/Lambdabot/Plugin/BF.hs view
@@ -0,0 +1,38 @@+-- Copyright (c) 2006 Jason Dagit - http://www.codersbase.com/+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++-- | A plugin for the Haskell interpreter for the brainf*ck language+-- http://www.muppetlabs.com/~breadbox/bf/+module Lambdabot.Plugin.BF (theModule) where++import Lambdabot.Plugin+import Lambdabot.Util.Process++import Data.Char+import Text.Regex.TDFA++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "bf")+            { help = say "bf <expr>. Evaluate a brainf*ck expression"+            , process = \msg -> do+                bf <- getConfig bfBinary+                ios80 (run bf msg scrub)+            }+        ]+    }++-- Clean up output+scrub :: String -> String+scrub = unlines . take 6 . map (' ':) . filter (not.null) . map cleanit . lines++cleanit :: String -> String+cleanit s | s =~ terminated   = "Terminated\n"+          | otherwise         = filter printable s+    where terminated = "waitForProc"+          -- the printable ascii chars are in the range [32 .. 126]+          -- according to wikipedia:+          -- http://en.wikipedia.org/wiki/ASCII#ASCII_printable_characters+          printable x = 31 < ord x && ord x < 127+
+ src/Lambdabot/Plugin/Base.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE PatternGuards #-}+-- | Lambdabot base module. Controls message send and receive+module Lambdabot.Plugin.Base (theModule) where++import Lambdabot+import Lambdabot.Command+import Lambdabot.Config.Core+import Lambdabot.IRC+import Lambdabot.Logging+import Lambdabot.Message+import Lambdabot.Monad+import Lambdabot.Nick+import Lambdabot.Plugin++import Control.Applicative+import Control.Exception.Lifted as E+import Control.Monad+import Control.Monad.State+import Data.List+import Data.List.Split+import qualified Data.Map as M+import Text.EditDistance+import Text.Regex.TDFA++type BaseState = GlobalPrivate () ()+type Base = ModuleT BaseState LB++theModule :: Module (GlobalPrivate () ())+theModule = newModule+    { moduleDefState = return $ mkGlobalPrivate 20 ()+    , moduleInit = do+             ircSignalConnect "PING"    doPING+             bindModule1 doNOTICE >>= ircSignalConnect "NOTICE"+             ircSignalConnect "PART"    doPART+             ircSignalConnect "JOIN"    doJOIN+             ircSignalConnect "NICK"    doNICK+             ircSignalConnect "MODE"    doMODE+             ircSignalConnect "TOPIC"   doTOPIC+             ircSignalConnect "QUIT"    doQUIT+             bindModule1 doPRIVMSG >>= ircSignalConnect "PRIVMSG"+             ircSignalConnect "001"     doRPL_WELCOME++          {- ircSignalConnect "002"     doRPL_YOURHOST+             ircSignalConnect "003"     doRPL_CREATED+             ircSignalConnect "004"     doRPL_MYINFO -}++             ircSignalConnect "005"     doRPL_BOUNCE++          {- ircSignalConnect "250"     doRPL_STATSCONN+             ircSignalConnect "251"     doRPL_LUSERCLIENT+             ircSignalConnect "252"     doRPL_LUSEROP+             ircSignalConnect "253"     doRPL_LUSERUNKNOWN+             ircSignalConnect "254"     doRPL_LUSERCHANNELS+             ircSignalConnect "255"     doRPL_LUSERME+             ircSignalConnect "265"     doRPL_LOCALUSERS+             ircSignalConnect "266"     doRPL_GLOBALUSERS -}++             ircSignalConnect "332"     doRPL_TOPIC++          {- ircSignalConnect "353"     doRPL_NAMRELY+             ircSignalConnect "366"     doRPL_ENDOFNAMES+             ircSignalConnect "372"     doRPL_MOTD+             ircSignalConnect "375"     doRPL_MOTDSTART+             ircSignalConnect "376"     doRPL_ENDOFMOTD -}+    }++doIGNORE :: Callback+doIGNORE = debugM . show++doPING :: Callback+doPING = debugM . errShowMsg++-- If this is a "TIME" then we need to pass it over to the localtime plugin+-- otherwise, dump it to stdout+doNOTICE :: IrcMessage -> Base ()+doNOTICE msg+    | isCTCPTimeReply   = doPRIVMSG (timeReply msg)+        -- TODO: need to say which module to run the privmsg in+    | otherwise         = noticeM (show body)+    where+        body = ircMsgParams msg+        isCTCPTimeReply = ":\SOHTIME" `isPrefixOf` (last body)++doJOIN :: Callback+doJOIN msg | lambdabotName msg /= nick msg = doIGNORE msg+           | otherwise+  = do s <- get+       put (s { ircChannels = M.insert  (mkCN loc) "[currently unknown]" (ircChannels s)}) -- the empty topic causes problems+       send $ getTopic loc -- initialize topic+   where aloc = dropWhile (/= ':') (head (ircMsgParams msg))+         loc       = case aloc of+                        [] -> Nick "freenode" "weird#"+                        _  -> Nick (server msg) (tail aloc)++doPART :: Callback+doPART msg+  = when (lambdabotName msg == nick msg) $ do+        let body = ircMsgParams msg+            loc = Nick (server msg) (head body)+        s <- get+        put (s { ircChannels = M.delete (mkCN loc) (ircChannels s) })++doNICK :: Callback+doNICK msg+  = doIGNORE msg++doMODE :: Callback+doMODE msg+  = doIGNORE msg+++doTOPIC :: Callback+doTOPIC msg+    = do let loc = Nick (server msg) (head (ircMsgParams msg))+         s <- get+         put (s { ircChannels = M.insert (mkCN loc) (tail $ head $ tail $ ircMsgParams msg) (ircChannels s)})++doRPL_WELCOME :: Callback+doRPL_WELCOME = doIGNORE++doQUIT :: Callback+doQUIT msg = doIGNORE msg++doRPL_BOUNCE :: Callback+doRPL_BOUNCE _msg = debugM "BOUNCE!"++doRPL_TOPIC :: Callback+doRPL_TOPIC msg -- nearly the same as doTOPIC but has our nick on the front of body+    = do let body = ircMsgParams msg+             loc = Nick (server msg) (body !! 1)+         s <- get+         put (s { ircChannels = M.insert (mkCN loc) (tail $ last body) (ircChannels s) })++doPRIVMSG :: IrcMessage -> Base ()+doPRIVMSG msg = do+    ignored <- lift $ checkIgnore msg+    commands    <- getConfig commandPrefixes+    evPrefixes  <- getConfig evalPrefixes+    disabled    <- getConfig disabledCommands+    let conf = (commands, evPrefixes, disabled)++    if ignored+        then lift $ doIGNORE msg+        else mapM_ (doPRIVMSG' conf (lambdabotName msg) msg) targets+    where+        alltargets = head (ircMsgParams msg)+        targets = map (parseNick (ircMsgServer msg)) $ splitOn "," alltargets++--+-- | What does the bot respond to?+--+doPRIVMSG' :: ([String], [String], [String]) -> Nick -> IrcMessage -> Nick -> Base ()+doPRIVMSG' configu myname msg target+  | myname == target+    = let (cmd, params) = splitFirstWord text+      in doPersonalMsg cmd params++  | flip any ":," $ \c -> (fmtNick (ircMsgServer msg) myname ++ [c]) `isPrefixOf` text+    = let Just wholeCmd = maybeCommand (fmtNick (ircMsgServer msg) myname) text+          (cmd, params) = splitFirstWord wholeCmd+      in doPublicMsg cmd params++  | (commands `arePrefixesOf` text)+  && length text > 1+  && (text !! 1 /= ' ') -- elem of prefixes+  && (not (commands `arePrefixesOf` [text !! 1]) ||+      (length text > 2 && text !! 2 == ' ')) -- ignore @@ prefix, but not the @@ command itself+    = let (cmd, params) = splitFirstWord (dropWhile (==' ') text)+      in doPublicMsg cmd params++  | otherwise =  doContextualMsg text++  where+    text = tail (head (tail (ircMsgParams msg)))+    who = nick msg++    (commands, evPrefixes, disabled) = configu+    doPersonalMsg s r+        | commands `arePrefixesOf` s  = doMsg (tail s) r who+        | s `elem` evPrefixes         = doMsg "run"    r who+        | otherwise                   = (lift $ doIGNORE msg)++    doPublicMsg s r+        | commands `arePrefixesOf` s            = doMsg (tail s) r target+        | evPrefixes `arePrefixesWithSpaceOf` s = doMsg "run" r target -- TODO+        | otherwise                             = (lift $ doIGNORE msg)++    --+    -- normal commands.+    --+    -- check privledges, do any spell correction, dispatch, handling+    -- possible timeouts.+    --+    -- todo, refactor+    --+    doMsg cmd rest towhere = do+        let ircmsg = ircPrivmsg towhere+        allcmds <- lift (gets (M.keys . ircCommands))+        let ms      = filter (isPrefixOf cmd) allcmds+        case ms of+            [s] -> docmd s                  -- a unique prefix+            _ | cmd `elem` ms -> docmd cmd  -- correct command (usual case)+            _ | otherwise     -> case closests cmd allcmds of+                  (n,[s]) | n < e ,  ms == [] -> docmd s -- unique edit match+                  (n,ss)  | n < e || ms /= []            -- some possibilities+                          -> lift . ircmsg $ "Maybe you meant: "++showClean(nub(ms++ss))+                  _ -> docmd cmd         -- no prefix, edit distance too far+        where+            e = 3   -- edit distance cut off. Seems reasonable for small words++            docmd cmd' = withPS towhere $ \_ _ -> do+                withCommand cmd'   -- Important.+                    (ircPrivmsg towhere "Unknown command, try @list")+                    (\_ theCmd -> do+                        name'   <- getModuleName++                        hasPrivs <- lb (checkPrivs msg)+                        let ok =  (cmd' `notElem` disabled)+                               && (not (privileged theCmd) || hasPrivs)++                        if not ok+                          then lift $ ircPrivmsg towhere "Not enough privileges"+                          else E.catch++                            (do mstrs <- runCommand theCmd msg towhere cmd' rest+                                -- send off our strings+                                lift $ mapM_ (ircPrivmsg towhere . expandTab 8) mstrs)++                            (\exc@SomeException{} -> lift . ircPrivmsg towhere .+                                (("Plugin `" ++ name' ++ "' failed with: ") ++) $ show exc))+    --+    -- contextual messages are all input that isn't an explicit command.+    -- they're passed to all modules (todo, sounds inefficient) for+    -- scanning, and any that implement 'contextual' will reply.+    --+    -- we try to run the contextual functions from all modules, on every+    -- non-command. better hope this is efficient.+    --+    -- Note how we catch any plugin errors here, rather than letting+    -- them bubble back up to the mainloop+    --+    doContextualMsg r = lift $ withAllModules $ \m -> do+        name' <- getModuleName+        E.catch +            (lift . mapM_ (ircPrivmsg target) =<< execCmd (contextual m r) msg target "contextual") +            (\e@SomeException{} -> debugM . (name' ++) . (" module failed in contextual handler: " ++) $ show e)++------------------------------------------------------------------------++closests :: String -> [String] -> (Int,[String])+closests pat ss = M.findMin m+    where+        m = M.fromListWith (++) ls+        ls = [ (levenshteinDistance defaultEditCosts pat s, [s]) | s <- ss ]++maybeCommand :: String -> String -> Maybe String+maybeCommand nm text = mrAfter <$> matchM re text+    where+        re :: Regex+        re = makeRegex (nm ++ "[.:,]*[[:space:]]*")++--+-- And stuff we don't care about+--++{-+doRPL_YOURHOST :: Callback+doRPL_YOURHOST _msg = return ()++doRPL_CREATED :: Callback+doRPL_CREATED _msg = return ()++doRPL_MYINFO :: Callback+doRPL_MYINFO _msg = return ()++doRPL_STATSCONN :: Callback+doRPL_STATSCONN _msg = return ()++doRPL_LUSERCLIENT :: Callback+doRPL_LUSERCLIENT _msg = return ()++doRPL_LUSEROP :: Callback+doRPL_LUSEROP _msg = return ()++doRPL_LUSERUNKNOWN :: Callback+doRPL_LUSERUNKNOWN _msg = return ()++doRPL_LUSERCHANNELS :: Callback+doRPL_LUSERCHANNELS _msg = return ()++doRPL_LUSERME :: Callback+doRPL_LUSERME _msg = return ()++doRPL_LOCALUSERS :: Callback+doRPL_LOCALUSERS _msg = return ()++doRPL_GLOBALUSERS :: Callback+doRPL_GLOBALUSERS _msg = return ()++doUNKNOWN :: Callback+doUNKNOWN msg+    = debugM $ "UNKNOWN> <" ++ msgPrefix msg +++      "> [" ++ msgCommand msg ++ "] " ++ show (body msg)++doRPL_NAMREPLY :: Callback+doRPL_NAMREPLY _msg = return ()++doRPL_ENDOFNAMES :: Callback+doRPL_ENDOFNAMES _msg = return ()++doRPL_MOTD :: Callback+doRPL_MOTD _msg = return ()++doRPL_MOTDSTART :: Callback+doRPL_MOTDSTART _msg = return ()++doRPL_ENDOFMOTD :: Callback+doRPL_ENDOFMOTD _msg = return ()+-}
+ src/Lambdabot/Plugin/Check.hs view
@@ -0,0 +1,27 @@+-- Copyright (c) 6 DonStewart - http://www.cse.unsw.edu.au/~dons+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++-- | Test a property with QuickCheck+module Lambdabot.Plugin.Check (theModule) where++import Lambdabot.Plugin+import Lambdabot.Plugin.Eval (eval)+import qualified Language.Haskell.Exts as Hs++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "check")+            { help = do+                say "check <expr>"+                say "You have QuickCheck and 3 seconds. Prove something."+            , process = lim80 . check+            }+        ]+    }++check :: MonadLB m => String -> m String+check src =+    case Hs.parseExp src of+        Hs.ParseFailed l e  -> return (Hs.prettyPrint l ++ ':' : e)+        Hs.ParseOk{}        -> eval ("myquickcheck (" ++ src ++ ") `seq` hsep[]")
+ src/Lambdabot/Plugin/Check/ShowQ.hs view
@@ -0,0 +1,52 @@+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)+-- Copyright date and holder unknown.+module Lambdabot.Plugin.Check.ShowQ (myquickcheck) where++import Data.List (group, intercalate, sort)+import System.IO.Unsafe (unsafePerformIO)+import Test.QuickCheck (numTests, quickCheckWithResult, stdArgs, Result(..), Testable)++myquickcheck :: Testable prop => prop -> String+myquickcheck = unsafePerformIO . myquickcheck'++myquickcheck' :: Testable prop => prop -> IO String+myquickcheck' a = tests a 0 []++tests :: (Testable prop) => prop -> Int -> [[String]] -> IO String+tests prop ntest stamps =+  do result <- quickCheckWithResult stdArgs prop+     case result of+       NoExpectedFailure{}  -> done "Arguments exhausted after" (numTests result) stamps+       GaveUp{}             -> done "Arguments exhausted after" (numTests result) stamps+       Success{}            -> done "OK, passed" (numTests result) stamps+       Failure{}            -> return $ "Falsifiable, after "+                                  ++ show ntest+                                  ++ " tests:\n"+                                  ++ reason result++done :: String -> Int -> [[String]] -> IO String+done mesg ntest stamps = return $ mesg ++ " " ++ show ntest ++ " tests" ++ table+ where+  table = display+        . map entry+        . reverse+        . sort+        . map pairLength+        . group+        . sort+        . filter (not . null)+        $ stamps++  display []  = "."+  display [x] = " (" ++ x ++ ")."+  display xs  = '.' : unlines (map (++ ".") xs)++  pairLength :: [a] -> (Int, a)+  pairLength [] = (0, error "pairLength should never get an empty list")+  pairLength xss@(xs:_) = (length xss, xs)++  entry (n, xs)         = percentage n ntest+                       ++ intercalate ", " xs++  percentage n m        = show ((100 * n) `div` m) ++ "%"+
+ src/Lambdabot/Plugin/Compose.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE PatternGuards #-}+-- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++-- Another progressive plugin. Compose two (for now) plugins transparently+-- A sort of mini interpreter. Could do with some more thinking.+module Lambdabot.Plugin.Compose (theModule) where++import Lambdabot.Command+import Lambdabot.Monad+import Lambdabot.Plugin++import Control.Arrow (first)+import Control.Monad+import Control.Monad.Trans+import Data.Char+import Data.List+import Data.List.Split++type Compose = ModuleT () LB++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "@")+            { aliases = ["?"]+            , help = do+                c <- getCmdName+                let cc = c++c+                mapM_ say+                    [ cc++" [args]."+                    , cc++" executes plugin invocations in its arguments, parentheses can be used."+                    , " The commands are right associative."+                    , " For example:    "++cc++" "++c++"pl "++c++"undo code"+                    , " is the same as: "++cc++" ("++c++"pl ("++c++"undo code))"+                    ]+            , process = evalBracket+            }+        , (command ".")+            { aliases = ["compose"]+            , help = mapM_ say+                [ ". <cmd1> <cmd2> [args]."+                , ". [or compose] is the composition of two plugins"+                , " The following semantics are used: . f g xs == g xs >>= f"+                ]+            , process = \args -> case splitOn " " args of+                (f:g:xs) -> do+                    f' <- lookupP f+                    g' <- lookupP g+                    lb (compose f' g' (concat $ intersperse " " xs)) >>= mapM_ say+                _ -> say "Not enough arguments to @."+            }+        ]+    }++-- | Compose two plugin functions+compose :: (String -> LB [String]) -> (String -> LB [String]) -> (String -> LB [String])+compose f g xs = g xs >>= f . unlines++------------------------------------------------------------------------+-- | Lookup the `process' method we're after, and apply it to the dummy args+--+lookupP :: String -> Cmd Compose (String -> LB [String])+lookupP cmd = withMsg $ \a -> do+    b <- getTarget+    lb $ withCommand cmd+        (error $ "Unknown command: " ++ show cmd)+        (\_m theCmd -> do+            when (privileged theCmd) $ error "Privileged commands cannot be composed"+            bindModule1 (runCommand theCmd a b cmd))+++------------------------------------------------------------------------++-- | More interesting composition/evaluation+-- @@ @f x y (@g y z)+evalBracket :: String -> Cmd Compose ()+evalBracket args = do+    cmdPrefixes <- getConfig commandPrefixes++    let conf = cmdPrefixes+    xs <- mapM evalExpr (fst (parseBracket 0 True args conf))+    mapM_ (say . addSpace) (concat' xs)+ where concat' ([x]:[y]:xs) = concat' ([x++y]:xs)+       concat' xs           = concat xs++       addSpace :: String -> String+       addSpace (' ':xs) = ' ':xs+       addSpace xs       = ' ':xs++evalExpr :: Expr -> Cmd Compose [String]+evalExpr (Arg s) = return [s]+evalExpr (Cmd c args) = do+     args' <- mapM evalExpr args+     let arg = concat $ concat $ map (intersperse " ") args'+     cmd <- lookupP c+     lift (lift (cmd arg))++------------------------------------------------------------------------++data Expr = Cmd String [Expr]+          | Arg String+    deriving Show++-- TODO: rewrite this using parsec or something+-- | Parse a command invocation that can contain parentheses+--   The Int indicates how many brackets must be closed to end the current argument, or 0+--   The Bool indicates if this is a valid location for a character constant+parseBracket :: Int -> Bool -> String -> [String] -> ([Expr],String)+parseBracket 0 _ [] _       = ([],[])+parseBracket _ _ [] _       = error "Missing ')' in nested command"+parseBracket 1 _ (')':xs) _ = ([],xs)+parseBracket n _ (')':xs) c | n > 0+                            = first (addArg ")") $ parseBracket (n-1) True xs c+parseBracket n _ ('(':xs) c | Just ys <- isCommand xs c     -- (@cmd arg arg)+                            = parseCommand n ys c+parseBracket n _ ('(':xs) c | n > 0+                            = first (addArg "(") $ parseBracket (n+1) True xs c+parseBracket n _ xs c       | Just ('(':ys) <- isCommand xs c -- @(cmd arg arg)+                            = parseCommand n ys c+parseBracket n _ xs c       | Just ys <- isCommand xs c       -- @cmd arg arg+                            = parseInlineCommand n ys c+parseBracket n c (x:xs) cfg | x `elem` "\"'" && (c || x /= '\'')+                            = let (str, ys) = parseString x xs+                                  (rest,zs) = parseBracket n True ys cfg+                              in  (addArg (x:str) rest, zs)+parseBracket n c (x:xs) cfg = first (addArg [x])+                            $ parseBracket n (not (isAlphaNum x) && (c || x /= '\'')) xs cfg++parseCommand, parseInlineCommand :: Int -> String -> [String] -> ([Expr],String)+parseCommand n xs conf = (Cmd cmd args:rest, ws)+    where+        (cmd, ys) = break (`elem` " )") xs+        (args,zs) = parseBracket 1 True (dropWhile (==' ') ys) conf+        (rest,ws) = parseBracket n True zs conf++parseInlineCommand n xs conf = (Cmd cmd rest:[], zs)+  where+    (cmd, ys) = break (`elem` " )") xs+    (rest,zs) = parseBracket n True (dropWhile (==' ') ys) conf++parseString :: Char -> String -> (String, String)+parseString _     []          = ([],[])+parseString delim ('\\':x:xs) = first (\ys -> '\\':x:ys) (parseString delim xs)+parseString delim (x:xs)+  | delim == x                = ([x],xs)+  | otherwise                 = first (x:) (parseString delim xs)+++-- | Does xs start with a command prefix?+isCommand :: String -> [String] -> Maybe String+isCommand xs = msum . map dropPrefix+ where dropPrefix p+          | p `isPrefixOf` xs = Just $ drop (length p) xs+          | otherwise         = Nothing++addArg :: String -> [Expr] -> [Expr]+addArg s (Arg a:es) = Arg (s++a):es+addArg s es         = Arg s     :es
+ src/Lambdabot/Plugin/Dice.hs view
@@ -0,0 +1,38 @@+-- | This module is for throwing dice for e.g. RPGs. (\@dice 3d6+2)++-- Original version copyright Einar Karttunen <ekarttun@cs.helsinki.fi> 2005-04-06.+-- Massive rewrite circa 2008-10-20 copyright James Cook <mokus@deepbondi.net>+module Lambdabot.Plugin.Dice (theModule) where++import Lambdabot.Plugin++import Data.List+import Data.Random.Dice (rollEm)++type Dice = ModuleT () LB++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "dice")+            { aliases = ["roll"]+            , help = say "@dice <expr>. Throw random dice. <expr> is of the form 3d6+2."+            , process = doDice True+            }+        ]+    , contextual = doDice False+    }++doDice :: Bool -> String -> Cmd Dice ()+doDice printErrs text = do+    user <- showNick =<< getSender+    result <- io (rollEm text)+    case result of+        Left err    -> if printErrs+            then say (trimError err)+            else return ()+        Right str   -> +            say (limitStr 75 (user ++ ": " ++ str))+    +    where+        trimError = concat . intersperse ": " . tail . lines . show
+ src/Lambdabot/Plugin/Dict.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE PatternGuards #-}+-- | DICT (RFC 2229) Lookup Module for lambdabot IRC robot.+-- Tom Moertel <tom@moertel.com>+module Lambdabot.Plugin.Dict (theModule) where++import Lambdabot.Plugin+import qualified Lambdabot.Plugin.Dict.DictLookup as Dict++import Control.Monad+import Data.List++type Dict = ModuleT () LB++theModule :: Module ()+theModule = newModule+    { moduleCmds = return $+        [ (command "dict-help")+            { help = getHelp []+            , process = getHelp . words+            }+        ] +++        [ (command name)+            { help = getHelp [name]+            , process = \args -> case parseTerms args of+                [] -> getHelp [name]+                s  -> mapM_ (doLookup >=> sayResult) s+            }+        | (name, (srv, db, _)) <- dictTable+        , let doLookup  = io . Dict.simpleDictLookup srv db+              sayResult = say . either ("Error: " ++) id+        ]+    }++-- | Configuration.++dictTable :: [(String, (Dict.QueryConfig, String, String))]+dictTable =+    -- @command     (server  , database,       description)+    [ ("all-dicts", (dict_org, "*"       ,     "Query all databases on dict.org"))+    , ("bouvier"  , (dict_org, "bouvier",      "Bouvier's Law Dictionary"))+    , ("cide"     , (dict_org, "gcide",        "The Collaborative International Dictionary of English"))+    , ("devils"   , (dict_org, "devil",        "The Devil's Dictionary"))+    , ("easton"   , (dict_org, "easton",       "Easton's 1897 Bible Dictionary"))+    , ("elements" , (dict_org, "elements",     "Elements database"))+    , ("foldoc"   , (dict_org, "foldoc",       "The Free On-line Dictionary of Computing"))+    , ("gazetteer", (dict_org, "gaz2k-places", "U.S. Gazetteer (2000)"))+    , ("hitchcock", (dict_org, "hitchcock",    "Hitchcock's Bible Names Dictionary (late 1800's)"))+    , ("jargon"   , (dict_org, "jargon",       "Jargon File"))+    , ("thesaurus", (dict_org, "moby-thes",    "Moby Thesaurus II"))+    , ("vera"     , (dict_org, "vera",         "V.E.R.A.: Virtual Entity of Relevant Acronyms"))+    , ("wn"       , (dict_org, "wn",           "WordNet (r) 1.7"))+    , ("world02"  , (dict_org, "world02",      "CIA World Factbook 2002"))+    ]+    where+    dict_org    = Dict.QC "dict.org" 2628++dictNames :: [String]+dictNames = sort (map fst dictTable)+++-- | Print out help.++getHelp :: [String] -> Cmd Dict ()+getHelp []    = do+    say ("I perform dictionary lookups via the following "+          ++ show (length dictNames) ++ " commands:\n")+    getHelp dictNames++getHelp dicts = mapM_ (say . gH) dicts+    where+    gH dict | Just (_, _, descr) <- lookup dict dictTable+            = pad dict ++ " " ++ descr++            | otherwise+            = "There is no dictionary database '" ++ dict ++ "'."++    pad xs = take padWidth (xs ++ " " ++ repeat '.')+    padWidth = maximum (map length dictNames) + 4+++-- | Break a string into dictionary-query terms, handling quoting and+-- escaping along the way.  (This is ugly, and I don't particularly+-- like it.)  Given a string like the following, we want to do the+-- right thing, which is to break it into five query strings:+--+--     firefly "c'est la vie" 'pound cake' 'rock n\' roll' et\ al+--+--     (1) firefly+--     (2) "c'est la vie"+--     (3) 'pound cake'+--     (4) 'rock n\' roll'+--     (5) et\ al++parseTerms :: String -> [String]+parseTerms = pW . words+    where+    pW []  = []+    pW (w@(f:_):ws)+        | f `elem` "'\"" = intercalate " " qws : pW ws'+        | last w == '\\' = let (w':rest) = pW ws in intercalate " " [w, w'] : rest+        | otherwise      = w : pW ws+        where+        (qws, ws') = case break isCloseQuotedWord (w:ws) of+            (qws', [])    -> (init qws' ++ [last qws' ++ [f]], [])+            (qw, w':rest) -> (qw ++ [w'], rest)+        isCloseQuotedWord xs = case reverse xs of+            x:y:_ -> f == x && y /= '\\' -- quote doesn't count if escaped+            x:_   -> f == x+            _     -> False+    pW _ = error "DictModule: parseTerms: can't parse"+
+ src/Lambdabot/Plugin/Dict/DictLookup.hs view
@@ -0,0 +1,99 @@+--+-- | DICT (RFC 2229) Lookup +-- Tom Moertel <tom@moertel.com>+-- +--Here's how you might write a program to query the Jargon database for+--the definition of "hacker" and then print the result:+--+-- >  main = doJargonLookup "hacker" >>= putStr+-- >+-- >  doJargonLookup :: String -> IO String+-- >  doJargonLookup query = do+-- >      result <- simpleDictLookup (QC "dict.org" 2628) "jargon" query +-- >      return $ case result of+-- >          Left errorResult -> "ERROR: " ++ errorResult+-- >          Right dictResult -> dictResult+-- >+--+module Lambdabot.Plugin.Dict.DictLookup ( simpleDictLookup, QueryConfig(..), LookupResult) where++import Data.List+import System.IO+import Control.Exception (SomeException, handle)+import Network++data QueryConfig    = QC { host :: String, port :: Int }+type DictConnection = Handle+data DictCommand    = Quit | Define DictName String+type DictName       = String -- dict-db name | "!" 1st match | "*" all matches+type LookupResult   = Either String String -- Left <error> | Right <result>++simpleDictLookup :: QueryConfig -> DictName -> String -> IO LookupResult+simpleDictLookup config dictnm query =+    handle (\e -> (return $ Left (show (e :: SomeException)))) $ do+        conn <- openDictConnection config+        result <- queryDict conn dictnm query+        closeDictConnection conn+        return result++openDictConnection :: QueryConfig -> IO DictConnection+openDictConnection config = do+    hDictServer <- connectTo (host config) (mkPortNumber $ port config)+    hSetBuffering hDictServer LineBuffering+    _ <- readResponseLine hDictServer -- ignore response+    return hDictServer+    where+    mkPortNumber = PortNumber . fromIntegral++closeDictConnection :: DictConnection -> IO ()+closeDictConnection conn = do+    sendCommand conn Quit+    _ <- readResponseLine conn -- ignore response+    hClose conn++{-+queryAllDicts :: DictConnection -> String -> IO LookupResult+queryAllDicts = flip queryDict "*"+-}++queryDict :: DictConnection -> DictName -> String -> IO LookupResult+queryDict conn dictnm query = do+    sendCommand conn (Define dictnm query)+    response <- readResponseLine conn+    case response of+        '1':'5':_     -> readDefinition >>= return . formatDefinition+        '5':'5':'2':_ -> return $ Right ("No match for \"" ++ query ++ "\".\n")+        '5':_         -> return $ Left response -- error response+        _             -> return $ Left ("Bogus response: " ++ response)+            +    where++    readDefinition = do+        line <- readResponseLine conn+        case line of+            '2':'5':'0':_ -> return []+            _             -> readDefinition >>= return . (line:)++    formatDefinition = Right . unlines . concatMap formater++    formater ('1':'5':'1':rest) = ["", "***" ++ rest]+    formater "."                = []+    formater line               = [line]+++readResponseLine :: DictConnection -> IO String+readResponseLine conn = do+    line <- hGetLine conn+    return (filter (/='\r') line)++sendCommand :: DictConnection -> DictCommand -> IO ()+sendCommand conn cmd =+    hSendLine conn $ case cmd of+        Quit -> "QUIT"+        Define db target -> join " " ["DEFINE", db, target]++join :: [a] -> [[a]] -> [a]+join = (concat.) . intersperse++hSendLine :: Handle -> String -> IO ()+hSendLine h line = hPutStr h (line ++ "\r\n")
+ src/Lambdabot/Plugin/Djinn.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE PatternGuards #-}+-- Copyright (c) 2005 Donald Bruce Stewart - http://www.cse.unsw.edu.au/~dons+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++-- Written: Mon Dec 12 10:16:56 EST 2005++-- | A binding to Djinn.+module Lambdabot.Plugin.Djinn (theModule) where++import Lambdabot.Config.Core+import Lambdabot.Logging+import Lambdabot.Plugin++import Control.Exception.Lifted as E+import Control.Monad+import Control.Monad.Trans+import Data.Char+import Data.List+import Data.Maybe+import System.Process (readProcess)+import Text.Regex.TDFA++-- | We can accumulate an interesting environment+type DjinnEnv = ([Decl] {- prelude -}, [Decl])+type Djinn = ModuleT (Maybe DjinnEnv) LB+type Decl = String++theModule :: Module (Maybe DjinnEnv)+theModule = newModule+    { moduleSerialize = Nothing+    , moduleDefState = return Nothing+    +    -- gratuitous invocation at startup to let the user know if the command is missing+    , moduleInit = void (djinn [] "")++    , moduleCmds = return+        [ (command "djinn")+            { help = mapM_ say+                [ "djinn <type>."+                , "Generates Haskell code from a type."+                , "http://darcs.augustsson.net/Darcs/Djinn"+                ]+            , process = rejectingCmds djinnCmd+            }+        , (command "djinn-add")+            { help = do+                say "djinn-add <expr>."+                say "Define a new function type or type synonym"+            , process = rejectingCmds djinnAddCmd+            }+        , (command "djinn-del")+            { help = do+                say "djinn-del <ident>."+                say "Remove a symbol from the environment"+            , process = rejectingCmds djinnDelCmd+            }+        , (command "djinn-env")+            { help = do+                say "djinn-env."+                say "Show the current djinn environment"+            , process = const djinnEnvCmd+            }+        , (command "djinn-names")+            { help = do+                say "djinn-names."+                say "Show the current djinn environment, compactly."+            , process = const djinnNamesCmd+            }+        , (command "djinn-clr")+            { help = do+                say "djinn-clr."+                say "Reset the djinn environment"+            , process = const djinnClrCmd+            }+        , (command "djinn-ver")+            { help = do+                say "djinn-ver."+                say "Show current djinn version"+            , process = const djinnVerCmd+            }+        ]+    }++getSavedEnv :: Djinn DjinnEnv+getSavedEnv = withMS $ \st write -> +    case st of+        Just env -> return env+        Nothing -> do+            st' <- getDjinnEnv ([],[]) -- get the prelude+            +            -- TODO: don't swallow errors here+            let newMS = (either (const []) snd{-!-} st', [])+            write (Just newMS)+            return newMS++getUserEnv :: Djinn [Decl]+getUserEnv = fmap snd getSavedEnv++-- check the args, reject them if they start with a colon (ignoring whitespace)+rejectingCmds :: Monad m => ([Char] -> Cmd m ()) -> [Char] -> Cmd m ()+rejectingCmds action args+    | take 1 (dropWhile isSpace args) == ":"+                = say "Invalid command"+    | otherwise = action args++-- Normal commands+djinnCmd :: [Char] -> Cmd Djinn ()+djinnCmd s = do+        env     <- lift getUserEnv+        e       <- djinn env $ ":set +sorted\nf ? " ++ dropForall s+        mapM_ say $ either id (parse . lines) e+    where+      dropForall t = maybe t mrAfter (t =~~ re)+      re = "^forall [[:alnum:][:space:]]+\\."+      parse :: [String] -> [String]+      parse x = if length x < 2+                then ["No output from Djinn; installed?"]+                else tail x++-- Augment environment. Have it checked by djinn.+djinnAddCmd :: [Char] -> Cmd Djinn ()+djinnAddCmd s = do+    (p,st)  <- lift getSavedEnv+    est     <- getDjinnEnv (p, dropSpace s : st)+    case est of+        Left e     -> say (head e)+        Right st'  -> writeMS (Just st')++-- Display the environment+djinnEnvCmd :: Cmd Djinn ()+djinnEnvCmd = do+    (prelude,st) <- lift getSavedEnv+    mapM_ say $ prelude ++ st++-- Display the environment's names (quarter-baked)+djinnNamesCmd :: Cmd Djinn ()+djinnNamesCmd = do+    (prelude,st) <- lift getSavedEnv+    let names = concat $ intersperse " " $ concatMap extractNames $ prelude ++ st+    say names+  where extractNames = filter (isUpper . head) . unfoldr (\x -> case x of _:_ -> listToMaybe (lex x); _ -> Nothing)++-- Reset the env+djinnClrCmd :: Cmd Djinn ()+djinnClrCmd = writeMS Nothing++-- Remove sym from environment. We let djinn do the hard work of+-- looking up the symbols.+djinnDelCmd :: [Char] -> Cmd Djinn ()+djinnDelCmd s =  do+    (_,env) <- lift getSavedEnv+    eenv <- djinn env $ ":delete " ++ dropSpace s ++ "\n:environment"+    case eenv of+        Left e     -> say (head e)+        Right env' -> modifyMS . fmap $ \(prel,_) ->+            (prel,filter (`notElem` prel) . nub . lines $ env')++-- Version number+djinnVerCmd :: Cmd Djinn ()+djinnVerCmd = say =<< getDjinnVersion++------------------------------------------------------------------------++-- | Extract the default environment+getDjinnEnv :: (MonadLB m) => DjinnEnv -> m (Either [String] DjinnEnv)+getDjinnEnv (prel,env') = do+    env <- djinn env' ":environment"+    return (either Left (Right . readEnv) env)+    where+        readEnv o = let new = filter (\p -> p `notElem` prel) . nub .  lines $ o+                     in (prel, new)++getDjinnVersion :: MonadLB m => m String+getDjinnVersion = do+    binary <- getConfig djinnBinary+    io (fmap readVersion (readProcess binary [] ":q"))+        `E.catch` \SomeException{} ->+            return "The djinn command does not appear to be installed."+    where +        readVersion = extractVersion . unlines . take 1 . lines+        extractVersion str = case str =~~ "version [0-9]+(-[0-9]+)*" of+            Nothing -> "Unknown"+            Just m  -> m++-- | Call the binary:++djinn :: MonadLB m => [Decl] -> String -> m (Either [String] String)+djinn env src = do+    binary <- getConfig djinnBinary+    io (tryDjinn binary env src)+        `E.catch` \e@SomeException{} -> do+            let cmdDesc = case binary of+                    "djinn" -> ""+                    _       -> "(" ++ binary ++ ") "+                msg = "Djinn command " ++ cmdDesc ++ "failed: " ++ show e+            errorM msg+            return (Left [msg])++tryDjinn :: String -> [Decl] -> String -> IO (Either [String] String)+tryDjinn binary env src = do+    out <- readProcess binary [] (unlines (env ++ [src, ":q"]))+    let safeInit [] = []+        safeInit xs = init xs+        o = dropNL . clean_ . unlines . safeInit . drop 2 . lines $ out+    return $ case () of {_+        | o =~ "Cannot parse command" ||+          o =~ "cannot be realized"   ||+          o =~ "^Error:"                -> Left (lines o)+        | otherwise                     -> Right o+    }++--+-- Clean up djinn output+--+clean_ :: String -> String+clean_ s | Just mr <- s =~~ prompt  = mrBefore mr ++ mrAfter mr+         | otherwise                = s+    where+        prompt = "(Djinn> *)+"
+ src/Lambdabot/Plugin/Dummy.hs view
@@ -0,0 +1,114 @@+-- | Simple template module+-- Contains many constant bot commands.+module Lambdabot.Plugin.Dummy (theModule) where++import Lambdabot.Plugin+import Lambdabot.Plugin.Dummy.DocAssocs (docAssocs)++import Data.Char+import qualified Data.ByteString.Char8 as P+import qualified Data.Map as M+import System.FilePath++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        $ (command "eval")+            { help = say "eval. Do nothing (perversely)"+            , process = const (return ())+            }+        : (command "choose")+            { help = say "choose. Lambdabot featuring AI power"+            , process = \args ->+                if null args then say "Choose between what?"+                    else say =<< (io . random . words $ args)+            }+        : [ (command cmd)+            { help = say (dummyHelp cmd)+            , process = mapM_ say . lines . op+            }+          | (cmd, op) <- dummylst+          ]++    , contextual = \msg -> case msg of+        "lisppaste2: url"  -> say "Haskell pastebin: http://hpaste.org/"+        _                  -> return ()+    }++dummyHelp :: String -> String+dummyHelp s = case s of+    "dummy"       -> "dummy. Print a string constant"+    "bug"         -> "bug. Submit a bug to GHC's trac"+    "id"          -> "id <arg>. The identity plugin"+    "show"        -> "show <foo>. Print \"<foo>\""+    "wiki"        -> "wiki <page>. URLs of Haskell wiki pages"+    "paste"       -> "paste. Paste page url"+    "docs"        -> "docs <lib>. Lookup the url for this library's documentation"+    "learn"       -> "learn. The learning page url"+    "haskellers"  -> "haskellers. Find other Haskell users"+    "botsnack"    -> "botsnack. Feeds the bot a snack"+    "get-shapr"   -> "get-shapr. Summon shapr instantly"+    "shootout"    -> "shootout. The debian language shootout"+    "faq"         -> "faq. Answer frequently asked questions about Haskell"+    "googleit"    -> "letmegooglethatforyou."+    "hackage"     -> "find stuff on hackage"+    _             -> "I'm sorry Dave, I'm affraid I don't know that command"++dummylst :: [(String, String -> String)]+dummylst =+    [("dummy"      , const "dummy")+    ,("bug"        , const "http://hackage.haskell.org/trac/ghc/newticket?type=bug")+    ,("id"         , (' ' :) . id)+    ,("show"       , show)+    ,("wiki"       , lookupWiki)+    ,("paste"      , const "Haskell pastebin: http://hpaste.org/")+    ,("docs"       , \x -> if null x+                           then docPrefix </> "index.html"+                           else lookupPackage docPrefix '-' "html" x)+    ,("learn"      , const "http://www.haskell.org/haskellwiki/Learning_Haskell")+    ,("haskellers" , const "http://www.haskellers.com/")+    ,("botsnack"   , const ":)")+    ,("get-shapr"  , const "shapr!!")+    ,("shootout"   , const "http://shootout.alioth.debian.org/gp4/benchmark.php?test=all&lang=all")+    ,("faq"        , const "The answer is: Yes! Haskell can do that.")+    ,("googleit"   , lookupGoogle)+    ,("hackage"    , lookupHackage)+    ,("thanks"     , const "you are welcome")+    ,("thx"        , const "you are welcome")+    ,("thank you"  , const "you are welcome")+    ,("ping"       , const "pong")+    ,("tic-tac-toe", const "how about a nice game of chess?")+    ]++lookupWiki :: String -> String+lookupWiki page = "http://www.haskell.org/haskellwiki" </> spacesToUnderscores page+  where spacesToUnderscores = map (\c -> if c == ' ' then '_' else c)++lookupHackage :: String -> String+lookupHackage "" = "http://hackage.haskell.org"+lookupHackage xs = "http://hackage.haskell.org/package" </> xs++googlePrefix :: String+googlePrefix = "http://letmegooglethatforyou.com"++lookupGoogle :: String -> String+lookupGoogle "" = googlePrefix+lookupGoogle xs = googlePrefix </> "?q=" ++ quote xs+ where+    quote = map (\x -> if x == ' ' then '+' else x)++docPrefix :: String+docPrefix = "http://haskell.org/ghc/docs/latest/html/libraries"++lookupPackage :: String -> Char -> String -> String -> String+lookupPackage begin sep end x'' = +    case M.lookup (P.pack x') docAssocs of+        Nothing -> x ++ " not available"+        Just m  -> begin+               </> P.unpack m+               </> map (choice (=='.') (const sep) id) x'+               <.> end+    where +        choice p f g = p >>= \b -> if b then f else g+        x  = dropSpace x''+        x' = map toLower x
+ src/Lambdabot/Plugin/Dummy/DocAssocs.hs view
@@ -0,0 +1,385 @@++module Lambdabot.Plugin.Dummy.DocAssocs (docAssocs) where++import qualified Data.Map as M+import qualified Data.ByteString.Char8 as P++-- pack all these strings++base :: P.ByteString+base = P.pack "base"+stm :: P.ByteString+stm  = P.pack "stm"+mtl :: P.ByteString+mtl  = P.pack "mtl"+fgl :: P.ByteString+fgl  = P.pack "fgl"+qc  :: P.ByteString+qc   = P.pack "QuickCheck"+hunit  :: P.ByteString+hunit = P.pack "bytestring"+parsec  :: P.ByteString+parsec = P.pack "parsec"+unix  :: P.ByteString+unix   = P.pack "unix"+haskeline :: P.ByteString+haskeline = P.pack "haskeline"+network :: P.ByteString+network  = P.pack "network"+th :: P.ByteString+th       = P.pack "template-haskell"+hs :: P.ByteString+hs       = P.pack "1"+cabal :: P.ByteString+cabal    = P.pack "Cabal"+hgl :: P.ByteString+hgl      = P.pack "3"+glut :: P.ByteString+glut     = P.pack "GLUT"+x11 :: P.ByteString+x11      = P.pack "3"+opengl :: P.ByteString+opengl   = P.pack "OpenGL"+containers :: P.ByteString+containers = P.pack "containers"++docAssocs :: M.Map P.ByteString P.ByteString+docAssocs = {-# SCC "Dummy.DocAssocs" #-} M.fromList [+  (P.pack "control.arrow", base),+  (P.pack "control.concurrent", base),+  (P.pack "control.concurrent.chan", base),+  (P.pack "control.concurrent.mvar", base),+  (P.pack "control.concurrent.qsem", base),+  (P.pack "control.concurrent.qsemn", base),+  (P.pack "control.concurrent.stm", stm),+  (P.pack "control.concurrent.stm.tchan", stm),+  (P.pack "control.concurrent.stm.tmvar", stm),+  (P.pack "control.concurrent.stm.tvar", stm),+  (P.pack "control.concurrent.samplevar", base),+  (P.pack "control.exception", base),+  (P.pack "control.monad", base),+  (P.pack "control.monad.cont", mtl),+  (P.pack "control.monad.error", mtl),+  (P.pack "control.monad.fix", base),+  (P.pack "control.monad.identity", mtl),+  (P.pack "control.monad.list", mtl),+  (P.pack "control.monad.rws", mtl),+  (P.pack "control.monad.reader", mtl),+  (P.pack "control.monad.st", base),+  (P.pack "control.monad.st.lazy", base),+  (P.pack "control.monad.st.strict", base),+  (P.pack "control.monad.state", mtl),+  (P.pack "control.monad.trans", mtl),+  (P.pack "control.monad.writer", mtl),+  (P.pack "control.parallel", base),+  (P.pack "control.parallel.strategies", base),+  (P.pack "data.array", base),+  (P.pack "data.array.diff", base),+  (P.pack "data.array.iarray", base),+  (P.pack "data.array.io", base),+  (P.pack "data.array.marray", base),+  (P.pack "data.array.st", base),+  (P.pack "data.array.storable", base),+  (P.pack "data.array.unboxed", base),+  (P.pack "data.bits", base),+  (P.pack "data.bool", base),+  (P.pack "data.char", base),+  (P.pack "data.complex", base),+  (P.pack "data.dynamic", base),+  (P.pack "data.either", base),+  (P.pack "data.finitemap", base),+  (P.pack "data.functorm", base),+  (P.pack "data.generics", base),+  (P.pack "data.generics.aliases", base),+  (P.pack "data.generics.basics", base),+  (P.pack "data.generics.instances", base),+  (P.pack "data.generics.schemes", base),+  (P.pack "data.generics.text", base),+  (P.pack "data.generics.twins", base),+  (P.pack "data.graph", containers),+  (P.pack "data.graph.inductive", fgl),+  (P.pack "data.graph.inductive.basic", fgl),+  (P.pack "data.graph.inductive.example", fgl),+  (P.pack "data.graph.inductive.graph", fgl),+  (P.pack "data.graph.inductive.graphviz", fgl),+  (P.pack "data.graph.inductive.internal.finitemap", fgl),+  (P.pack "data.graph.inductive.internal.heap", fgl),+  (P.pack "data.graph.inductive.internal.queue", fgl),+  (P.pack "data.graph.inductive.internal.rootpath", fgl),+  (P.pack "data.graph.inductive.internal.thread", fgl),+  (P.pack "data.graph.inductive.monad", fgl),+  (P.pack "data.graph.inductive.monad.ioarray", fgl),+  (P.pack "data.graph.inductive.nodemap", fgl),+  (P.pack "data.graph.inductive.query", fgl),+  (P.pack "data.graph.inductive.query.artpoint", fgl),+  (P.pack "data.graph.inductive.query.bcc", fgl),+  (P.pack "data.graph.inductive.query.bfs", fgl),+  (P.pack "data.graph.inductive.query.dfs", fgl),+  (P.pack "data.graph.inductive.query.dominators", fgl),+  (P.pack "data.graph.inductive.query.gvd", fgl),+  (P.pack "data.graph.inductive.query.indep", fgl),+  (P.pack "data.graph.inductive.query.mst", fgl),+  (P.pack "data.graph.inductive.query.maxflow", fgl),+  (P.pack "data.graph.inductive.query.maxflow2", fgl),+  (P.pack "data.graph.inductive.query.monad", fgl),+  (P.pack "data.graph.inductive.query.sp", fgl),+  (P.pack "data.graph.inductive.query.transclos", fgl),+  (P.pack "data.graph.inductive.tree", fgl),+  (P.pack "data.hashtable", base),+  (P.pack "data.ioref", base),+  (P.pack "data.int", base),+  (P.pack "data.intmap", containers),+  (P.pack "data.intset", containers),+  (P.pack "data.ix", base),+  (P.pack "data.list", base),+  (P.pack "data.map", containers),+  (P.pack "data.maybe", base),+  (P.pack "data.monoid", base),+  (P.pack "data.packedstring", base),+  (P.pack "data.queue", base),+  (P.pack "data.ratio", base),+  (P.pack "data.stref", base),+  (P.pack "data.stref.lazy", base),+  (P.pack "data.stref.strict", base),+  (P.pack "data.sequence", containers),+  (P.pack "data.set", containers),+  (P.pack "data.tree", containers),+  (P.pack "data.tuple", base),+  (P.pack "data.typeable", base),+  (P.pack "data.unique", base),+  (P.pack "data.version", base),+  (P.pack "data.word", base),+  (P.pack "debug.quickcheck", qc),+  (P.pack "debug.quickcheck.batch", qc),+  (P.pack "debug.quickcheck.poly", qc),+  (P.pack "debug.quickcheck.utils", qc),+  (P.pack "debug.trace", base),+  (P.pack "distribution.compat.directory", cabal),+  (P.pack "distribution.compat.exception", cabal),+  (P.pack "distribution.compat.filepath", cabal),+  (P.pack "distribution.compat.rawsystem", cabal),+  (P.pack "distribution.compat.readp", cabal),+  (P.pack "distribution.extension", cabal),+  (P.pack "distribution.getopt", cabal),+  (P.pack "distribution.installedpackageinfo", cabal),+  (P.pack "distribution.license", cabal),+  (P.pack "distribution.make", cabal),+  (P.pack "distribution.package", cabal),+  (P.pack "distribution.packagedescription", cabal),+  (P.pack "distribution.preprocess", cabal),+  (P.pack "distribution.preprocess.unlit", cabal),+  (P.pack "distribution.setup", cabal),+  (P.pack "distribution.simple", cabal),+  (P.pack "distribution.simple.build", cabal),+  (P.pack "distribution.simple.configure", cabal),+  (P.pack "distribution.simple.ghcpackageconfig", cabal),+  (P.pack "distribution.simple.install", cabal),+  (P.pack "distribution.simple.localbuildinfo", cabal),+  (P.pack "distribution.simple.register", cabal),+  (P.pack "distribution.simple.srcdist", cabal),+  (P.pack "distribution.simple.utils", cabal),+  (P.pack "distribution.version", cabal),+  (P.pack "foreign", base),+  (P.pack "foreign.c", base),+  (P.pack "foreign.c.error", base),+  (P.pack "foreign.c.string", base),+  (P.pack "foreign.c.types", base),+  (P.pack "foreign.concurrent", base),+  (P.pack "foreign.foreignptr", base),+  (P.pack "foreign.marshal", base),+  (P.pack "foreign.marshal.alloc", base),+  (P.pack "foreign.marshal.array", base),+  (P.pack "foreign.marshal.error", base),+  (P.pack "foreign.marshal.pool", base),+  (P.pack "foreign.marshal.utils", base),+  (P.pack "foreign.ptr", base),+  (P.pack "foreign.stableptr", base),+  (P.pack "foreign.storable", base),+  (P.pack "ghc.conc", base),+  (P.pack "ghc.consolehandler", base),+  (P.pack "ghc.dotnet", base),+  (P.pack "ghc.exts", base),+  (P.pack "graphics.hgl", hgl),+  (P.pack "graphics.hgl.core", hgl),+  (P.pack "graphics.hgl.draw", hgl),+  (P.pack "graphics.hgl.draw.brush", hgl),+  (P.pack "graphics.hgl.draw.font", hgl),+  (P.pack "graphics.hgl.draw.monad", hgl),+  (P.pack "graphics.hgl.draw.pen", hgl),+  (P.pack "graphics.hgl.draw.picture", hgl),+  (P.pack "graphics.hgl.draw.region", hgl),+  (P.pack "graphics.hgl.draw.text", hgl),+  (P.pack "graphics.hgl.key", hgl),+  (P.pack "graphics.hgl.run", hgl),+  (P.pack "graphics.hgl.units", hgl),+  (P.pack "graphics.hgl.utils", hgl),+  (P.pack "graphics.hgl.window", hgl),+  (P.pack "graphics.rendering.opengl", opengl),+  (P.pack "graphics.rendering.opengl.gl", opengl),+  (P.pack "graphics.rendering.opengl.gl.antialiasing", opengl),+  (P.pack "graphics.rendering.opengl.gl.basictypes", opengl),+  (P.pack "graphics.rendering.opengl.gl.beginend", opengl),+  (P.pack "graphics.rendering.opengl.gl.bitmaps", opengl),+  (P.pack "graphics.rendering.opengl.gl.bufferobjects", opengl),+  (P.pack "graphics.rendering.opengl.gl.clipping", opengl),+  (P.pack "graphics.rendering.opengl.gl.colorsum", opengl),+  (P.pack "graphics.rendering.opengl.gl.colors", opengl),+  (P.pack "graphics.rendering.opengl.gl.coordtrans", opengl),+  (P.pack "graphics.rendering.opengl.gl.displaylists", opengl),+  (P.pack "graphics.rendering.opengl.gl.evaluators", opengl),+  (P.pack "graphics.rendering.opengl.gl.feedback", opengl),+  (P.pack "graphics.rendering.opengl.gl.flushfinish", opengl),+  (P.pack "graphics.rendering.opengl.gl.fog", opengl),+  (P.pack "graphics.rendering.opengl.gl.framebuffer", opengl),+  (P.pack "graphics.rendering.opengl.gl.hints", opengl),+  (P.pack "graphics.rendering.opengl.gl.linesegments", opengl),+  (P.pack "graphics.rendering.opengl.gl.perfragment", opengl),+  (P.pack "graphics.rendering.opengl.gl.pixelrectangles", opengl),+  (P.pack "graphics.rendering.opengl.gl.pixelrectangles.colortable", opengl),+  (P.pack "graphics.rendering.opengl.gl.pixelrectangles.convolution", opengl),+  (P.pack "graphics.rendering.opengl.gl.pixelrectangles.histogram", opengl),+  (P.pack "graphics.rendering.opengl.gl.pixelrectangles.minmax", opengl),+  (P.pack "graphics.rendering.opengl.gl.pixelrectangles.pixelmap", opengl),+  (P.pack "graphics.rendering.opengl.gl.pixelrectangles.pixelstorage", opengl),+  (P.pack "graphics.rendering.opengl.gl.pixelrectangles.pixeltransfer", opengl),+  (P.pack "graphics.rendering.opengl.gl.pixelrectangles.rasterization", opengl),+  (P.pack "graphics.rendering.opengl.gl.points", opengl),+  (P.pack "graphics.rendering.opengl.gl.polygons", opengl),+  (P.pack "graphics.rendering.opengl.gl.rasterpos", opengl),+  (P.pack "graphics.rendering.opengl.gl.readcopypixels", opengl),+  (P.pack "graphics.rendering.opengl.gl.rectangles", opengl),+  (P.pack "graphics.rendering.opengl.gl.savingstate", opengl),+  (P.pack "graphics.rendering.opengl.gl.selection", opengl),+  (P.pack "graphics.rendering.opengl.gl.statevar", opengl),+  (P.pack "graphics.rendering.opengl.gl.stringqueries", opengl),+  (P.pack "graphics.rendering.opengl.gl.texturing", opengl),+  (P.pack "graphics.rendering.opengl.gl.texturing.application", opengl),+  (P.pack "graphics.rendering.opengl.gl.texturing.environments", opengl),+  (P.pack "graphics.rendering.opengl.gl.texturing.objects", opengl),+  (P.pack "graphics.rendering.opengl.gl.texturing.parameters", opengl),+  (P.pack "graphics.rendering.opengl.gl.texturing.queries", opengl),+  (P.pack "graphics.rendering.opengl.gl.texturing.specification", opengl),+  (P.pack "graphics.rendering.opengl.gl.vertexarrays", opengl),+  (P.pack "graphics.rendering.opengl.gl.vertexspec", opengl),+  (P.pack "graphics.rendering.opengl.glu", opengl),+  (P.pack "graphics.rendering.opengl.glu.errors", opengl),+  (P.pack "graphics.rendering.opengl.glu.initialization", opengl),+  (P.pack "graphics.rendering.opengl.glu.matrix", opengl),+  (P.pack "graphics.rendering.opengl.glu.mipmapping", opengl),+  (P.pack "graphics.rendering.opengl.glu.nurbs", opengl),+  (P.pack "graphics.rendering.opengl.glu.quadrics", opengl),+  (P.pack "graphics.rendering.opengl.glu.tessellation", opengl),+  (P.pack "graphics.soe", hgl),+  (P.pack "graphics.ui.glut", glut),+  (P.pack "graphics.ui.glut.begin", glut),+  (P.pack "graphics.ui.glut.callbacks", glut),+  (P.pack "graphics.ui.glut.callbacks.global", glut),+  (P.pack "graphics.ui.glut.callbacks.window", glut),+  (P.pack "graphics.ui.glut.colormap", glut),+  (P.pack "graphics.ui.glut.debugging", glut),+  (P.pack "graphics.ui.glut.devicecontrol", glut),+  (P.pack "graphics.ui.glut.fonts", glut),+  (P.pack "graphics.ui.glut.gamemode", glut),+  (P.pack "graphics.ui.glut.initialization", glut),+  (P.pack "graphics.ui.glut.menu", glut),+  (P.pack "graphics.ui.glut.objects", glut),+  (P.pack "graphics.ui.glut.overlay", glut),+  (P.pack "graphics.ui.glut.state", glut),+  (P.pack "graphics.ui.glut.window", glut),+  (P.pack "graphics.x11.types", x11),+  (P.pack "graphics.x11.xlib", x11),+  (P.pack "graphics.x11.xlib.atom", x11),+  (P.pack "graphics.x11.xlib.color", x11),+  (P.pack "graphics.x11.xlib.context", x11),+  (P.pack "graphics.x11.xlib.display", x11),+  (P.pack "graphics.x11.xlib.event", x11),+  (P.pack "graphics.x11.xlib.font", x11),+  (P.pack "graphics.x11.xlib.misc", x11),+  (P.pack "graphics.x11.xlib.region", x11),+  (P.pack "graphics.x11.xlib.screen", x11),+  (P.pack "graphics.x11.xlib.types", x11),+  (P.pack "graphics.x11.xlib.window", x11),+  (P.pack "language.haskell.parser", hs),+  (P.pack "language.haskell.pretty", hs),+  (P.pack "language.haskell.syntax", hs),+  (P.pack "language.haskell.th", th),+  (P.pack "language.haskell.th.lib", th),+  (P.pack "language.haskell.th.ppr", th),+  (P.pack "language.haskell.th.pprlib", th),+  (P.pack "language.haskell.th.syntax", th),+  (P.pack "network", network),+  (P.pack "network.bsd", network),+  (P.pack "network.cgi", network),+  (P.pack "network.socket", network),+  (P.pack "network.uri", network),+  (P.pack "numeric", base),+  (P.pack "prelude", base),+  (P.pack "system.cputime", base),+  (P.pack "system.cmd", base),+  (P.pack "system.console.getopt", base),+  (P.pack "system.console.haskeline", haskeline),+  (P.pack "system.directory", base),+  (P.pack "system.environment", base),+  (P.pack "system.exit", base),+  (P.pack "system.io", base),+  (P.pack "system.io.error", base),+  (P.pack "system.io.unsafe", base),+  (P.pack "system.info", base),+  (P.pack "system.locale", base),+  (P.pack "system.mem", base),+  (P.pack "system.mem.stablename", base),+  (P.pack "system.mem.weak", base),+  (P.pack "system.posix", unix),+  (P.pack "system.posix.directory", unix),+  (P.pack "system.posix.dynamiclinker", unix),+  (P.pack "system.posix.dynamiclinker.module", unix),+  (P.pack "system.posix.dynamiclinker.prim", unix),+  (P.pack "system.posix.env", unix),+  (P.pack "system.posix.error", unix),+  (P.pack "system.posix.files", unix),+  (P.pack "system.posix.io", unix),+  (P.pack "system.posix.process", unix),+  (P.pack "system.posix.resource", unix),+  (P.pack "system.posix.signals", base),+  (P.pack "system.posix.signals.exts", unix),+  (P.pack "system.posix.temp", unix),+  (P.pack "system.posix.terminal", unix),+  (P.pack "system.posix.time", unix),+  (P.pack "system.posix.types", base),+  (P.pack "system.posix.unistd", unix),+  (P.pack "system.posix.user", unix),+  (P.pack "system.process", base),+  (P.pack "system.random", base),+  (P.pack "system.time", base),+  (P.pack "test.hunit", hunit),+  (P.pack "test.hunit.base", hunit),+  (P.pack "test.hunit.lang", hunit),+  (P.pack "test.hunit.terminal", hunit),+  (P.pack "test.hunit.text", hunit),+  (P.pack "test.quickcheck", qc),+  (P.pack "test.quickcheck.batch", qc),+  (P.pack "test.quickcheck.poly", qc),+  (P.pack "test.quickcheck.utils", qc),+  (P.pack "text.html", base),+  (P.pack "text.html.blocktable", base),+  (P.pack "text.parsercombinators.parsec", parsec),+  (P.pack "text.parsercombinators.parsec.char", parsec),+  (P.pack "text.parsercombinators.parsec.combinator", parsec),+  (P.pack "text.parsercombinators.parsec.error", parsec),+  (P.pack "text.parsercombinators.parsec.expr", parsec),+  (P.pack "text.parsercombinators.parsec.language", parsec),+  (P.pack "text.parsercombinators.parsec.perm", parsec),+  (P.pack "text.parsercombinators.parsec.pos", parsec),+  (P.pack "text.parsercombinators.parsec.prim", parsec),+  (P.pack "text.parsercombinators.parsec.token", parsec),+  (P.pack "text.parsercombinators.readp", base),+  (P.pack "text.parsercombinators.readprec", base),+  (P.pack "text.prettyprint", base),+  (P.pack "text.prettyprint.hughespj", base),+  (P.pack "text.printf", base),+  (P.pack "text.read", base),+  (P.pack "text.read.lex", base),+  (P.pack "text.regex", base),+  (P.pack "text.regex.posix", base),+  (P.pack "text.show", base),+  (P.pack "text.show.functions", base)]
+ src/Lambdabot/Plugin/Elite.hs view
@@ -0,0 +1,92 @@+-- (c) Josef Svenningsson, 2005+-- Licence: No licence, public domain++-- Inspired by the following page:+-- http://www.microsoft.com/athome/security/children/kidtalk.mspx+module Lambdabot.Plugin.Elite (theModule) where++import Lambdabot.Plugin++import Control.Arrow+import Control.Monad+import Data.Char+import Data.Maybe+import Text.Regex.TDFA++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "elite")+            { aliases = ["leet", "l33t", "1337"]+            , help = say "elite <phrase>. Translate English to elitespeak"+            , process = \args -> case words args of+                 [] -> say "Say again?"+                 wds -> do let instr = map toLower (unwords wds)+                           say =<< io (translateLine instr)+                           +            }+        ]+    }++translateLine :: String -> IO String+translateLine = fmap (dropWhile isSpace) . translate . (' ':)+-- extra space allows whole-word patterns to match at start++translate :: String -> IO String+translate []  = return []+translate str = do+    let alts = [ (subst match',rest)+               | (re, subst) <- ruleList+               , mr <- maybeToList (matchM re str)+               , null (mrBefore mr)+               , let match' = mrMatch mr+                     rest   = mrAfter mr+               ]+    (subst,rest) <- random alts+    liftM (subst ++) (translate rest)++ruleList :: [(Regex, String -> String)]+ruleList = map (first makeRegex)+    [ (".",     id            )+    , (".",     map toUpper   )+    , ("a",     const "4"     )+    , ("b",     const "8"     )+    , (" be ",  const " b "   )+    , ("c",     const "("     )+    , ("ck",    const "xx"    )+    , ("cks ",  const "x "    )+    , ("cks ",  const "x0rs " )+    , ("cks ",  const "x0rz " )+    , (" cool ",const " kewl ")+    , ("e",     const "3"     )+    , ("elite", const "1337"  )+    , ("elite", const "leet"  )+    , ("f",     const "ph"    )+    , (" for ", const " 4 "   )+    , ("g",     const "9"     )+    , ("h",     const "|-|"   )+    , ("k",     const "x"     )+    , ("l",     const "|"     )+    , ("l",     const "1"     )+    , ("m",     const "/\\/\\")+    , ("o",     const "0"     )+    , ("ph",    const "f"     )+    , ("s",     const "z"     )+    , ("s",     const "$"     )+    , ("s",     const "5"     )+    , ("s ",    const "z0rz " )+    , ("t",     const "7"     )+    , ("t",     const "+"     )+    , (" the ", const " teh " )+    , (" to ",  const " 2 "   )+    , (" to ",  const " too " )+    , (" to ",  const " tu "  )+    , (" too ", const " to "  )+    , ("v",     const "\\/"   )+    , ("w",     const "\\/\\/")+    , (" you ", const " u "   )+    , (" you ", const " yu "  )+    , (" you ", const " joo " )+    , ("z",     const "s"     )+    ]+
+ src/Lambdabot/Plugin/Error.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}+module Lambdabot.Plugin.Error (theModule, failOnLoad, errorOnLoad) where++import Lambdabot.Config+import Lambdabot.Plugin++import Control.Monad++config "failOnLoad"  [t| Bool |] [| False |]+config "errorOnLoad" [t| Bool |] [| False |]++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "error")+            { help = say "Throw an error, see what lambdabot does with it!"+            , process = error . show+            }+        , (command "fail")+            { help = say "Throw an error, see what lambdabot does with it!"+            , process = fail . show+            }+        ]+    , moduleInit = do+        shouldFail <- getConfig failOnLoad+        when shouldFail (fail "Error module hates the world!")+        +        shouldError <- getConfig errorOnLoad+        when shouldError (error "Error module hates the world!")+    }
+ src/Lambdabot/Plugin/Eval.hs view
@@ -0,0 +1,173 @@+-- Copyright (c) 2004-6 Donald Bruce Stewart - http://www.cse.unsw.edu.au/~dons+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++-- | A Haskell evaluator for the pure part, using mueval+module Lambdabot.Plugin.Eval (theModule, eval, exts) where++import Lambdabot.Plugin++import Control.Exception (try, SomeException)+import Control.Monad+import Data.List+import Data.Ord+import qualified Language.Haskell.Exts as Hs+import System.Directory+import System.Exit+import System.Process++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "run")+            { help = say "run <expr>. You have Haskell, 3 seconds and no IO. Go nuts!"+            , process = lim80 . eval+            }+        , (command "let")+            { aliases = ["define"] -- because @define always gets "corrected" to @undefine+            , help = say "let <x> = <e>. Add a binding"+            , process = lim80 . define+            }+        , (command "undefine")+            { help = say "undefine. Reset evaluator local bindings"+            , process = \s ->+                if null s+                    then do+                        reset+                        say "Undefined."+                    else say "There's currently no way to undefine just one thing.  Say @undefine (with no extra words) to undefine everything."+            }+        ]++    , contextual = \txt -> do+        b <- isEval txt+        when b (lim80 (eval (dropPrefix txt)))+    }++-- extensions to enable for the interpreted expression+-- (and probably also L.hs if it doesn't already have these set)+exts :: [String]+exts = ["ImplicitPrelude"] -- workaround for bug in hint package++args :: String -> String -> [String] -> [String]+args load src trusted = concat+    [ ["-S"]+    , map ("-s" ++) trusted+    , map ("-X" ++) exts+    , ["--no-imports", "-l", load]+    , ["--expression=" ++ src]+    , ["+RTS", "-N", "-RTS"]+    ]++isEval :: MonadLB m => String -> m Bool+isEval str = do+    prefixes <- getConfig evalPrefixes+    return (prefixes `arePrefixesWithSpaceOf` str)++dropPrefix :: String -> String+dropPrefix = dropWhile (' ' ==) . drop 2++eval :: MonadLB m => String -> m String+eval src = do+    load    <- lb (findOrCreateLBFile "L.hs")+    binary  <- getConfig muevalBinary+    trusted <- getConfig trustedPackages+    (_,out,err) <- io (readProcessWithExitCode binary (args load src trusted) "")+    case (out,err) of+        ([],[]) -> return "Terminated\n"+        _       -> do+            let o = munge out+                e = munge err+            return $ case () of {_+                | null o && null e -> "Terminated\n"+                | null o           -> " " ++ e+                | otherwise        -> " " ++ o+            }++------------------------------------------------------------------------+-- define a new binding++define :: MonadLB m => String -> m String+define [] = return "Define what?"+define src = case Hs.parseModule src of+    Hs.ParseOk srcModule -> do+        l <- lb (findOrCreateLBFile "L.hs")+        res <- io (Hs.parseFile l)+        case res of+            Hs.ParseFailed loc err -> return (Hs.prettyPrint loc ++ ':' : err)+            Hs.ParseOk lModule -> do+                let merged = mergeModules lModule srcModule+                case moduleProblems merged of+                    Just msg -> return msg+                    Nothing  -> comp merged+    Hs.ParseFailed _loc err -> return ("Parse failed: " ++ err)++-- merge the second module _into_ the first - meaning where merging doesn't+-- make sense, the field from the first will be used+mergeModules :: Hs.Module -> Hs.Module -> Hs.Module+mergeModules (Hs.Module loc1 name1 pragmas1 warnings1  exports1 imports1 decls1)+             (Hs.Module    _     _        _         _ _exports2 imports2 decls2)+    = Hs.Module loc1 name1 pragmas1 warnings1 exports1+        (mergeImports imports1 imports2)+        (mergeDecls   decls1   decls2)+    where+        mergeImports x y = nub (sortBy (comparing Hs.importModule) (x ++ y))+        mergeDecls x y = sortBy (comparing funcNamesBound) (x ++ y)++        -- this is a very conservative measure... we really only even care about function names,+        -- because we just want to sort those together so clauses can be added in the right places+        -- TODO: find out whether the [Hs.Match] can contain clauses for more than one function (e,g. might it be a whole binding group?)+        funcNamesBound (Hs.FunBind ms) = nub $ sort [ n | Hs.Match _ n _ _ _ _ <- ms]+        funcNamesBound _ = []++moduleProblems :: Hs.Module -> Maybe [Char]+moduleProblems (Hs.Module _ _ pragmas _ _ _imports _decls)+    | safe `notElem` langs  = Just "Module has no \"Safe\" language pragma"+    | trusted `elem` langs  = Just "\"Trustworthy\" language pragma is set"+    | otherwise             = Nothing+    where+        safe    = Hs.name "Safe"+        trusted = Hs.name "Trustworthy"+        langs = concat [ ls | Hs.LanguagePragma _ ls <- pragmas ]++-- It parses. then add it to a temporary L.hs and typecheck+comp :: MonadLB m => Hs.Module -> m String+comp src = do+    -- Note we copy to .L.hs, not L.hs. This hides the temporary files as dot-files+    io (writeFile ".L.hs" (Hs.prettyPrint src))++    -- and compile .L.hs+    -- careful with timeouts here. need a wrapper.+    trusted <- getConfig trustedPackages+    let ghcArgs = concat+            [ ["-O", "-v0", "-c", "-Werror", "-fpackage-trust"]+            , concat [["-trust", pkg] | pkg <- trusted]+            , [".L.hs"]+            ]+    ghc <- getConfig ghcBinary+    (c, o',e') <- io (readProcessWithExitCode ghc ghcArgs "")+    -- cleanup, 'try' because in case of error the files are not generated+    _ <- io (try (removeFile ".L.hi") :: IO (Either SomeException ()))+    _ <- io (try (removeFile ".L.o")  :: IO (Either SomeException ()))++    case (munge o', munge e') of+        ([],[]) | c /= ExitSuccess -> do+                    io (removeFile ".L.hs")+                    return "Error."+                | otherwise -> do+                    l <- lb (findOrCreateLBFile "L.hs")+                    io (renameFile ".L.hs" l)+                    return "Defined."+        (ee,[]) -> return ee+        (_ ,ee) -> return ee++munge :: String -> String+munge = expandTab 8 . dropWhile (=='\n') . dropNL++------------------------------+-- reset all bindings++reset :: MonadLB m => m ()+reset = do+    l <- lb (findOrCreateLBFile "L.hs")+    p <- lb (findOrCreateLBFile "Pristine.hs")+    io (copyFile p l)
+ src/Lambdabot/Plugin/Eval/Trusted.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE Trustworthy #-}+module Lambdabot.Plugin.Eval.Trusted+    ( module Math.OEIS+    , module Test.QuickCheck+    , module Lambdabot.Plugin.Check.ShowQ+    , module Lambdabot.Plugin.Eval.Trusted+    ) where++import Math.OEIS+import Lambdabot.Plugin.Check.ShowQ+import Test.QuickCheck++describeSequence :: SequenceData -> Maybe String+describeSequence = fmap description . lookupSequence++newtype Mu f = In { out :: f (Mu f) }++newtype Rec a = InR { outR :: Rec a -> a }
+ src/Lambdabot/Plugin/Filter.hs view
@@ -0,0 +1,68 @@+-- | GNU Talk Filters+-- needs: http://www.hyperrealm.com/main.php?s=talkfilters+-- Edward Kmett 2006++module Lambdabot.Plugin.Filter (theModule) where++import Lambdabot.Plugin++import Control.Applicative+import Data.Maybe+import System.Directory (findExecutable)+import System.Process++-- State consists of a map from filter name to executable path++theModule :: Module [(String, FilePath, String)]+theModule = newModule+    { moduleDefState = catMaybes <$> sequence+        [ do+            mbPath <- io (findExecutable name)+            return $! do+                path <- mbPath+                Just (name, path, descr)+        | (name, descr) <- filters+        ]+        +    , moduleCmds = do+        activeFilters <- readMS+        return+            [ (command name)+                { help = say descr+                , process = \s -> do+                    case words s of+                            [] -> say ("usage: " ++ name ++ " <phrase>")+                            t -> ios80 (runFilter path (unwords t))+                }+            | (name, path, descr) <- activeFilters+            ]+    }++filters :: [(String, String)]+filters =+    [ ("austro",     "austro <phrase>. Talk like Ahhhnold")+    , ("b1ff",       "b1ff <phrase>. B1ff of usenet yore")+    , ("brooklyn",   "brooklyn <phrase>. Yo")+    , ("chef",       "chef <phrase>. Bork bork bork")+    , ("cockney",    "cockney <phrase>. Londoner accent")+    , ("drawl",      "drawl <phrase>. Southern drawl")+    , ("dubya",      "dubya <phrase>. Presidential filter")+    , ("fudd",       "fudd <phrase>. Fudd, Elmer")+    , ("funetak",    "funetak <phrase>. Southern drawl")+    , ("jethro",     "jethro <phrase>. Now listen to a story 'bout a man named Jed...")+    , ("jive",       "jive <phrase>. Slap ma fro")+    , ("kraut",      "kraut <phrase>. German accent")+    , ("pansy",      "pansy <phrase>. Effeminate male")+    , ("pirate",     "pirate <phrase>. Talk like a pirate")+    , ("postmodern", "postmodern <phrase>. Feminazi")+    , ("redneck",    "redneck <phrase>. Deep south")+    , ("valspeak",   "valley <phrase>. Like, ya know?")+    , ("warez",      "warez <phrase>. H4x0r")+    ]++runFilter :: String -> String -> IO String+runFilter f s = do+    out <- readProcess f [] s+    return $ result out+    where result [] = "Couldn't run the filter."+          result xs = unlines . filter (not . all (==' ')) . lines $ xs
+ src/Lambdabot/Plugin/Free.hs view
@@ -0,0 +1,19 @@+-- | Free theorems plugin+-- Andrew Bromage, 2006+module Lambdabot.Plugin.Free (theModule) where++import Lambdabot.Plugin+import Lambdabot.Plugin.Free.FreeTheorem+import Lambdabot.Plugin.Type (query_ghci)++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "free")+            { help = say "free <ident>. Generate theorems for free"+            , process = \xs -> do+                result <- freeTheoremStr (query_ghci ":t") xs+                say . unwords . lines $ result+            }+        ]+    }
+ src/Lambdabot/Plugin/Free/Expr.hs view
@@ -0,0 +1,132 @@+{-# OPTIONS -w #-}
+
+module Lambdabot.Plugin.Free.Expr where
+
+import Lambdabot.Plugin.Free.Type
+import Lambdabot.Plugin.Free.Util
+
+varInExpr :: Var -> Expr -> Bool
+varInExpr v (EBuiltin _)
+    = False
+varInExpr v (EVar v')
+    = v == v'
+varInExpr v (EVarOp _ _ v')
+    = False
+varInExpr v (EApp e1 e2)
+    = varInExpr v e1 || varInExpr v e2
+varInExpr v (ETyApp e1 t)
+    = varInExpr v e1
+
+leftVarOfExpr :: Expr -> Var
+leftVarOfExpr (EVar v) = v
+leftVarOfExpr (EApp e _) = leftVarOfExpr e
+leftVarOfExpr (ETyApp e _) = leftVarOfExpr e
+
+exprSubst :: Var -> Expr -> Expr -> Expr
+exprSubst v e e'@(EBuiltin _)
+    = e'
+exprSubst v e e'@(EVar v')
+    | v == v'   = e
+    | otherwise = e'
+exprSubst v e e'@(EVarOp _ _ v')
+    | v == v'   = e
+    | otherwise = e'
+exprSubst v e (EApp e1 e2)
+    = EApp (exprSubst v e e1) (exprSubst v e e2)
+exprSubst v e (ETyApp e1 t)
+    = ETyApp (exprSubst v e e1) t
+
+
+type Var = String
+
+data Fixity
+    = FL | FN | FR
+    deriving (Eq, Show)
+
+data Expr
+    = EVar Var
+    | EBuiltin Builtin
+    | EVarOp Fixity Int Var
+    | EApp Expr Expr
+    | ETyApp Expr Type
+        deriving (Eq, Show)
+
+data Builtin
+    = BMap TyName
+    | BId
+    | BProj Int Int
+    | BMapTuple Int
+    | BArr
+        deriving (Eq, Show)
+
+data ExprCtx
+    = ECDot
+    | ECAppL ExprCtx Expr
+    | ECAppR Expr ExprCtx
+    | ECTyApp ExprCtx Type
+        deriving (Eq, Show)
+
+applySimplifierExpr :: (Expr -> Expr) -> (Expr -> Expr)
+applySimplifierExpr s (EApp e1 e2)
+    = EApp (s e1) (s e2)
+applySimplifierExpr s (ETyApp e t)
+    = ETyApp (s e) t
+applySimplifierExpr s e
+    = e
+
+unzipExpr :: Expr -> ExprCtx -> Expr
+unzipExpr e ECDot = e
+unzipExpr e (ECAppL c e2) = unzipExpr (EApp e e2) c
+unzipExpr e (ECAppR e1 c) = unzipExpr (EApp e1 e) c
+unzipExpr e (ECTyApp c t) = unzipExpr (ETyApp e t) c
+
+varInCtx :: Var -> ExprCtx -> Bool
+varInCtx v ECDot
+    = False
+varInCtx v (ECAppL c e2)
+    = varInCtx v c || varInExpr v e2
+varInCtx v (ECAppR e1 c)
+    = varInCtx v c || varInExpr v e1
+varInCtx v (ECTyApp c _)
+    = varInCtx v c
+
+precAPP :: Int
+precAPP = 10
+
+instance Pretty Expr where
+    prettyP p (EBuiltin b)
+        = prettyP p b
+    prettyP _ (EVar v)
+        = text v
+    prettyP _ (EVarOp _ _ v)
+        = lparen <> text v <> rparen
+    prettyP p (EApp (EApp (EVarOp fix prec op) e1) e2)
+        = prettyParen (p > prec) (
+            prettyP pl e1 <+> text op <+> prettyP pr e2
+        )
+        where
+            pl = if fix == FL then prec else prec+1
+            pr = if fix == FR then prec else prec+1
+    prettyP p (EApp e1 e2)
+        = prettyParen (p > precAPP) (
+            prettyP precAPP e1 <+> prettyP (precAPP+1) e2
+        )
+    prettyP p (ETyApp e t)
+        = prettyP precAPP e
+
+instance Pretty Builtin where
+    prettyP p (BMap "[]")   = text "$map"
+    prettyP p (BMap c)      = text ("$map_" ++ c)
+    prettyP p BId           = text "$id"
+    prettyP p (BProj 2 1)   = text "$fst"
+    prettyP p (BProj 2 2)   = text "$snd"
+    prettyP p (BProj 3 1)   = text "$fst3"
+    prettyP p (BProj 3 2)   = text "$snd3"
+    prettyP p (BProj 3 3)   = text "$thd3"
+    prettyP p (BProj l i)   = text ("$proj_" ++ show l ++ "_" ++ show i)
+    prettyP p (BMapTuple 2) = text "$map_Pair"
+    prettyP p (BMapTuple 3) = text "$map_Triple"
+    prettyP p (BMapTuple n) = text $ "$map_Tuple" ++ show n
+    prettyP p BArr          = text "$arr"
+
+-- vim: ts=4:sts=4:expandtab:ai
+ src/Lambdabot/Plugin/Free/FreeTheorem.hs view
@@ -0,0 +1,293 @@+{-# OPTIONS -w #-}
+
+module Lambdabot.Plugin.Free.FreeTheorem where
+
+import Lambdabot.Plugin.Free.Type
+import Lambdabot.Plugin.Free.Expr
+import Lambdabot.Plugin.Free.Theorem
+import Lambdabot.Plugin.Free.Parse
+import Lambdabot.Plugin.Free.Util
+
+import Control.Monad
+import Control.Monad.State
+import Control.Monad.Identity
+
+import Data.Char
+import qualified Data.Map as M
+
+newtype MyState
+    = MyState {
+        myVSupply :: Int
+    }
+
+type MyMon a = StateT MyState Identity a
+
+type TyEnv = [(TyVar,Var,TyVar,TyVar)]
+
+makeVar :: String -> MyMon String
+makeVar v
+    = do
+        vn <- gets myVSupply
+        modify (\s -> s { myVSupply = vn+1 })
+        return (v ++ "_" ++ show vn)
+
+extractTypes :: TyEnv -> Type -> (Type,Type)
+extractTypes env (TyVar v)
+    = head [ (TyVar t1,TyVar t2) | (v',_,t1,t2) <- env, v == v' ]
+extractTypes env (TyForall v t)
+    = let (t1,t2) = extractTypes ((v,undefined,v,v):env) t
+      in (TyForall v t1, TyForall v t2)
+extractTypes env (TyArr t1 t2)
+    = let (t1a,t1b) = extractTypes env t1
+          (t2a,t2b) = extractTypes env t2
+      in (TyArr t1a t2a, TyArr t1b t2b)
+extractTypes env (TyTuple ts)
+    = let ts12 = map (extractTypes env) ts
+      in (TyTuple (map fst ts12), TyTuple (map snd ts12))
+extractTypes env (TyCons c ts)
+    = let ts12 = map (extractTypes env) ts
+      in (TyCons c (map fst ts12), TyCons c (map snd ts12))
+
+freeTheoremStr :: (Monad m) => (String -> m String) -> String -> m String
+freeTheoremStr tf s
+    = case parse (do
+                    Just (QVarId v) <- getToken
+                    (mplus (do match OpColonColon
+                               t <- parseType
+                               return $ Left (v,t))
+                           (return (Right v)))) (lexer s) of
+        ParseSuccess (Left (v,t)) [] -> return (run' v t)
+        ParseSuccess (Right v)    [] -> do tStr <- tf s
+                                           case parse parseType (lexer tStr) of
+                                             ParseSuccess t [] -> return (run' v t)
+                                             ParseSuccess _ _ -> return $ "Extra stuff at end of line in retrieved type " ++ show tStr
+                                             ParseError msg -> return msg
+        ParseSuccess _ _      -> return "Extra stuff at end of line"
+        ParseError msg        -> return msg
+    where
+        run' v t = renderStyle defstyle (pretty (freeTheorem v t))
+        defstyle = Style {
+                        mode = PageMode,
+                        lineLength = 78,
+                        ribbonsPerLine = 1.5
+                    }
+
+freeTheorem :: String -> Type -> Theorem
+freeTheorem name t
+    = runIdentity $ do
+        (th,_) <- runStateT (freeTheorem' [] v0 v0 t) initState
+        let th' = theoremSimplify th
+        return . fst $ runState (insertRn name name >> rename th') initRnSt
+    where
+        v0 = EVar name
+        initState   = MyState { myVSupply = 1 }
+
+------------------------------------------------------------------------
+-- Rename monad, and pretty alpha renamer
+
+data RnSt = RnSt { gamma  :: M.Map Var Var
+                 , unique   :: [Var]
+                 , uniquelist :: [Var]
+                 , uniquefn :: [Var]
+                 }
+    deriving Show
+
+initRnSt
+    = RnSt M.empty suggestionsVal suggestionsList suggestionsFun
+    where
+        suggestionsVal = map (:[]) "xyzuvabcstdeilmnorw"
+                            ++ [ 'x' : show i | i <- [1..] ]
+        suggestionsList = map (:"s") "xyzuvabcstdeilmnorw"
+                            ++ [ "xs" ++ show i | i <- [1..] ]
+        suggestionsFun = map (:[]) "fghkpq"
+                            ++ [ 'f' : show i | i <- [1..] ]
+
+type RN a = State RnSt a
+
+-- generate a nice fresh name
+freshName :: RN Var
+freshName = do
+    s <- get
+    let ns    = unique s
+        fresh = head ns
+    put $ s { unique = tail ns }
+    case M.lookup fresh (gamma s) of
+        Nothing -> return fresh
+        _       -> freshName
+
+-- generate a nice function name
+freshFunctionName :: RN Var
+freshFunctionName = do
+    s <- get
+    let ns    = uniquefn s
+        fresh = head ns
+    put $ s { uniquefn = tail ns }
+    case M.lookup fresh (gamma s) of
+        Nothing -> return fresh
+        _       -> freshFunctionName
+
+-- generate a nice list name
+freshListName :: RN Var
+freshListName = do
+    s <- get
+    let ns    = uniquelist s
+        fresh = head ns
+    put $ s { uniquelist = tail ns }
+    case M.lookup fresh (gamma s) of
+        Nothing -> return fresh
+        _       -> freshListName
+
+-- insert a new association into the heap
+insertRn :: Var -> Var -> RN ()
+insertRn old new = modify $ \s ->
+    let gamma' = M.insert old new (gamma s) in s { gamma = gamma' }
+
+-- lookup the binding
+lookupRn :: Var -> RN Var
+lookupRn old = do
+    m <- gets gamma
+    return $ case M.lookup old m of
+        Nothing  -> old
+        Just new -> new
+
+-- alpha rename a simplified theory to something nice
+rename :: Theorem -> RN Theorem
+rename (ThImplies th1 th2) = do
+    th1' <- rename th1
+    th2' <- rename th2
+    return $ ThImplies th1' th2'
+
+rename (ThEqual e1 e2) = do
+    e1' <- rnExp e1
+    e2' <- rnExp e2
+    return $ ThEqual e1' e2'
+
+rename (ThAnd th1 th2) = do
+    th1' <- rename th1
+    th2' <- rename th2
+    return $ ThAnd th1' th2'
+
+rename (ThForall v ty th) = do
+    v' <- case ty of
+                TyArr _ _     -> freshFunctionName
+                TyCons "[]" _ -> freshListName
+                _             -> freshName
+    insertRn v v'
+    ty' <- rnTy ty
+    th' <- rename th
+    return $ ThForall v' ty' th'
+
+rnExp :: Expr -> RN Expr
+rnExp e@(EBuiltin _) = return e
+rnExp (EVar v)       = EVar       `fmap` lookupRn v
+rnExp (EVarOp f n v) = EVarOp f n `fmap` lookupRn v
+
+rnExp (EApp e1 e2) = do
+    e1' <- rnExp e1
+    e2' <- rnExp e2
+    return (EApp e1' e2')
+
+rnExp (ETyApp e ty) = do
+    e'  <- rnExp e
+    ty' <- rnTy ty
+    return (ETyApp e' ty')
+
+rnTy :: Type -> RN Type
+rnTy ty = return ty
+
+------------------------------------------------------------------------
+
+freeTheorem' :: TyEnv -> Expr -> Expr -> Type -> MyMon Theorem
+
+freeTheorem' env e1 e2 t'@(TyForall v t)
+    = do
+        mv <- makeVar "f"
+        t1 <- makeVar v
+        t2 <- makeVar v
+        let tymv = TyArr (TyVar t1) (TyVar t2)
+        pt <- freeTheorem' ((v,mv,t1,t2):env) (ETyApp e1 (TyVar t1))
+                                              (ETyApp e2 (TyVar t2)) t
+        return (ThForall mv tymv pt)
+
+freeTheorem' env e1 e2 t'@(TyArr t1 t2)
+    = do
+        mv1 <- makeVar "v1"
+        mv2 <- makeVar "v2"
+        let (tmv1,tmv2) = extractTypes env t1
+        p1 <- freeTheorem' env (EVar mv1) (EVar mv2) t1
+        p2 <- freeTheorem' env (EApp e1 (EVar mv1)) (EApp e2 (EVar mv2)) t2
+        return (ThForall mv1 tmv1 (ThForall mv2 tmv2 (ThImplies p1 p2)))
+
+freeTheorem' env e1 e2 t'@(TyTuple [])
+    = do
+        return (ThEqual e1 e2)
+
+freeTheorem' env e1 e2 t'@(TyTuple ts)
+    = do
+        let len = length ts
+
+        fts <- mapM (\t -> do
+                let (t1,t2) = extractTypes env t
+                f <- makeVar "f"
+                x <- makeVar "x"
+                y <- makeVar "y"
+                th <- freeTheorem' env (EVar x) (EVar y) t
+                let eq = ThEqual (EApp (EVar f) (EVar x)) (EVar y)
+                return ((f,TyArr t1 t2),
+                        ThForall x t1 (
+                            ThForall y t2 (
+                                ThImplies th eq
+                            )
+                        )
+                    )
+            ) ts
+        let thf = ThEqual (EApp (foldl (\e ((f,_),_) -> EApp e (EVar f))
+                            (EBuiltin $ BMapTuple len) fts) e1) e2
+        return (foldr (\((f,t),e1) e2 -> ThForall f t (ThImplies e1 e2))
+                thf fts)
+
+freeTheorem' env e1 e2 t'@(TyVar v)
+    = do
+        let f = head [ f | (v',f,_,_) <- env, v' == v ]
+        return (ThEqual (EApp (EVar f) e1) e2)
+
+freeTheorem' env e1 e2 t'@(TyCons _ [])
+    = do
+        return (ThEqual e1 e2)
+
+freeTheorem' env e1 e2 t'@(TyCons c [t])
+    = do
+        f <- makeVar "f"
+        x <- makeVar "x"
+        y <- makeVar "y"
+        let (t1,t2) = extractTypes env t
+        p1 <- freeTheorem' env (EVar x) (EVar y) t
+        let p2 = ThEqual (EApp (EVar f) (EVar x)) (EVar y)
+        let p3 = ThEqual (EApp (EApp (EBuiltin (BMap c)) (EVar f)) e1) e2
+        return (ThForall f (TyArr t1 t2) (
+                ThImplies (ThForall x t1 (ThForall y t2 (ThImplies p1 p2)))
+                            p3))
+
+freeTheorem' env e1 e2 t'@(TyCons c@"Either" ts@[_,_])
+    = do
+        fts <- mapM (\t -> do
+                let (t1,t2) = extractTypes env t
+                f <- makeVar "f"
+                x <- makeVar "x"
+                y <- makeVar "y"
+                th <- freeTheorem' env (EVar x) (EVar y) t
+                let eq = ThEqual (EApp (EVar f) (EVar x)) (EVar y)
+                return ((f,TyArr t1 t2),
+                        ThForall x t1 (
+                            ThForall y t2 (
+                                ThImplies th eq
+                            )
+                        )
+                    )
+            ) ts
+        let thf = ThEqual (EApp (foldl (\e ((f,_),_) -> EApp e (EVar f))
+                            (EBuiltin $ BMap c) fts) e1) e2
+        return (foldr (\((f,t),e1) e2 -> ThForall f t (ThImplies e1 e2))
+                thf fts)
+
+-- vim: ts=4:sts=4:expandtab:ai
+ src/Lambdabot/Plugin/Free/Parse.hs view
@@ -0,0 +1,224 @@+{-# OPTIONS -w #-}
+
+module Lambdabot.Plugin.Free.Parse where
+
+import Control.Monad
+
+data Token
+    = QVarId String
+    | QConId String
+    | QVarSym String
+    | QConSym String
+    | OpenParen
+    | CloseParen
+    | Comma
+    | Semicolon
+    | OpenBracket
+    | CloseBracket
+    | BackQuote
+    | OpenBrace
+    | CloseBrace
+    | OpDotDot
+    | OpColon
+    | OpColonColon
+    | OpEquals
+    | OpBackslash
+    | OpPipe
+    | OpBackArrow
+    | OpArrow
+    | OpAt
+    | OpTilde
+    | OpImplies
+    | IdCase
+    | IdClass
+    | IdData
+    | IdDefault
+    | IdDeriving
+    | IdDo
+    | IdElse
+    | IdForall
+    | IdIf
+    | IdImport
+    | IdIn
+    | IdInfix
+    | IdInfixl
+    | IdInfixr
+    | IdInstance
+    | IdLet
+    | IdModule
+    | IdNewtype
+    | IdOf
+    | IdThen
+    | IdType
+    | IdWhere
+    | IdUscore
+    | TokError String
+        deriving (Show,Eq,Ord)
+
+data ParseResult a
+    = ParseSuccess a [Token]
+    | ParseError String
+        deriving (Show)
+
+newtype ParseS a = ParseS { parse :: [Token] -> ParseResult a }
+
+instance Monad ParseS where
+    return x = ParseS (\ts -> ParseSuccess x ts)
+    m >>= k = ParseS (\ts -> case parse m ts of
+                                ParseSuccess x ts' -> parse (k x) ts'
+                                ParseError s       -> ParseError s)
+    fail str = ParseS (\_ -> ParseError str)
+
+instance MonadPlus ParseS where
+    mzero = ParseS (\ts -> ParseError "parse error")
+    mplus m1 m2
+        = ParseS (\ts -> case parse m1 ts of
+                            res@(ParseSuccess _ _) -> res
+                            ParseError _           -> parse m2 ts)
+
+peekToken :: ParseS (Maybe Token)
+peekToken = ParseS (\ts -> case ts of
+                            []     -> ParseSuccess Nothing []
+                            (t':_) -> ParseSuccess (Just t') ts)
+
+getToken :: ParseS (Maybe Token)
+getToken = ParseS (\ts -> case ts of
+                            []     -> ParseSuccess Nothing []
+                            (t:ts) -> ParseSuccess (Just t) ts)
+
+match :: Token -> ParseS ()
+match m
+    = do
+        mt <- getToken
+        case mt of
+            Just t | t == m -> return ()
+            _               -> fail ("Expected " ++ show m)
+
+ascSymbol = ['!','#','$','%','&','*','+','.','/','<','=','>','?','@','\\',
+                '^','|','-','~']
+
+
+lexer :: String -> [Token]
+lexer []
+    = []
+lexer (' ':cs)
+    = lexer cs
+lexer ('\t':cs)
+    = lexer cs
+lexer ('\f':cs)
+    = lexer cs
+lexer ('\r':cs)
+    = lexer cs
+lexer ('\n':cs)
+    = lexer cs
+lexer ('\v':cs)
+    = lexer cs
+lexer ('-':'-':cs)
+    = lexerLineComment cs
+    where
+        lexerLineComment ('\r':'\n':cs) = lexer cs
+        lexerLineComment ('\r':cs) = lexer cs
+        lexerLineComment ('\n':cs) = lexer cs
+        lexerLineComment ('\f':cs) = lexer cs
+        lexerLineComment (c:cs) = lexerLineComment cs
+        lexerLineComment [] = []
+lexer ('{':'-':cs)
+    = lexerComment lexer cs
+    where
+        lexerComment k ('{':'-':cs) = lexerComment (lexerComment k) cs
+        lexerComment k ('-':'}':cs) = k cs
+        lexerComment k (_:cs) = lexerComment k cs
+        lexerComment k [] = [TokError "Unterminated comment"]
+lexer ('(':cs)
+    = OpenParen : lexer cs
+lexer (')':cs)
+    = CloseParen : lexer cs
+lexer (',':cs)
+    = Comma : lexer cs
+lexer ('[':cs)
+    = OpenBracket : lexer cs
+lexer (']':cs)
+    = CloseBracket : lexer cs
+lexer (c@':':cs)
+    = lexerConSym [c] cs
+    where
+        lexerConSym con (c:cs)                
+            | c == ':'
+                || c `elem` ascSymbol
+                = lexerConSym (c:con) cs
+        lexerConSym con cs
+            = case reverse con of
+                ":"  -> OpColon : lexer cs
+                "::" -> OpColonColon : lexer cs
+                con  -> QConSym con : lexer cs
+lexer (c:cs)
+    | c `elem` ['A'..'Z']
+        = lexerConId [c] cs
+    | c `elem` ['a'..'z'] || c == '_'
+        = lexerVarId [c] cs
+    | c `elem` ascSymbol
+        = lexerVarSym [c] cs
+    | otherwise
+        = [TokError "Illegal char"]
+        where
+            lexerConId con (c:cs)
+                | c `elem` ['A'..'Z']
+                    || c `elem` ['a'..'z']
+                    || c `elem` ['0'..'9']
+                    || c == '\''
+                    || c == '_'
+                        = lexerConId (c:con) cs
+            lexerConId con cs
+                = QConId (reverse con) : lexer cs
+
+            lexerVarId var (c:cs)
+                | c `elem` ['A'..'Z']
+                    || c `elem` ['a'..'z']
+                    || c `elem` ['0'..'9']
+                    || c == '\''
+                    || c == '_'
+                        = lexerVarId (c:var) cs
+            lexerVarId var cs
+                = case reverse var of
+                    "_"        -> IdUscore : lexer cs
+                    "case"     -> IdCase : lexer cs
+                    "class"    -> IdClass : lexer cs
+                    "data"     -> IdData : lexer cs
+                    "default"  -> IdDefault : lexer cs
+                    "deriving" -> IdDeriving : lexer cs
+                    "do"       -> IdDo : lexer cs
+                    "else"     -> IdElse : lexer cs
+                    "forall"   -> IdForall : lexer cs
+                    "if"       -> IdIf : lexer cs
+                    "import"   -> IdImport : lexer cs
+                    "in"       -> IdIn : lexer cs
+                    "infix"    -> IdInfix : lexer cs
+                    "infixl"   -> IdInfixl : lexer cs
+                    "infixr"   -> IdInfixr : lexer cs
+                    "instance" -> IdInstance : lexer cs
+                    "let"      -> IdLet : lexer cs
+                    "module"   -> IdModule : lexer cs
+                    "newtype"  -> IdNewtype : lexer cs
+                    "of"       -> IdOf : lexer cs
+                    "then"     -> IdThen : lexer cs
+                    "type"     -> IdType : lexer cs
+                    "where"    -> IdWhere : lexer cs
+                    v          -> QVarId v : lexer cs
+
+            lexerVarSym var (c:cs)
+                | c == ':' || c `elem` ascSymbol
+                    = lexerVarSym (c:var) cs
+            lexerVarSym var cs
+                = case reverse var of
+                    ".."    -> OpDotDot : lexer cs
+                    "="     -> OpEquals : lexer cs
+                    "\\"    -> OpBackslash : lexer cs
+                    "|"     -> OpPipe : lexer cs
+                    "<-"    -> OpBackArrow : lexer cs
+                    "->"    -> OpArrow : lexer cs
+                    "@"     -> OpAt : lexer cs
+                    "~"     -> OpTilde : lexer cs
+                    "=>"    -> OpImplies : lexer cs
+                    var     -> QVarSym var : lexer cs
+
+-- vim: ts=4:sts=4:expandtab:ai
+ src/Lambdabot/Plugin/Free/Test.hs view
@@ -0,0 +1,54 @@+module Lambdabot.Plugin.Free.Test where
+
+import Lambdabot.Plugin.Free.FreeTheorem
+import Lambdabot.Plugin.Free.Type
+
+
+tUndef = "undefined :: a -> a"
+
+tMzero = "mzero :: [a]"
+
+tReturnList = "return :: a -> [a]"
+
+tHead = "head :: [a] -> a"
+
+tTail = "tail :: [a] -> [a]"
+
+tId = "id :: a -> a"
+
+tConst = "const :: a -> b -> a"
+
+tIdPair = "id :: (a,b) -> (a,b)"
+
+tSwap = "swap :: (a,b) -> (b,a)"
+
+tGenSwap = "genSwap :: (forall z. a -> b -> z) -> (forall z. b -> a -> z)"
+
+tMap = "map :: (a -> b) -> ([a] -> [b])"
+
+tZip = "zip :: ([a],[b]) -> [(a,b)]"
+
+tIdFun = "id :: (a -> b) -> (a -> b)"
+
+tFst = "fst :: (a,b) -> a"
+
+tFstFun = "fst :: (a->b,c) -> a -> b"
+
+tSnd = "snd :: (a,b) -> b"
+
+
+tContinuation :: Type -> Type
+tContinuation a
+    = TyForall "R" (TyArr (TyArr a r) r)
+    where
+        r = TyVar "R"
+
+tReturnC = "return :: a -> (forall r. (a -> r) -> r)"
+
+tCallCC = "callcc :: ((a -> (forall r. (b -> r) -> r)) -> (forall r. (a -> r) -> r)) -> (forall r. (a -> r) -> r)"
+
+tPierce = "pierce :: ((a -> b) -> a) -> a"
+
+tNot = "not :: (forall z. z -> z -> z) -> (forall z. z -> z -> z)"
+
+-- vim: ts=4:sts=4:expandtab:ai
+ src/Lambdabot/Plugin/Free/Theorem.hs view
@@ -0,0 +1,190 @@+{-# OPTIONS -w #-}
+
+module Lambdabot.Plugin.Free.Theorem where
+
+import Lambdabot.Plugin.Free.Type
+import Lambdabot.Plugin.Free.Expr
+import Lambdabot.Plugin.Free.Util
+
+data Theorem
+    = ThForall Var Type Theorem
+    | ThImplies Theorem Theorem
+    | ThEqual Expr Expr
+    | ThAnd Theorem Theorem
+        deriving (Eq,Show)
+
+precIMPLIES, precAND :: Int
+precIMPLIES = 5
+precAND = 3
+
+instance Pretty Theorem where
+    prettyP p t = prettyTheorem p False t
+
+
+prettyTheorem :: Int -> Bool -> Theorem -> Doc
+prettyTheorem p fa th@(ThForall v t p1)
+    | fa        = prettyForall p [v] p1
+    | otherwise = prettyP p p1
+prettyTheorem p fa (ThImplies p1 p2)
+    = prettyParenIndent (p > precIMPLIES) (
+        prettyTheorem (precIMPLIES+1) True p1
+        $$ nest (-1) (text "=>")
+        $$ prettyTheorem precIMPLIES fa p2
+    )
+prettyTheorem _ _ (ThEqual e1 e2)
+    = prettyP 0 e1 <+> text "=" <+> prettyP 0 e2
+prettyTheorem p fa (ThAnd e1 e2)
+    = prettyParenIndent (p > precAND) (
+        prettyTheorem (precAND+1) fa e1 $$ text "&&"
+        $$ prettyTheorem precAND fa e2
+    )
+
+prettyForall :: Int -> [Var] -> Theorem -> Doc
+prettyForall p vs (ThForall v t p1)
+    = prettyForall p (v:vs) p1
+prettyForall p vs th
+    = parens (
+        text "forall" <+> hsep [ text v | v <- reverse vs ] <> text "."
+        <+> prettyTheorem 0 True th
+    )
+
+varInTheorem :: Var -> Theorem -> Bool
+varInTheorem v (ThForall v' t p)
+    = v /= v' && varInTheorem v p
+varInTheorem v (ThImplies p1 p2)
+    = varInTheorem v p1 || varInTheorem v p2
+varInTheorem v (ThEqual e1 e2)
+    = varInExpr v e1 || varInExpr v e2
+varInTheorem v (ThAnd e1 e2)
+    = varInTheorem v e1 || varInTheorem v e2
+
+applySimplifierTheorem :: (Theorem -> Theorem) -> (Theorem -> Theorem)
+applySimplifierTheorem s (ThForall v t p)
+    = ThForall v t (s p)
+applySimplifierTheorem s (ThImplies p1 p2)
+    = ThImplies (s p1) (s p2)
+applySimplifierTheorem s p@(ThEqual _ _)
+    = p
+applySimplifierTheorem s p@(ThAnd p1 p2)
+    = ThAnd (s p1) (s p2)
+
+peepholeSimplifyTheorem :: Theorem -> Theorem
+peepholeSimplifyTheorem
+    = peepholeSimplifyTheorem' . applySimplifierTheorem peepholeSimplifyTheorem
+
+peepholeSimplifyTheorem' :: Theorem -> Theorem
+peepholeSimplifyTheorem' (ThForall v t p)
+    = case varInTheorem v p of
+            True  -> ThForall v t p
+            False -> p
+peepholeSimplifyTheorem' p@(ThAnd e1 e2)
+    = foldr1 ThAnd (flattenAnd e1 . flattenAnd e2 $ [])
+    where
+        flattenAnd (ThAnd e1 e2) = flattenAnd e1 . flattenAnd e2
+        flattenAnd e = (e:)
+peepholeSimplifyTheorem' p
+    = p
+
+peepholeSimplifyExpr :: Expr -> Expr
+peepholeSimplifyExpr
+    = peepholeSimplifyExpr' . applySimplifierExpr peepholeSimplifyExpr
+
+peepholeSimplifyExpr' :: Expr -> Expr
+peepholeSimplifyExpr' (EApp (EBuiltin BId) e2)
+    = e2
+peepholeSimplifyExpr' (EApp (EBuiltin (BMap _)) (EBuiltin BId))
+    = EBuiltin BId
+peepholeSimplifyExpr' e
+    = e
+
+foldEquality :: Theorem -> Theorem
+foldEquality p@(ThForall _ _ _)
+    = case foldEquality' p [] of
+        Just p' -> p'
+        Nothing -> applySimplifierTheorem foldEquality p
+    where
+        foldEquality' (ThForall v t p) vts
+            = foldEquality' p ((v,t):vts)
+        foldEquality' (ThImplies (ThEqual (EVar v) e2) p) vts
+            | v `elem` map fst vts
+                = foldEquality'' vts (theoremSubst v e2 p)
+        foldEquality' (ThImplies (ThEqual e1 (EVar v)) p) vts
+            | v `elem` map fst vts
+                = foldEquality'' vts (theoremSubst v e1 p)
+        foldEquality' _ vts
+            = Nothing
+
+        foldEquality'' [] e
+            = Just e
+        foldEquality'' ((v,t):vts) e
+            = foldEquality'' vts (ThForall v t e)
+
+foldEquality p
+    = applySimplifierTheorem foldEquality p
+
+tryCurrying :: Theorem -> Theorem
+tryCurrying p@(ThForall _ _ _)
+    = case tryCurrying' p [] of
+        Just p' -> p'
+        Nothing -> applySimplifierTheorem tryCurrying p
+    where
+        tryCurrying' (ThForall v t p) vts
+            = tryCurrying' p ((v,t):vts)
+        tryCurrying' (ThEqual e1 e2) vts
+            = case (traverseRight ECDot e1, traverseRight ECDot e2) of
+                ((ctx1, EVar v1), (ctx2, EVar v2))
+                    | v1 == v2 && v1 `elem` map fst vts
+                        && not (varInCtx v1 ctx1) && not (varInCtx v2 ctx2)
+                        -> tryCurrying'' vts (ThEqual (untraverse ctx1)
+                                                      (untraverse ctx2))
+                _       -> Nothing
+        tryCurrying' _ _
+            = Nothing
+
+        traverseRight ctx (EApp e1 e2)
+            = traverseRight (ECAppR e1 ctx) e2
+        traverseRight ctx e
+            = (ctx, e)
+
+        untraverse ECDot = EBuiltin BId
+        untraverse (ECAppR e1 ECDot)
+            = e1
+        untraverse (ECAppR e1 ctx)
+            = EApp (EApp (EVarOp FR 9 ".") (untraverse ctx)) e1
+        tryCurrying'' [] e
+            = Just e
+        tryCurrying'' ((v,t):vts) e
+            = tryCurrying'' vts (ThForall v t e)
+
+tryCurrying p
+    = applySimplifierTheorem tryCurrying p
+
+theoremSimplify :: Theorem -> Theorem
+theoremSimplify
+    = iterateUntilFixpoint
+        (foldEquality
+        . iterateUntilFixpoint peephole
+        . tryCurrying
+        . iterateUntilFixpoint peephole
+        )
+    where
+        iterateUntilFixpoint s t
+            = findFixpoint (iterate s t)
+
+        peephole t = findFixpoint (iterate peepholeSimplifyTheorem t)
+
+        findFixpoint (x1:xs@(x2:_))
+            | x1 == x2  = x2
+            | otherwise = findFixpoint xs
+
+theoremSubst :: Var -> Expr -> Theorem -> Theorem
+theoremSubst v e (ThForall f t p)
+    = ThForall f t (theoremSubst v e p)
+theoremSubst v e (ThImplies p1 p2)
+    = ThImplies (theoremSubst v e p1) (theoremSubst v e p2)
+theoremSubst v e (ThEqual e1 e2)
+    = ThEqual (exprSubst v e e1) (exprSubst v e e2)
+theoremSubst v e (ThAnd p1 p2)
+    = ThAnd (theoremSubst v e p1) (theoremSubst v e p2)
+
+-- vim: ts=4:sts=4:expandtab:ai
+ src/Lambdabot/Plugin/Free/Type.hs view
@@ -0,0 +1,222 @@+{-# OPTIONS -w #-}
+
+module Lambdabot.Plugin.Free.Type where
+
+import Control.Monad
+import Lambdabot.Plugin.Free.Parse
+import Data.List
+import Lambdabot.Plugin.Free.Util
+
+type TyVar = String
+type TyName = String
+
+data Type
+    = TyForall TyVar Type
+    | TyArr Type Type
+    | TyTuple [Type]
+    | TyCons TyName [Type]
+    | TyVar TyVar
+        deriving (Eq, Show)
+
+precTYAPP, precARROW :: Int
+precTYAPP = 11
+precARROW = 10
+
+instance Pretty Type where
+    prettyP p (TyForall v t)
+        = prettyParen (p > 0) (
+            text "forall" <+> text v <> text "." <+> prettyP 0 t
+        )
+    prettyP p (TyArr t1 t2)
+        = prettyParen (p > precARROW) (
+            prettyP (precARROW+1) t1 <+> text "->" <+> prettyP precARROW t2
+        )
+    prettyP _ (TyTuple [])
+        = parens empty
+    prettyP _ (TyTuple (t:ts))
+        = parens (prettyP 0 t <> prettyTs 0 (text ",") ts)
+    prettyP _ (TyCons "[]" [t])
+        = lbrack <> prettyP 0 t <> rbrack
+    prettyP p (TyCons cons ts)
+        = prettyParen (p > precTYAPP) (
+            text cons <> prettyTs (precTYAPP+1) empty ts
+        )
+    prettyP _ (TyVar v)
+        = text v
+
+prettyTs :: Int -> Doc -> [Type] -> Doc
+prettyTs p c [] = empty
+prettyTs p c (t:ts) = c <+> prettyP p t <> prettyTs p c ts
+
+
+parseType :: ParseS Type
+parseType
+    = parseType' >>= return . normaliseType
+
+parseType' :: ParseS Type
+parseType'
+    = do
+        t <- peekToken
+        case t of
+            Just IdForall -> getToken >> parseForall
+            _             -> parseArrType
+    where
+        parseForall
+            = do
+                t <- getToken
+                case t of
+                    Just (QVarId v)
+                        -> parseForall >>= \t -> return (TyForall v t)
+                    Just (QVarSym ".")
+                        -> parseType'
+                    _   -> fail "Expected variable or '.'"
+
+        parseArrType
+            = do
+                t1 <- parseBType
+                t <- peekToken
+                case t of
+                    Just OpArrow
+                        -> getToken >> parseType' >>= \t2 ->
+                            return (TyArr t1 t2)
+                    _   -> return t1
+
+        parseBType
+            = do
+                t1 <- parseAType
+                case t1 of
+                    TyCons c ts
+                        -> do
+                            ts' <- parseBTypes
+                            return (TyCons c (ts++ts'))
+                    _   -> return t1
+
+        parseBTypes
+            = (parseBType >>= \t -> parseBTypes >>= \ts -> return (t:ts))
+                `mplus` return []
+
+        parseAType
+            = parseQTyCon `mplus` parseOtherAType
+
+        parseQTyCon
+            = do
+                t <- getToken
+                case t of
+                    Just OpenParen
+                        -> do
+                            t <- getToken
+                            case t of
+                                Just CloseParen
+                                    -> return (TyCons "()" [])
+                                Just OpArrow
+                                    -> match CloseParen
+                                        >> return (TyCons "->" [])
+                                Just Comma
+                                    -> parseQTyConTuple 1
+                                _   -> fail "Badly formed type constructor"
+                    Just OpenBracket
+                        -> match CloseBracket >> return (TyCons "[]" [])
+                    Just (QConId v)
+                        -> return (TyCons v [])
+                    _   -> fail "Badly formed type constructor"
+
+        parseQTyConTuple :: Int -> ParseS Type
+        parseQTyConTuple i
+            = do
+                t <- getToken
+                case t of
+                    Just Comma
+                        -> parseQTyConTuple (i+1)
+                    Just CloseParen
+                        -> return (TyCons ("(" ++ take i (repeat ',') ++ ")") [])
+                    _   -> fail "Badly formed type constructor"
+
+        parseOtherAType
+            = do
+                t1 <- getToken
+                case t1 of
+                    Just OpenParen
+                        -> do
+                            t <- parseType'
+                            parseTuple [t]
+                    Just OpenBracket
+                        -> parseType' >>= \t -> match CloseBracket
+                                        >> return (TyCons "[]" [t])
+                    Just (QVarId v)
+                        -> return (TyVar v)
+                    _   -> fail "Badly formed type"
+
+        parseTuple ts
+            = do
+                t1 <- getToken
+                case t1 of
+                    Just CloseParen
+                        -> case ts of
+                                [t] -> return t
+                                _   -> return (TyTuple (reverse ts))
+                    Just Comma
+                        -> do
+                            t <- parseType'
+                            parseTuple (t:ts)
+
+normaliseType :: Type -> Type
+normaliseType t
+    = let (fvs,nt) = normaliseType' t
+      in foldr TyForall nt (nub fvs)
+    where
+        normaliseType' t@(TyVar v)
+            = ([v],t)
+        normaliseType' (TyForall v t')
+            = let (fvs,t) = normaliseType' t'
+              in (filter (/=v) fvs, TyForall v t)
+        normaliseType' (TyArr t1 t2)
+            = let
+                (fvs1,t1') = normaliseType' t1
+                (fvs2,t2') = normaliseType' t2
+              in
+                (fvs1++fvs2, TyArr t1' t2')
+        normaliseType' (TyTuple ts)
+            = let
+                fvsts = map normaliseType' ts
+                fvs = concat (map fst fvsts)
+                ts' = map snd fvsts
+              in (fvs, TyTuple ts')
+        normaliseType' (TyCons c ts)
+            = let
+                fvsts = map normaliseType' ts
+                fvs = concat (map fst fvsts)
+                ts' = map snd fvsts
+              in case c of
+                    "->" -> case ts' of
+                        [t1,t2] -> (fvs, TyArr t1 t2)
+                        _ -> error "Arrow type should have 2 arguments"
+                    _ -> case checkTuple c of
+                        Just i
+                            -> if i == length ts'
+                                then (fvs, TyTuple ts')
+                                else error "Tuple type has the wrong number of arguments"
+                        Nothing
+                            -> (fvs, TyCons c ts')
+
+        checkTuple ('(':')':cs)
+            = Just 0
+        checkTuple ('(':cs)
+            = checkTuple' 1 cs
+        checkTuple _
+            = Nothing
+
+        checkTuple' k ")"
+            = Just k
+        checkTuple' k (',':cs)
+            = checkTuple' (k+1) cs
+        checkTuple' _ _
+            = Nothing
+
+readType :: String -> Type
+readType s
+    = case parse parseType (lexer s) of
+        ParseSuccess t [] -> t
+        ParseSuccess t _  -> error "Extra stuff at end of type"
+        ParseError msg    -> error msg
+
+-- vim: ts=4:sts=4:expandtab:ai
+ src/Lambdabot/Plugin/Free/Util.hs view
@@ -0,0 +1,30 @@+module Lambdabot.Plugin.Free.Util (
+    Pretty(..),
+    prettyParen,
+    prettyParenIndent,
+    module Text.PrettyPrint.HughesPJ
+) where
+
+
+import Text.PrettyPrint.HughesPJ
+
+
+class Pretty a where
+    prettyP :: Int -> a -> Doc
+
+    pretty :: a -> Doc
+    pretty x = prettyP 0 x
+
+
+prettyParen :: Bool -> Doc -> Doc
+prettyParen b doc
+    = if b then parens doc else doc
+
+prettyParenIndent :: Bool -> Doc -> Doc
+prettyParenIndent b doc
+    = if b
+      then vcat [lparen, nest 2 doc, rparen]
+      else doc
+
+
+-- vim: ts=4:sts=4:expandtab
+ src/Lambdabot/Plugin/Fresh.hs view
@@ -0,0 +1,36 @@+-- | Haskell project name generation+-- semi-joke+module Lambdabot.Plugin.Fresh (theModule) where++import Lambdabot.Plugin++import Control.Monad.Trans+import Data.Char++type Fresh = ModuleT Integer LB++theModule :: Module Integer+theModule = newModule+    { moduleDefState = return 0+    , moduleSerialize = Just stdSerial+    +    , moduleCmds = return+        [ (command "freshname")+            { help = say "freshname. Return a unique Haskell project name."+            , process = \_ -> lift fresh >>= say+            }+        ]+    }++fresh :: Fresh String+fresh = withMS $ \n f -> do+    f (n+1)+    return ("Ha" ++ reverse (asName n))++asName :: Integer -> String+asName i+    | i == 0    = [chr (ord 'a')]+    | r == 0    = [chr (ord 'a' + (fromIntegral a))]+    | otherwise =  chr (ord 'a' + (fromIntegral a)) : asName r+    where+      (r,a) = i `quotRem` 26
+ src/Lambdabot/Plugin/Haddock.hs view
@@ -0,0 +1,35 @@+-- | Hackish Haddock module.+module Lambdabot.Plugin.Haddock (theModule) where++import Lambdabot.Plugin++import qualified Data.ByteString.Char8 as P+import Data.List+import qualified Data.Map as M++type HaddockState = M.Map P.ByteString [P.ByteString]+type Haddock = ModuleT HaddockState LB++theModule :: Module HaddockState+theModule = newModule+    { moduleCmds = return+        [ (command "index")+            { help = say "index <ident>. Returns the Haskell modules in which <ident> is defined"+            , process = doHaddock+            }+        ]+        +    , moduleDefState  = return M.empty+    , moduleSerialize = Just (readOnly readPacked)+    }++doHaddock :: String -> Cmd Haddock ()+doHaddock k = do+    m <- readMS+    say $ maybe "bzzt"+        (intercalate (", ") . map P.unpack)+        (M.lookup (stripPs (P.pack k)) m)++-- make \@index ($) work.+stripPs :: P.ByteString -> P.ByteString+stripPs = fst . P.spanEnd (==')') . snd . P.span (=='(')
+ src/Lambdabot/Plugin/Hello.hs view
@@ -0,0 +1,18 @@+--+-- | Hello world plugin+--+module Lambdabot.Plugin.Hello (theModule) where++import Lambdabot.Plugin++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "hello")+            { aliases = ["goodbye"]+            , help = say "hello/goodbye <arg>. Simplest possible plugin"+            , process = \xs -> say ("Hello world. " ++ xs)+            }+        ]+    }+
+ src/Lambdabot/Plugin/Help.hs view
@@ -0,0 +1,46 @@+-- | Provide help for plugins+module Lambdabot.Plugin.Help (theModule) where++import Lambdabot.Command+import Lambdabot.Message (Message)+import Lambdabot.Monad+import Lambdabot.Plugin++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "help")+            { help = say "help <command>. Ask for help for <command>. Try 'list' for all commands"+            , process = \args -> withMsg $ \msg -> do+                tgt <- getTarget+                lb (doHelp msg tgt args) >>= mapM_ say+            }+        ]+    }++moduleHelp :: (Monad m, Message a) =>+              Command m -> a -> Nick -> String -> m [String]+moduleHelp theCmd msg tgt cmd =+    execCmd (help theCmd) msg tgt cmd++--+-- If a target is a command, find the associated help, otherwise if it's+-- a module, return a list of commands that module implements.+--+doHelp :: Message t => t -> Nick -> [Char] -> LB [[Char]]+doHelp msg tgt [] = doHelp msg tgt "help"+doHelp msg tgt rest =+    withCommand arg                  -- see if it is a command+        (withModule arg              -- else maybe it's a module name+            (doHelp msg tgt "help")             -- else give up+            (\md -> do -- its a module+                cmds <- moduleCmds md+                let ss = cmds >>= cmdNames+                let s | null ss   = arg ++ " is a module."+                      | otherwise = arg ++ " provides: " ++ showClean ss+                return [s]))++        -- so it's a valid command, try to find its help+        (\_md theCmd -> moduleHelp theCmd msg tgt arg)++    where (arg:_) = words rest
+ src/Lambdabot/Plugin/Hoogle.hs view
@@ -0,0 +1,62 @@+-- 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.Hoogle (theModule) where++import Lambdabot.Plugin+import System.Process++theModule :: Module [String]+theModule = newModule+    { moduleDefState = return []+    , moduleCmds = return+        [ (command "hoogle")+            { help = say "hoogle <expr>. Haskell API Search for either names, or types."+            , process = \s -> do+                binary <- getConfig hoogleBinary+                o <- io (hoogle binary s)+                let (this,that) = splitAt 3 o+                writeMS that+                mapM_ say this+            }+        , (command "hoogle+")+            -- TODO: what does this really do?  give it a proper help msg+            { help = say "hoogle <expr>. Haskell API Search for either names, or types."+            , process = \_ -> do+                this <- withMS $ \st write -> do+                    let (this,that) = splitAt 3 st+                    write that+                    return this+                mapM_ say this+            }+        ]+    }++------------------------------------------------------------------------++-- arbitrary cutoff point+cutoff :: Int+cutoff = -10++-- | Actually run the hoogle binary+hoogle :: String -> String -> IO [String]+hoogle binary s = do+        let args = ["--count=20", s]+        (_,out,err) <- readProcessWithExitCode binary args ""+        return $ result out err++    where result [] [] = ["A Hoogle error occurred."]+          result [] ys = [ys]+          result xs _  =+                let xs' = map toPair $ lines xs+                    res = map snd $ filter ((>=cutoff) . fst) xs'+                in if null res+                   then ["No matches, try a more general search"]+                   else res++          toPair s' = let (res, meta)  = break (=='@') s'+                          rank = takeWhile (/=' ') . drop 2 $ meta+                      in case readM rank :: Maybe Int of+                         Just n  -> (n,res)+                         Nothing -> (0,res)
+ src/Lambdabot/Plugin/IRC.hs view
@@ -0,0 +1,146 @@+-- | The plugin-level IRC interface.++module Lambdabot.Plugin.IRC (theModule) where++import Lambdabot.Plugin+import Lambdabot.Monad+import Lambdabot.IRC++import Control.Concurrent.Lifted+import qualified Control.Concurrent.SSem as SSem+import Control.Exception.Lifted as E (SomeException(..), throwIO, catch)+import Control.Monad+import Control.Monad.Trans+import qualified Data.ByteString.Char8 as P+import Data.List+import Data.List.Split+import Network( connectTo, PortID(..) )+import System.IO+import System.Timeout.Lifted++type IRC = ModuleT () LB++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "irc-connect")+            { privileged = True+            , help = say "irc-connect tag host portnum nickname userinfo.  connect to an irc server"+            , process = \rest ->+                case splitOn " " rest of+                    tag:hostn:portn:nickn:uix -> do+                        pn <- (PortNumber . fromInteger) `fmap` readM portn+                        lift (online tag hostn pn nickn (intercalate " " uix))+                    _ -> say "Not enough parameters!"+            }+        ]+    }++----------------------------------------------------------------------+-- Encoding and decoding of messages++-- | 'encodeMessage' takes a message and converts it to a function.+--   giving this function a string will attach the string to the message+--   and output a string containing IRC protocol commands ready for writing+--   on the outgoing stream socket.+encodeMessage :: IrcMessage -> String -> String+encodeMessage msg+  = encodePrefix (ircMsgPrefix msg) . encodeCommand (ircMsgCommand msg)+          . encodeParams (ircMsgParams msg)+  where+    encodePrefix [] = id+    encodePrefix prefix = showChar ':' . showString prefix . showChar ' '++    encodeCommand cmd = showString cmd++    encodeParams [] = id+    encodeParams (p:ps) = showChar ' ' . showString p . encodeParams ps++-- | 'decodeMessage' Takes an input line from the IRC protocol stream+--   and decodes it into a message.  TODO: this has too many parameters.+decodeMessage :: String -> String -> String -> IrcMessage+decodeMessage svr lbn line =+    let (prefix, rest1) = decodePrefix (,) line+        (cmd, rest2)    = decodeCmd (,) rest1+        params          = decodeParams rest2+    in IrcMessage { ircMsgServer = svr, ircMsgLBName = lbn, ircMsgPrefix = prefix,+                    ircMsgCommand = cmd, ircMsgParams = params }+  where+    decodePrefix k (':':cs) = decodePrefix' k cs+      where decodePrefix' j ""       = j "" ""+            decodePrefix' j (' ':ds) = j "" ds+            decodePrefix' j (c:ds)   = decodePrefix' (j . (c:)) ds++    decodePrefix k cs = k "" cs++    decodeCmd k []       = k "" ""+    decodeCmd k (' ':cs) = k "" cs+    decodeCmd k (c:cs)   = decodeCmd (k . (c:)) cs++    decodeParams :: String -> [String]+    decodeParams xs = decodeParams' [] [] xs+      where+        decodeParams' param params []+          | null param = reverse params+          | otherwise  = reverse (reverse param : params)+        decodeParams' param params (' ' : cs)+          | null param = decodeParams' [] params cs+          | otherwise  = decodeParams' [] (reverse param : params) cs+        decodeParams' param params rest@(c@':' : cs)+          | null param = reverse (rest : params)+          | otherwise  = decodeParams' (c:param) params cs+        decodeParams' param params (c:cs) = decodeParams' (c:param) params cs++ircSignOn :: String -> Nick -> String -> LB ()+ircSignOn svr nickn ircname = do+    send $ user (nTag nickn) (nName nickn) svr ircname+    send $ setNick nickn++------------------------------------------------------------------------+--+-- Lambdabot is mostly synchronous.  We have a main loop, which reads+-- messages and forks threads to execute commands (which write responces).+-- OR+-- We have a main loop which reads offline commands, and synchronously+-- interprets them.++online :: String -> String -> PortID -> String -> String -> IRC ()+online tag hostn portnum nickn ui = do+    sock    <- io $ connectTo hostn portnum+    io $ hSetBuffering sock NoBuffering+    -- Implements flood control: RFC 2813, section 5.8+    sem1    <- io $ SSem.new 0+    sem2    <- io $ SSem.new 4 -- one extra token stays in the MVar+    sendmv  <- io newEmptyMVar+    io . void . fork . forever $ do+        SSem.wait sem1+        threadDelay 2000000+        SSem.signal sem2+    io . void . fork . forever $ do+        SSem.wait sem2+        putMVar sendmv ()+        SSem.signal sem1+    E.catch +        (addServer tag (io . sendMsg tag sock sendmv))+        (\err@SomeException{} -> io (hClose sock) >> E.throwIO err)+    lb $ ircSignOn hostn (Nick tag nickn) ui+    lb . void . fork $ E.catch+        (readerLoop tag nickn sock)+        (\e@SomeException{} -> do+            io $ hPutStrLn stderr $ "irc[" ++ tag ++ "] error: " ++ show e+            remServer tag)++readerLoop :: String -> String -> Handle -> LB ()+readerLoop tag nickn sock = forever $ do+    line <- io $ hGetLine sock+    let line' = filter (`notElem` "\r\n") line+    if "PING " `isPrefixOf` line'+        then io $ hPutStr sock ("PONG " ++ drop 5 line' ++ "\r\n")+        else void . fork . void . timeout 15000000 $ received (decodeMessage tag nickn line')++sendMsg :: String -> Handle -> MVar () -> IrcMessage -> IO ()+sendMsg tag sock mv msg =+    E.catch (do takeMVar mv+                P.hPut sock $ P.pack $ encodeMessage msg "\r\n")+            (\err -> do hPutStrLn stderr $ "irc[" ++ tag ++ "] error: " ++ show (err :: IOError)+                        hClose sock)
+ src/Lambdabot/Plugin/Instances.hs view
@@ -0,0 +1,147 @@+{- | 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.Instances (theModule) where++import Text.ParserCombinators.Parsec++import Lambdabot.Plugin++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++theModule :: Module ()+theModule = 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 dropSpace . 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
+ src/Lambdabot/Plugin/Karma.hs view
@@ -0,0 +1,110 @@+-- | Karma+module Lambdabot.Plugin.Karma (theModule) where++import Lambdabot.Compat.FreenodeNick+import Lambdabot.Plugin+import qualified Lambdabot.NickEq as E++import Data.Char+import Data.List+import qualified Data.Map as M+import Data.Maybe+import Text.Printf++type KarmaState = M.Map Nick Integer+type Karma = ModuleT KarmaState LB++theModule :: Module KarmaState+theModule = newModule+    { moduleCmds = return+        [ (command "karma")+            { help = say "karma <polynick>. Return a person's karma value"+            , process = \rest -> withMsg $ \msg -> do+                sender <- getSender+                tellKarma sender $ case words rest of+                    []       -> E.mononickToPolynick sender+                    (nick:_) -> E.readPolynick msg nick++            }+        , (command "karma+")+            { help = say "karma+ <nick>. Increment someone's karma"+            , process = doCmd 1+            }+        , (command "karma-")+            { help = say "karma- <nick>. Decrement someone's karma"+            , process = doCmd (-1)+            }+        , (command "karma-all")+            { help = say "karma-all. List all karma"+            , process = const listKarma+            }+        ]++    , moduleDefState  = return $ M.empty+    , moduleSerialize = Just freenodeNickMapSerial++    -- nick++($| )+    , contextual = \text -> withMsg $ \_ -> do+        sender <- getSender++        let ws          = words text+            decs        = match "--"+            incs        = match "++"+            match m     = mapM readNick . filter okay . map (reverse . drop 2)+                        . filter (isPrefixOf m) . map reverse $ ws+            okay x      = not (elem x badNicks || any (`isPrefixOf` x) badPrefixes)+            -- Special cases.  Ignore the null nick.  C must also be ignored+            -- because C++ and C-- are languages.+            badNicks    = ["", "C", "c", "notepad"]+            -- More special cases, to ignore Perl code.+            badPrefixes = ["$", "@", "%"]++        mapM_ (changeKarma (-1) sender) =<< decs+        mapM_ (changeKarma   1  sender) =<< incs+    }++doCmd :: Integer -> String -> Cmd Karma ()+doCmd dk rest = do+    sender <- getSender+    case words rest of+      []       -> say "usage @karma(+|-) nick"+      (nick:_) -> do+          nick' <- readNick nick+          changeKarma dk sender nick' >>= say++------------------------------------------------------------------------++tellKarma :: Nick -> E.Polynick -> Cmd Karma ()+tellKarma sender nick = do+    lookup' <- lb E.lookupMononickMap+    karma <- (sum . map snd . lookup' nick) `fmap` readMS+    nickStr <- withMsg (return . flip E.showPolynick nick)+    say $ concat [if E.mononickToPolynick sender == nick then "You have" else nickStr ++ " has"+                   ," a karma of "+                   ,show karma]++listKarma :: Cmd Karma ()+listKarma = do+    ks <- M.toList `fmap` readMS+    let ks' = sortBy (\(_,e) (_,e') -> e' `compare` e) ks+    flip mapM_ ks' $ \(k,e) -> do+        k' <- showNick k+        say (printf " %-20s %4d" k' e)++changeKarma :: Integer -> Nick -> Nick -> Cmd Karma String+changeKarma km sender nick+    | map toLower (nName nick) == "java" && km > 0 = do+        me <- getLambdabotName+        changeKarma (-km) me sender+    | sender == nick = return "You can't change your own karma, silly."+    | otherwise      = do+        nickStr <- showNick nick+        withMS $ \fm write -> do+            let fm' = M.insertWith (+) nick km fm+            let karma = fromMaybe 0 $ M.lookup nick fm'+            write fm'+            return (fmt nickStr km (show karma))+        where+            fmt n v k | v < 0     = n ++ "'s karma lowered to "    ++ k ++ "."+                      | v == 0    = n ++ "'s karma unchanged at "  ++ k ++ "."+                      | otherwise = n ++ "'s karma raised to "     ++ k ++ "."
+ src/Lambdabot/Plugin/Localtime.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE TypeFamilies #-}++-- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++-- | Simple wrapper over privmsg to get time information via the CTCP+module Lambdabot.Plugin.Localtime (theModule) where++import Lambdabot.Plugin+import Lambdabot (ircPrivmsg')+import qualified Data.Map as M++type TimeMap = M.Map Nick  -- the person who's time we requested+                    [Nick] -- a list of targets waiting on this time++theModule :: Module TimeMap+theModule = newModule+    { moduleDefState = return M.empty++    , moduleCmds = return+        [ (command "time")+            { aliases = ["localtime"]+            , help = say "time <user>. Print a user's local time. User's client must support ctcp pings."+            , process = doLocalTime+            }+        , (command "localtime-reply")+            { help = say "time <user>. Print a user's local time. User's client must support ctcp pings."+            , process = doReply+            }+        ]+    } :: Module TimeMap++-- record this person as a callback, for when we (asynchronously) get a result+doLocalTime :: (MonadLBState m, LBState m ~ M.Map Nick [Nick]) =>+               [Char] -> Cmd m ()+doLocalTime [] = do+    n <- getSender+    doLocalTime (nName n)++doLocalTime rawWho = do+    whoAsked <- getTarget+    whoToPing <- readNick $ fst $ break (== ' ') rawWho+    me <- getLambdabotName+    if whoToPing /= me+        then do+            modifyMS $ \st -> M.insertWith (++) whoToPing [whoAsked] st+            -- this is a CTCP time call, which returns a NOTICE+            lb $ ircPrivmsg' whoToPing ("\^ATIME\^A")     -- has to be raw+        else say "I live on the internet, do you expect me to have a local time?"++-- the Base module caught the NOTICE TIME, mapped it to a PRIVMGS, and here it is :)+doReply :: (MonadLBState m, LBState m ~ M.Map Nick [Nick]) =>+           [Char] -> Cmd m ()+doReply text = do+    let (whoGotPinged', time') = break (== ':') text+        time = drop 1 time'+    whoGotPinged <- readNick whoGotPinged'++    targets <- withMS $ \st set -> do+        case M.lookup whoGotPinged st of+            Nothing -> return []+            Just xs -> do set (M.insert whoGotPinged [] st) -- clear the callback state+                          return xs+    whoGotPinged'' <- showNick whoGotPinged+    let txt = "Local time for " ++ whoGotPinged'' ++ " is " ++ time+    lb $ flip mapM_ targets $ flip ircPrivmsg' txt
+ src/Lambdabot/Plugin/Log.hs view
@@ -0,0 +1,202 @@+-- Copyright (c) 2004 Thomas Jaeger+-- Copyright (c) 2005 Simon Winwood+-- Copyright (c) 2005 Don Stewart+-- Copyright (c) 2005 David House <dmouse@gmail.com>+--+-- | Logging an IRC channel..+--+module Lambdabot.Plugin.Log (theModule) where++import Lambdabot+import Lambdabot.Compat.FreenodeNick+import Lambdabot.IRC+import qualified Lambdabot.Message as Msg+import Lambdabot.Nick+import Lambdabot.Plugin++import Control.Monad+import qualified Data.Map as M+import Data.Time+import System.Directory (createDirectoryIfMissing)+import System.FilePath+import System.IO++-- ------------------------------------------------------------------------++type Channel = Nick++type DateStamp = (Int, Int, Integer)+data ChanState = CS { chanHandle  :: Handle,+                      chanDate    :: DateStamp }+               deriving (Show, Eq)+type LogState = M.Map Channel ChanState+type Log = ModuleT LogState LB++data Event =+    Said Nick UTCTime String+    | Joined Nick String UTCTime+    | Parted Nick String UTCTime -- covers quitting as well+    | Renick Nick String UTCTime Nick+    deriving (Eq)++instance Show Event where+    show (Said nick ct what)      = timeStamp ct ++ " <" ++ nName nick ++ "> " ++ what+    show (Joined nick usr ct)     = timeStamp ct ++ " " ++ show (FreenodeNick nick)+                                    ++ " (" ++ usr ++ ") joined."+    show (Parted nick usr ct)     = timeStamp ct ++ " " ++ show (FreenodeNick nick)+                                    ++ " (" ++ usr ++ ") left."+    show (Renick nick usr ct new) = timeStamp ct ++ " " ++ show  (FreenodeNick nick)+                                    ++ " (" ++ usr ++ ") is now " ++ show (FreenodeNick new) ++ "."++-- * Dispatchers and Module instance declaration+--+theModule :: Module (M.Map Channel ChanState)+theModule = newModule+    { moduleDefState  = return M.empty+    , moduleExit      = cleanLogState+    , moduleInit      = do+        let doLog f m hdl = logString hdl . show . f m+            wrapCB f = bindModule1 $ \msg -> do+                now <- io getCurrentTime+                -- map over the channels this message was directed to, adding to each+                -- of their log files.+                mapM_ (withValidLog (doLog f msg) now) (Msg.channels msg)+            connect signal cb = ircSignalConnect signal =<< wrapCB cb++        connect "PRIVMSG" msgCB+        connect "JOIN"    joinCB+        connect "PART"    partCB+        connect "NICK"    nickCB+    }++-- * Logging helpers+--++-- | Show a number, padded to the left with zeroes up to the specified width+showWidth :: Int    -- ^ Width to fill to+          -> Int    -- ^ Number to show+          -> String -- ^ Padded string+showWidth width n = zeroes ++ num+    where num    = show n+          zeroes = replicate (width - length num) '0'++timeStamp :: UTCTime -> String+timeStamp (UTCTime _ ct) =+    (showWidth 2 (hours `mod` 24)) ++ ":" +++    (showWidth 2 (mins  `mod` 60)) ++ ":" +++    (showWidth 2 (secs  `mod` 60))+    where+        secs  = round ct :: Int+        mins  = secs `div` 60+        hours = mins `div` 60++-- | Show a DateStamp.+dateToString :: DateStamp -> String+dateToString (d, m, y) = (showWidth 2 $ fromInteger y) ++ "-" +++                         (showWidth 2 $ fromEnum m + 1) ++ "-" +++                         (showWidth 2 d)++-- | UTCTime -> DateStamp conversion+dateStamp :: UTCTime -> DateStamp+dateStamp (UTCTime day _) = (d, m, y)+    where (y,m,d) = toGregorian day++-- * State manipulation functions+--++-- | Cleans up after the module (closes files)+cleanLogState :: Log ()+cleanLogState =+    withMS $ \state writer -> do+      io $ M.fold (\cs iom -> iom >> hClose (chanHandle cs)) (return ()) state+      writer M.empty++-- | Fetch a channel from the internal map. Uses LB's fail if not found.+getChannel :: Channel -> Log ChanState+getChannel c = (readMS >>=) . mLookup $ c+    where mLookup k = maybe (fail "getChannel: not found") return . M.lookup k++getDate :: Channel -> Log DateStamp+getDate c = fmap chanDate . getChannel $ c++getHandle :: Channel -> Log Handle+getHandle c = fmap chanHandle . getChannel $ c+    -- add points. otherwise:+    -- Unbound implicit parameters (?ref::GHC.IOBase.MVar LogState, ?name::String)+    --  arising from instantiating a type signature at+    -- Plugin/Log.hs:187:30-39+    -- Probable cause: `getChannel' is applied to too few arguments++-- | Put a DateStamp and a Handle. Used by 'openChannelFile' and+--  'reopenChannelMaybe'.+putHdlAndDS :: Channel -> Handle -> DateStamp -> Log ()+putHdlAndDS c hdl ds =+        modifyMS (M.adjust (\cs -> cs {chanHandle = hdl, chanDate = ds}) c)+++-- * Logging IO+--++-- | Open a file to write the log to.+openChannelFile :: Channel -> UTCTime -> Log Handle+openChannelFile chan ct = do+    stateDir <- getConfig outputDir+    let dir  = stateDir </> "Log" </> nTag chan </> nName chan+        file = dir </> (dateToString date) <.> "txt"+    io $ createDirectoryIfMissing True dir >> openFile file AppendMode+    where date = dateStamp ct++-- | Close and re-open a log file, and update the state.+reopenChannelMaybe :: Channel -> UTCTime -> Log ()+reopenChannelMaybe chan ct = do+  date <- getDate chan+  when (date /= dateStamp ct) $ do+    hdl <- getHandle chan+    io $ hClose hdl+    hdl' <- openChannelFile chan ct+    putHdlAndDS chan hdl' (dateStamp ct)++-- | Initialise the channel state (if it not already inited)+initChannelMaybe :: Nick -> UTCTime -> Log ()+initChannelMaybe chan ct = do+  chanp <- liftM (M.member chan) readMS+  unless chanp $ do+    hdl <- openChannelFile chan ct+    modifyMS (M.insert chan $ CS hdl (dateStamp ct))++-- | Ensure that the log is correctly initialised etc.+withValidLog :: (Handle -> UTCTime -> Log a) -> UTCTime -> Channel -> Log a+withValidLog f ct chan = do+  initChannelMaybe chan ct+  reopenChannelMaybe chan ct+  hdl <- getHandle chan+  rv <- f hdl ct+  return rv++-- | Log a string. Main logging workhorse.+logString :: Handle -> String -> Log ()+logString hdl str = io $ hPutStrLn hdl str >> hFlush hdl+  -- We flush on each operation to ensure logs are up to date.++-- * The event loggers themselves+--++-- | When somebody joins.+joinCB :: IrcMessage -> UTCTime -> Event+joinCB msg ct = Joined (Msg.nick msg) (Msg.fullName msg) ct++-- | When somebody quits.+partCB :: IrcMessage -> UTCTime -> Event+partCB msg ct = Parted (Msg.nick msg) (Msg.fullName msg) ct++-- | When somebody changes his\/her name.+-- TODO:  We should only do this for channels that the user is currently on.+nickCB :: IrcMessage -> UTCTime -> Event+nickCB msg ct = Renick (Msg.nick msg) (Msg.fullName msg) ct+                       (parseNick (Msg.server msg) $ drop 1 $ head $ ircMsgParams msg)++-- | When somebody speaks.+msgCB :: IrcMessage -> UTCTime -> Event+msgCB msg ct = Said (Msg.nick msg) ct+                    (tail . concat . tail $ ircMsgParams msg)+                      -- each lines is :foo
+ src/Lambdabot/Plugin/More.hs view
@@ -0,0 +1,46 @@+-- | Support for more(1) buffering+module Lambdabot.Plugin.More (theModule) where++import Lambdabot.Plugin+import Lambdabot++import Control.Monad.Trans++type MoreState = GlobalPrivate () [String]+type More = ModuleT MoreState LB++-- the @more state is handled centrally+theModule :: Module (GlobalPrivate () [String])+theModule = newModule+    { moduleDefState = return $ mkGlobalPrivate 20 ()+    , moduleInit+        =   bindModule2 moreFilter+        >>= ircInstallOutputFilter++    , moduleCmds = return+        [ (command "more")+            { help = say "@more. Return more output from the bot buffer."+            , process = \_ -> do+                target <- getTarget+                morestate <- readPS target+                -- TODO: test theory that we can just "say" morestate;+                --       it should end up going through the moreFilter as needed+                case morestate of+                    Nothing -> return ()+                    Just ls -> lift (moreFilter target ls)+                        >>= mapM_ (lb . ircPrivmsg' target)+            }+        ]+    }++moreFilter :: Nick -> [String] -> More [String]+moreFilter target msglines = do+    let (morelines, thislines) = case drop (maxLines+2) msglines of+          [] -> ([],msglines)+          _  -> (drop maxLines msglines, take maxLines msglines)+    writePS target $ if null morelines then Nothing else Just morelines+    return $ thislines ++ if null morelines+                          then []+                          else ['[':shows (length morelines) " @more lines]"]++    where maxLines = 5 -- arbitrary, really
+ src/Lambdabot/Plugin/Numberwang.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE TypeFamilies #-}++module Lambdabot.Plugin.Numberwang where++import Control.Applicative+import Control.Monad+import Data.Random+import Data.Random.Distribution.Poisson+import Lambdabot.Plugin+import Numeric+++data NumberwangState = State+    { nextCmd   :: !Int -- number of invocations of @numberwang before the next numberwang+    , nextCon   :: !Int -- number of contextual occurrences of numbers before next numberwang+    }++cmdDist :: RVar Int+cmdDist = poisson (3.5 :: Double)++conDist :: RVar Int+conDist = poisson (32  :: Double)++theModule :: Module NumberwangState+theModule = newModule+    { moduleDefState = sample (State <$> cmdDist <*> conDist)+    , moduleCmds = return+        [ (command "numberwang")+            { help = say "@numberwang <number>: Determines if it is Numberwang."+            , process = doNumberwang True . length . words+            }+        ]+    , contextual = doNumberwang False . length . (numbers :: String -> [Double])+    }++numbers :: RealFrac t => String -> [t]+numbers [] = []+numbers cs = case readFloat cs of+    (n, rest):_ -> n : numbers rest+    _           -> numbers (tail cs)++doNumberwang :: (Num a, Ord a, MonadLBState m, LBState m ~ NumberwangState) =>+                Bool -> a -> Cmd m ()+doNumberwang cmd n+    | n <= 0    = when cmd $ say "What number?"+    | otherwise = do+        isNumberwang <- checkNumberwang cmd 1+        if isNumberwang+            then say "That's Numberwang!"+            else when cmd $ say "Sorry, that's not Numberwang."++withState :: (MonadLBState m, LBState m ~ NumberwangState) =>+             Bool -> (Int -> (Int -> m ()) -> RVar Int -> m a) -> m a+withState True f = withMS $ \st setST ->+    f (nextCmd st) (\n -> setST st {nextCmd = n}) cmdDist+withState False f = withMS $ \st setST ->+    f (nextCon st) (\n -> setST st {nextCon = n}) conDist++checkNumberwang :: (MonadLBState m, LBState m ~ NumberwangState) =>+                   Bool -> Int -> m Bool+checkNumberwang cmd l = withState cmd $ \ n setN nDist -> do+    if n <= l+        then do+            setN =<< lb (sample nDist)+            return True+        else do+            setN (n - l)+            return False
+ src/Lambdabot/Plugin/OEIS.hs view
@@ -0,0 +1,18 @@+-- | Look up sequences in the Online Encyclopedia of Integer Sequences+--   Based on the Math.OEIS library+module Lambdabot.Plugin.OEIS (theModule) where++import Lambdabot.Plugin++import Math.OEIS++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "oeis")+            { aliases = ["sequence"]+            , help = say "oeis <sequence>. Look up a sequence in the Online Encyclopedia of Integer Sequences"+            , process = ios80 . fmap concat . lookupOEIS+            }+        ]+    }
+ src/Lambdabot/Plugin/OfflineRC.hs view
@@ -0,0 +1,104 @@+-- | Offline mode / RC file / -e support module.  Handles spooling lists+-- of commands (from haskeline, files, or the command line) into the vchat+-- layer.+module Lambdabot.Plugin.OfflineRC ( theModule ) where++import Lambdabot.Config.Core+import Lambdabot.IRC+import Lambdabot.Monad+import Lambdabot.Plugin++import Control.Concurrent.Lifted+import Control.Exception.Lifted ( evaluate, finally )+import Control.Monad( void, when )+import Control.Monad.State( gets )+import Control.Monad.Trans( lift, liftIO )+import Data.Char+import System.Console.Haskeline (InputT, Settings(..), runInputT, defaultSettings, getInputLine)+import System.IO+import System.Timeout.Lifted++-- We need to track the number of active sourcings so that we can+-- unregister the server (-> allow the bot to quit) when it is not+-- being used.+type OfflineRCState = Integer+type OfflineRC = ModuleT OfflineRCState LB++theModule :: Module OfflineRCState+theModule = newModule+    { moduleDefState = return 0+    , moduleInit = do+        void . fork $ do+            waitForInit+            lockRC+            cmds <- getConfig onStartupCmds+            mapM_ feed cmds `finally` unlockRC++    , moduleCmds = return+        [ (command "offline")+            { privileged = True+            , help = say "offline. Start a repl"+            , process = const . lift $ do+                lockRC+                histFile <- lb $ findOrCreateLBFile "offlinerc"+                let settings = defaultSettings { historyFile = Just histFile }+                _ <- fork (runInputT settings replLoop `finally` unlockRC)+                return ()+            }+        , (command "rc")+            { privileged = True+            , help = say "rc name. Read a file of commands (asynchonously). TODO: better name."+            , process = \fn -> lift $ do+                txt <- io $ readFile fn+                io $ evaluate $ foldr seq () txt+                lockRC+                _ <- fork (mapM_ feed (lines txt) `finally` unlockRC)+                return ()+            }+        ]+    }++feed :: String -> OfflineRC ()+feed msg = do+    cmdPrefix <- fmap head (getConfig commandPrefixes)+    let msg' = case msg of+            '>':xs -> cmdPrefix ++ "run " ++ xs+            '!':xs -> xs+            _      -> cmdPrefix ++ dropWhile (== ' ') msg+    lift . (>> return ()) . timeout (15 * 1000 * 1000) . received $+              IrcMessage { ircMsgServer = "offlinerc"+                         , ircMsgLBName = "offline"+                         , ircMsgPrefix = "null!n=user@null"+                         , ircMsgCommand = "PRIVMSG"+                         , ircMsgParams = ["offline", ":" ++ msg' ] }++handleMsg :: IrcMessage -> LB ()+handleMsg msg = liftIO $ do+    let str = case (tail . ircMsgParams) msg of+            []    -> []+            (x:_) -> tail x+    hPutStrLn stdout str+    hFlush stdout++replLoop :: InputT OfflineRC ()+replLoop = do+    line <- getInputLine "lambdabot> "+    case line of+        Nothing -> return ()+        Just x -> do+            let s' = dropWhile isSpace x+            when (not $ null s') $ do+                lift $ feed s'+            continue <- lift (lift (gets ircStayConnected))+            when continue replLoop++lockRC :: OfflineRC ()+lockRC = do+    withMS $ \ cur writ -> do+        when (cur == 0) (addServer "offlinerc" handleMsg)+        writ (cur + 1)++unlockRC :: OfflineRC ()+unlockRC = withMS $ \ cur writ -> do+    when (cur == 1) $ lb $ remServer "offlinerc"+    writ (cur - 1)
+ src/Lambdabot/Plugin/Pl.hs view
@@ -0,0 +1,88 @@+-- | Pointfree programming fun+--+-- A catalogue of refactorings is at:+--      http://www.cs.kent.ac.uk/projects/refactor-fp/catalogue/+--      http://www.cs.kent.ac.uk/projects/refactor-fp/catalogue/RefacIdeasAug03.html+--+-- Use more Arrow stuff+--+-- TODO would be to plug into HaRe and use some of their refactorings.+module Lambdabot.Plugin.Pl (theModule) where++import Lambdabot.Plugin++import Lambdabot.Plugin.Pl.Common          (TopLevel, mapTopLevel, getExpr)+import Lambdabot.Plugin.Pl.Parser          (parsePF)+import Lambdabot.Plugin.Pl.PrettyPrinter   (Expr)+import Lambdabot.Plugin.Pl.Transform       (transform)+import Lambdabot.Plugin.Pl.Optimize        (optimize)++import Data.IORef+import System.Timeout++-- firstTimeout is the timeout when the expression is simplified for the first+-- time. After each unsuccessful attempt, this number is doubled until it hits+-- maxTimeout.+firstTimeout, maxTimeout :: Int+firstTimeout =  3000000 --  3 seconds+maxTimeout   = 15000000 -- 15 seconds++type PlState = GlobalPrivate () (Int, TopLevel)+type Pl = ModuleT PlState LB++theModule :: Module (GlobalPrivate () (Int, TopLevel))+theModule = newModule+    { moduleDefState = return $ mkGlobalPrivate 15 ()+    +    , moduleCmds = return+        [ (command "pointless")+            { aliases = ["pl"]+            , help = say "pointless <expr>. Play with pointfree code."+            , process = pf+            }+        , (command "pl-resume")+            { help = say "pl-resume. Resume a suspended pointless transformation."+            , process = const res+            }+        ]+    }++------------------------------------------------------------------------++res :: Cmd Pl ()+res = do+  d <- readPS =<< getTarget+  case d of+    Just d' -> optimizeTopLevel d'+    Nothing -> say "pointless: sorry, nothing to resume."++-- | Convert a string to pointfree form+pf :: String -> Cmd Pl ()+pf inp = do+    case parsePF inp of+        Right d  -> optimizeTopLevel (firstTimeout, mapTopLevel transform d)+        Left err -> say err++optimizeTopLevel :: (Int, TopLevel) -> Cmd Pl ()+optimizeTopLevel (to, d) = do+    target <- getTarget+    let (e,decl) = getExpr d+    (e', finished) <- io $ optimizeIO to e+    let eDecl = decl e'+    say (show eDecl)+    if finished+        then writePS target Nothing+        else do+            writePS target $ Just (min (2*to) maxTimeout, eDecl)+            say "optimization suspended, use @pl-resume to continue."++------------------------------------------------------------------------++optimizeIO :: Int -> Expr -> IO (Expr, Bool)+optimizeIO to e = do+  best <- newIORef e+  result <- timeout to (mapM_ (writeIORef best $!) $ optimize e)+  e' <- readIORef best+  return $ case result of+    Nothing -> (e', False)+    Just _  -> (e', True)
+ src/Lambdabot/Plugin/Pl/Common.hs view
@@ -0,0 +1,137 @@+module Lambdabot.Plugin.Pl.Common (+        Fixity(..), Expr(..), Pattern(..), Decl(..), TopLevel(..),+        bt, sizeExpr, mapTopLevel, getExpr,+        operators, opchars, reservedOps, lookupOp, lookupFix, minPrec, maxPrec,+        comp, flip', id', const', scomb, cons, nil, fix', if',+        makeList, getList,+        Assoc(..),+        module Data.Maybe,+        module Control.Arrow,+        module Data.List,+        module Control.Monad,+        module GHC.Base+    ) where++import Data.Maybe (isJust, fromJust)+import Data.List (intersperse, minimumBy)+import qualified Data.Map as M++import Control.Monad+import Control.Arrow (first, second, (***), (&&&), (|||), (+++))++import Text.ParserCombinators.Parsec.Expr (Assoc(..))++import GHC.Base (assert)+++-- The rewrite rules can be found at the end of the file Rules.hs++-- Not sure if passing the information if it was used as infix or prefix+-- is worth threading through the whole thing is worth the effort,+-- but it stays that way until the prettyprinting algorithm gets more+-- sophisticated.+data Fixity = Pref | Inf deriving Show++instance Eq Fixity where+  _ == _ = True++instance Ord Fixity where+  compare _ _ = EQ++data Expr+  = Var Fixity String+  | Lambda Pattern Expr+  | App Expr Expr+  | Let [Decl] Expr+  deriving (Eq, Ord)++data Pattern+  = PVar String+  | PCons Pattern Pattern+  | PTuple Pattern Pattern+  deriving (Eq, Ord)++data Decl = Define {+  declName :: String,+  declExpr :: Expr+} deriving (Eq, Ord)++data TopLevel = TLD Bool Decl | TLE Expr deriving (Eq, Ord)++mapTopLevel :: (Expr -> Expr) -> TopLevel -> TopLevel+mapTopLevel f tl = case getExpr tl of (e, c) -> c $ f e++getExpr :: TopLevel -> (Expr, Expr -> TopLevel)+getExpr (TLD True (Define foo e)) = (Let [Define foo e] (Var Pref foo),+                                     \e' -> TLD False $ Define foo e')+getExpr (TLD False (Define foo e)) = (e, \e' -> TLD False $ Define foo e')+getExpr (TLE e)      = (e, TLE)++sizeExpr :: Expr -> Int+sizeExpr (Var _ _) = 1+sizeExpr (App e1 e2) = sizeExpr e1 + sizeExpr e2 + 1+sizeExpr (Lambda _ e) = 1 + sizeExpr e+sizeExpr (Let ds e) = 1 + sum (map sizeDecl ds) + sizeExpr e where+  sizeDecl (Define _ e') = 1 + sizeExpr e'++comp, flip', id', const', scomb, cons, nil, fix', if' :: Expr+comp   = Var Inf  "."+flip'  = Var Pref "flip"+id'    = Var Pref "id"+const' = Var Pref "const"+scomb  = Var Pref "ap"+cons   = Var Inf  ":"+nil    = Var Pref "[]"+fix'   = Var Pref "fix"+if'    = Var Pref "if'"++makeList :: [Expr] -> Expr+makeList = foldr (\e1 e2 -> cons `App` e1 `App` e2) nil++-- Modularity is a drag+getList :: Expr -> ([Expr], Expr)+getList (c `App` x `App` tl) | c == cons = first (x:) $ getList tl+getList e = ([],e)++bt :: a+bt = undefined++shift, minPrec, maxPrec :: Int+shift = 0+maxPrec = shift + 10+minPrec = 0++-- operator precedences are needed both for parsing and prettyprinting+operators :: [[(String, (Assoc, Int))]]+operators = (map . map . second . second $ (+shift))+  [[inf "." AssocRight 9, inf "!!" AssocLeft 9],+   [inf name AssocRight 8 | name <- ["^", "^^", "**"]],+   [inf name AssocLeft 7+     | name <- ["*", "/", "`quot`", "`rem`", "`div`", "`mod`", ":%", "%"]],+   [inf name AssocLeft 6  | name <- ["+", "-"]],+   [inf name AssocRight 5 | name <- [":", "++", "<+>"]],+   [inf name AssocNone 4+     | name <- ["==", "/=", "<", "<=", ">=", ">", "`elem`", "`notElem`"]] ++[inf name AssocLeft 4 | name <- ["<*","*>","<$>","<$","<**>"]],+   [inf "&&" AssocRight 3, inf "***" AssocRight 3, inf "&&&" AssocRight 3, inf "<|>" AssocLeft 3],+   [inf "||" AssocRight 2, inf "+++" AssocRight 2, inf "|||" AssocRight 2],+   [inf ">>" AssocLeft 1, inf ">>=" AssocLeft 1, inf "=<<" AssocRight 1, inf ">>>" AssocRight 1, inf "^>>" AssocRight 1, inf "^<<" AssocRight 1],+   [inf name AssocRight 0 | name <- ["$", "$!", "`seq`"]]+  ] where+  inf name assoc fx = (name, (assoc, fx))++opchars :: [Char]+opchars = "!@#$%^*./|=-+:?<>&"++reservedOps :: [String]+reservedOps = ["->", "..", "="]++opFM :: M.Map String (Assoc, Int)+opFM = (M.fromList $ concat operators)++lookupOp :: String -> Maybe (Assoc, Int)+lookupOp k = M.lookup k opFM++lookupFix :: String -> (Assoc, Int)+lookupFix str = case lookupOp $ str of+  Nothing -> (AssocLeft, 9 + shift)+  Just x  -> x
+ src/Lambdabot/Plugin/Pl/Names.hs view
@@ -0,0 +1,89 @@++--+-- | Names of haskell functions used in the Pl code+--+module Lambdabot.Plugin.Pl.Names where++import Lambdabot.Plugin.Pl.Common+++-- | Expressions with holes+-- No MLambda here because we only consider closed Terms (no alpha-renaming!).+-- Has to be in this module, otherwise we get recursion+data MExpr+  = MApp  !MExpr !MExpr  -- ^ Application+  | Hole  !Int           -- ^ Hole/argument where another expression could go+  | Quote !Expr+  deriving Eq+++-- Names+idE, flipE, bindE, extE, returnE, consE, appendE, nilE, foldrE, foldlE, fstE,+  sndE, dollarE, constE, uncurryE, curryE, compE, headE, tailE, sE, commaE, +  fixE, foldl1E, notE, equalsE, nequalsE, plusE, multE, zeroE, oneE, lengthE, +  sumE, productE, concatE, concatMapE, joinE, mapE, fmapE, fmapIE, subtractE, +  minusE, liftME, apE, liftM2E, seqME, zipE, zipWithE, +  crossE, firstE, secondE, andE, orE, allE, anyE :: MExpr+idE        = Quote $ Var Pref "id"+flipE      = Quote $ Var Pref "flip"+constE     = Quote $ Var Pref "const"+compE      = Quote $ Var Inf  "."+sE         = Quote $ Var Pref "ap"+fixE       = Quote $ Var Pref "fix"+bindE      = Quote $ Var Inf  ">>="+extE       = Quote $ Var Inf  "=<<"+returnE    = Quote $ Var Pref "return"+consE      = Quote $ Var Inf  ":"+nilE       = Quote $ Var Pref "[]"+appendE    = Quote $ Var Inf  "++"+foldrE     = Quote $ Var Pref "foldr"+foldlE     = Quote $ Var Pref "foldl"+fstE       = Quote $ Var Pref "fst"+sndE       = Quote $ Var Pref "snd"+dollarE    = Quote $ Var Inf  "$"+uncurryE   = Quote $ Var Pref "uncurry"+curryE     = Quote $ Var Pref "curry"+headE      = Quote $ Var Pref "head"+tailE      = Quote $ Var Pref "tail"+commaE     = Quote $ Var Inf  ","+foldl1E    = Quote $ Var Pref "foldl1"+equalsE    = Quote $ Var Inf  "=="+nequalsE   = Quote $ Var Inf  "/="+notE       = Quote $ Var Pref "not"+plusE      = Quote $ Var Inf  "+"+multE      = Quote $ Var Inf  "*"+zeroE      = Quote $ Var Pref "0"+oneE       = Quote $ Var Pref "1"+lengthE    = Quote $ Var Pref "length"+sumE       = Quote $ Var Pref "sum"+productE   = Quote $ Var Pref "product"+concatE    = Quote $ Var Pref "concat"+concatMapE = Quote $ Var Pref "concatMap"+joinE      = Quote $ Var Pref "join"+mapE       = Quote $ Var Pref "map"+fmapE      = Quote $ Var Pref "fmap"+fmapIE     = Quote $ Var Inf  "fmap"+subtractE  = Quote $ Var Pref "subtract"+minusE     = Quote $ Var Inf  "-"+liftME     = Quote $ Var Pref "liftM"+liftM2E    = Quote $ Var Pref "liftM2"+apE        = Quote $ Var Inf  "ap"+seqME      = Quote $ Var Inf  ">>"+zipE       = Quote $ Var Pref "zip"+zipWithE   = Quote $ Var Pref "zipWith"+crossE     = Quote $ Var Inf  "***"+firstE     = Quote $ Var Pref "first"+secondE    = Quote $ Var Pref "second"+andE       = Quote $ Var Pref "and"+orE        = Quote $ Var Pref "or"+allE       = Quote $ Var Pref "all"+anyE       = Quote $ Var Pref "any"++++a, c :: MExpr -> MExpr -> MExpr+a       = MApp+c e1 e2 = compE `a` e1 `a` e2+infixl 9 `a`+infixr 8 `c`+
+ src/Lambdabot/Plugin/Pl/Optimize.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE ImplicitParams #-}+module Lambdabot.Plugin.Pl.Optimize (+    optimize,+  ) where++import Lambdabot.Plugin.Pl.Common+import Lambdabot.Plugin.Pl.Rules+import Lambdabot.Plugin.Pl.PrettyPrinter ()++import Data.List (nub)+import Data.Maybe (listToMaybe)++cut :: [a] -> [a]+cut = take 1++toMonadPlus :: MonadPlus m => Maybe a -> m a+toMonadPlus Nothing = mzero+toMonadPlus (Just x)= return x++type Size = Double+-- | The 'size' of an expression, lower is better+--+-- This seems to be a better size for our purposes,+-- despite being "a little" slower because of the wasteful uglyprinting+sizeExpr' :: Expr -> Size+sizeExpr' e = fromIntegral (length $ show e) + adjust e where+  -- hackish thing to favor some expressions if the length is the same:+  -- (+ x) --> (x +)+  -- x >>= f --> f =<< x+  -- f $ g x --> f (g x)+  adjust :: Expr -> Size+  adjust (Var _ str) -- Just n <- readM str = log (n*n+1) / 4+                     | str == "uncurry"    = -4+--                     | str == "s"          = 5+                     | str == "flip"       = 0.1+                     | str == ">>="        = 0.05+                     | str == "$"          = 0.01+                     | str == "subtract"   = 0.01+                     | str == "ap"         = 2+                     | str == "liftM2"     = 1.01+                     | str == "return"     = -2+                     | str == "zipWith"    = -4+                     | str == "const"      = 0 -- -2+                     | str == "fmap"       = -1+  adjust (Lambda _ e') = adjust e'+  adjust (App e1 e2)  = adjust e1 + adjust e2+  adjust _ = 0++-- | Optimize an expression+optimize :: Expr -> [Expr]+optimize e = result where+  result :: [Expr]+  result = map (snd . fromJust) . takeWhile isJust .+    iterate (>>= simpleStep) $ Just (sizeExpr' e, e)++  simpleStep :: (Size, Expr) -> Maybe (Size, Expr)+  simpleStep t = do+    let chn  = let ?first = True  in step (snd t)+        chnn = let ?first = False in step =<< chn+        new  = filter (\(x,_) -> x < fst t) . map (sizeExpr' &&& id) $+                snd t: chn ++ chnn+    listToMaybe new++-- | Apply all rewrite rules once+step :: (?first :: Bool) => Expr -> [Expr]+step e = nub $ rewrite rules e++-- | Apply a single rewrite rule+--+rewrite :: (?first :: Bool) => RewriteRule -> Expr -> [Expr]+rewrite rl e = case rl of+    Up r1 r2     -> let e'  = cut $ rewrite r1 e+                        e'' = rewrite r2 =<< e'+                    in if null e'' then e' else e''+    OrElse r1 r2 -> let e'  = rewrite r1 e+                    in if null e' then rewrite r2 e else e'+    Then r1 r2   -> rewrite r2 =<< nub (rewrite r1 e)+    Opt  r       -> e: rewrite r e+    If   p  r    -> if null (rewrite p e) then mzero else rewrite r e+    Hard r       -> if ?first then rewrite r e else mzero+    Or rs        -> (\x -> rewrite x e) =<< rs+    RR {}        -> rewDeep rl e+    CRR {}       -> rewDeep rl e+    Down {}      -> rewDeep rl e++  where -- rew = ...; rewDeep = ...++-- Apply a 'deep' reqrite rule+rewDeep :: (?first :: Bool) => RewriteRule -> Expr -> [Expr]+rewDeep rule e = rew rule e `mplus` case e of+    Var _ _    -> mzero+    Lambda _ _ -> error "lambda: optimizer only works for closed expressions"+    Let _ _    -> error "let: optimizer only works for closed expressions"+    App e1 e2  -> ((`App` e2) `map` rewDeep rule e1) `mplus`+                  ((e1 `App`) `map` rewDeep rule e2)++-- | Apply a rewrite rule to an expression+--   in a 'deep' position, i.e. from inside a RR,CRR or Down+rew :: (?first :: Bool) => RewriteRule -> Expr -> [Expr]+rew (RR r1 r2)   e = toMonadPlus $ fire r1 r2 e+rew (CRR r)      e = toMonadPlus $ r e+rew (Or rs)      e = (\x -> rew x e) =<< rs+rew (Down r1 r2) e = if null e'' then e' else e''+  where+    e'  = cut $ rew r1 e+    e'' = rewDeep r2 =<< e'+rew r@(Then   {}) e = rewrite r e+rew r@(OrElse {}) e = rewrite r e+rew r@(Up     {}) e = rewrite r e+rew r@(Opt    {}) e = rewrite r e+rew r@(If     {}) e = rewrite r e+rew r@(Hard   {}) e = rewrite r e
+ src/Lambdabot/Plugin/Pl/Parser.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE PatternGuards #-}++-- TODO, use Language.Haskell+-- Doesn't handle string literals?++module Lambdabot.Plugin.Pl.Parser (parsePF) where++import Lambdabot.Plugin.Pl.Common++import Text.ParserCombinators.Parsec+import Text.ParserCombinators.Parsec.Expr+import Text.ParserCombinators.Parsec.Language+import qualified Text.ParserCombinators.Parsec.Token as T++-- is that supposed to be done that way?+tp :: T.TokenParser ()+tp = T.makeTokenParser $ haskellStyle {+  reservedNames = ["if","then","else","let","in"]+}++parens :: Parser a -> Parser a+parens = T.parens tp++brackets :: Parser a -> Parser a+brackets = T.brackets tp++symbol :: String -> Parser String+symbol = T.symbol tp++modIdentifier :: Parser String+modIdentifier = T.lexeme tp $ do+  c <- oneOf ['A'..'Z']+  cs <- many ( alphaNum <|> oneOf "_'.")+  return (c:cs)++atomic :: Parser String+atomic = try (string "()") <|> try (show `fmap` T.natural tp) <|> modIdentifier <|> T.identifier tp++reserved :: String -> Parser ()+reserved = T.reserved tp++charLiteral :: Parser Char+charLiteral = T.charLiteral tp++stringLiteral :: Parser String+stringLiteral = T.stringLiteral tp++table :: [[Operator Char st Expr]]+table = addToFirst def $ map (map inf) operators where+  addToFirst y (x:xs) = ((y:x):xs)+  addToFirst _ _ = assert False bt++  def :: Operator Char st Expr+  def = Infix (try $ do+      name <- parseOp+      guard $ not $ isJust $ lookupOp name+      spaces+      return $ \e1 e2 -> App (Var Inf name) e1 `App` e2+    ) AssocLeft++  inf :: (String, (Assoc, Int)) -> Operator Char st Expr+  inf (name, (assoc, _)) = Infix (try $ do+      _ <- string name+      notFollowedBy $ oneOf opchars+      spaces+      let name' = if head name == '`'+                  then tail . reverse . tail . reverse $ name+                  else name+      return $ \e1 e2 -> App (Var Inf name') e1 `App` e2+    ) assoc+++parseOp :: CharParser st String+parseOp = (between (char '`') (char '`') $ many1 (letter <|> digit))+  <|> try (do+    op <- many1 $ oneOf opchars+    guard $ not $ op `elem` reservedOps+    return op)++pattern :: Parser Pattern+pattern = buildExpressionParser ptable ((PVar `fmap`+                       (    atomic+                        <|> (symbol "_" >> return "")))+                        <|> parens pattern)+    <?> "pattern" where+  ptable = [[Infix (symbol ":" >> return PCons) AssocRight],+            [Infix (symbol "," >> return PTuple) AssocNone]]++lambda :: Parser Expr+lambda = do+    _  <- symbol "\\"+    vs <- many1 pattern+    _  <- symbol "->"+    e  <- myParser False+    return $ foldr Lambda e vs+  <?> "lambda abstraction"++var :: Parser Expr+var = try (makeVar `fmap` atomic <|>+           parens (try unaryNegation <|> try rightSection+                   <|> try (makeVar `fmap` many1 (char ','))+                   <|> tuple) <|> list <|> (Var Pref . show) `fmap` charLiteral+                   <|> stringVar `fmap` stringLiteral)+        <?> "variable" where+  makeVar v | Just _ <- lookupOp v = Var Inf v -- operators always want to+                                               -- be infixed+            | otherwise            = Var Pref v+  stringVar :: String -> Expr+  stringVar str = makeList $ (Var Pref . show) `map` str++list :: Parser Expr+list = msum (map (try . brackets) plist) <?> "list" where+  plist = [+    foldr (\e1 e2 -> cons `App` e1 `App` e2) nil `fmap`+      (myParser False `sepBy` symbol ","),+    do e <- myParser False+       _ <- symbol ".."+       return $ Var Pref "enumFrom" `App` e,+    do e  <- myParser False+       _  <- symbol ","+       e' <- myParser False+       _  <- symbol ".."+       return $ Var Pref "enumFromThen" `App` e `App` e',+    do e  <- myParser False+       _  <- symbol ".."+       e' <- myParser False+       return $ Var Pref "enumFromTo" `App` e `App` e',+    do e   <- myParser False+       _   <- symbol ","+       e'  <- myParser False+       _   <- symbol ".."+       e'' <- myParser False+       return $ Var Pref "enumFromThenTo" `App` e `App` e' `App` e''+    ]++tuple :: Parser Expr+tuple = do+    elts <- myParser False `sepBy` symbol ","+    guard $ length elts /= 1+    let name = Var Pref $ replicate (length elts - 1) ','+    return $ foldl App name elts+  <?> "tuple"++unaryNegation :: Parser Expr+unaryNegation = do+    _ <- symbol "-"+    e <- myParser False+    return $ Var Pref "negate" `App` e+  <?> "unary negation"++rightSection :: Parser Expr+rightSection = do+    v <- Var Inf `fmap` parseOp+    spaces+    let rs e = flip' `App` v `App` e+    option v (rs `fmap` myParser False)+  <?> "right section"+++myParser :: Bool -> Parser Expr+myParser b = lambda <|> expr b++expr :: Bool -> Parser Expr+expr b = buildExpressionParser table (term b) <?> "expression"++decl :: Parser Decl+decl = do+  f <- atomic+  args <- pattern `endsIn` symbol "="+  e <- myParser False+  return $ Define f (foldr Lambda e args)++letbind :: Parser Expr+letbind = do+  reserved "let"+  ds <- decl `sepBy` symbol ";"+  reserved "in"+  e <- myParser False+  return $ Let ds e++ifexpr :: Parser Expr+ifexpr = do+  reserved "if"+  p <- myParser False+  reserved "then"+  e1 <- myParser False+  reserved "else"+  e2 <- myParser False+  return $ if' `App` p `App` e1 `App` e2++term :: Bool -> Parser Expr+term b = application <|> lambda <|> letbind <|> ifexpr <|>+    (guard b >> (notFollowedBy (noneOf ")") >> return (Var Pref "")))+  <?> "simple term"++application :: Parser Expr+application = do+    e:es <- many1 $ var <|> parens (myParser True)+    return $ foldl App e es+  <?> "application"++endsIn :: Parser a -> Parser b -> Parser [a]+endsIn p end = do+  xs <- many p+  _  <- end+  return $ xs++input :: Parser TopLevel+input = do+  spaces+  tl <- try (do+      f    <- atomic+      args <- pattern `endsIn` symbol "="+      e    <- myParser False+      return $ TLD True $ Define f (foldr Lambda e args)+    ) <|> TLE `fmap` myParser False+  eof+  return tl++parsePF :: String -> Either String TopLevel+parsePF inp = case runParser input () "" inp of+    Left err -> Left $ show err+    Right e  -> Right $ mapTopLevel postprocess e+++postprocess :: Expr -> Expr+postprocess (Var f v) = (Var f v)+postprocess (App e1 (Var Pref "")) = postprocess e1+postprocess (App e1 e2) = App (postprocess e1) (postprocess e2)+postprocess (Lambda v e) = Lambda v (postprocess e)+postprocess (Let ds e) = Let (mapDecl postprocess `map` ds) $ postprocess e where+  mapDecl :: (Expr -> Expr) -> Decl -> Decl+  mapDecl f (Define foo e') = Define foo $ f e'+
+ src/Lambdabot/Plugin/Pl/PrettyPrinter.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE PatternGuards #-}+module Lambdabot.Plugin.Pl.PrettyPrinter (Expr) where++-- Dummy export to make ghc -Wall happy++import Lambdabot.Util.Serial (readM)+import Lambdabot.Plugin.Pl.Common++instance Show Decl where+  show (Define f e) = f ++ " = " ++ show e+  showList ds = (++) $ concat $ intersperse "; " $ map show ds++instance Show TopLevel where+  showsPrec p (TLE e) = showsPrec p e+  showsPrec p (TLD _ d) = showsPrec p d++-- | Expression with syntactic sugar+data SExpr+  = SVar !String+  | SLambda ![Pattern] !SExpr+  | SLet ![Decl] !SExpr+  | SApp !SExpr !SExpr+  | SInfix !String !SExpr !SExpr+  | LeftSection !String !SExpr  -- (x +)+  | RightSection !String !SExpr -- (+ x)+  | List ![SExpr]+  | Tuple ![SExpr]+  | Enum !Expr !(Maybe Expr) !(Maybe Expr)++{-# INLINE toSExprHead #-}+toSExprHead :: String -> [Expr] -> Maybe SExpr+toSExprHead hd tl+  | all (==',') hd, length hd+1 == length tl+  = Just . Tuple . reverse $ map toSExpr tl+  | otherwise = case (hd,reverse tl) of+      ("enumFrom", [e])              -> Just $ Enum e Nothing   Nothing+      ("enumFromThen", [e,e'])       -> Just $ Enum e (Just e') Nothing+      ("enumFromTo", [e,e'])         -> Just $ Enum e Nothing   (Just e')+      ("enumFromThenTo", [e,e',e'']) -> Just $ Enum e (Just e') (Just e'')+      _                              -> Nothing++toSExpr :: Expr -> SExpr+toSExpr (Var _ v) = SVar v+toSExpr (Lambda v e) = case toSExpr e of+  (SLambda vs e') -> SLambda (v:vs) e'+  e'              -> SLambda [v] e'+toSExpr (Let ds e) = SLet ds $ toSExpr e+toSExpr e | Just (hd,tl) <- getHead e, Just se <- toSExprHead hd tl = se+toSExpr e | (ls, tl) <- getList e, tl == nil+  = List $ map toSExpr ls+toSExpr (App e1 e2) = case e1 of+  App (Var Inf v) e0+    -> SInfix v (toSExpr e0) (toSExpr e2)+  Var Inf v | v /= "-"+    -> LeftSection v (toSExpr e2)++  Var _ "flip" | Var Inf v <- e2, v == "-" -> toSExpr $ Var Pref "subtract"++  App (Var _ "flip") (Var pr v)+    | v == "-"  -> toSExpr $ Var Pref "subtract" `App` e2+    | v == "id" -> RightSection "$" (toSExpr e2)+    | Inf <- pr -> RightSection v (toSExpr e2)+  _ -> SApp (toSExpr e1) (toSExpr e2)++getHead :: Expr -> Maybe (String, [Expr])+getHead (Var _ v) = Just (v, [])+getHead (App e1 e2) = second (e2:) `fmap` getHead e1+getHead _ = Nothing++instance Show Expr where+  showsPrec p = showsPrec p . toSExpr++instance Show SExpr where+  showsPrec _ (SVar v) = (getPrefName v ++)+  showsPrec p (SLambda vs e) = showParen (p > minPrec) $ ('\\':) .+    foldr (.) id (intersperse (' ':) (map (showsPrec $ maxPrec+1) vs)) .+    (" -> "++) . showsPrec minPrec e+  showsPrec p (SApp e1 e2) = showParen (p > maxPrec) $+    showsPrec maxPrec e1 . (' ':) . showsPrec (maxPrec+1) e2+  showsPrec _ (LeftSection fx e) = showParen True $+    showsPrec (snd (lookupFix fx) + 1) e . (' ':) . (getInfName fx++)+  showsPrec _ (RightSection fx e) = showParen True $+    (getInfName fx++) . (' ':) . showsPrec (snd (lookupFix fx) + 1) e+  showsPrec _ (Tuple es) = showParen True $+    (concat `id` intersperse ", " (map show es) ++)++  showsPrec _ (List es)+    | Just cs <- mapM ((=<<) readM . fromSVar) es = shows (cs::String)+    | otherwise = ('[':) .+      (concat `id` intersperse ", " (map show es) ++) . (']':)+    where fromSVar (SVar str) = Just str+          fromSVar _          = Nothing+  showsPrec _ (Enum fr tn to) = ('[':) . shows fr .+    showsMaybe (((',':) . show) `fmap` tn) . (".."++) .+    showsMaybe (show `fmap` to) . (']':)+      where showsMaybe = maybe id (++)+  showsPrec _ (SLet ds e) = ("let "++) . shows ds . (" in "++) . shows e+++  showsPrec p (SInfix fx e1 e2) = showParen (p > fixity) $+    showsPrec f1 e1 . (' ':) . (getInfName fx++) . (' ':) .+    showsPrec f2 e2 where+      fixity = snd $ lookupFix fx+      (f1, f2) = case fst $ lookupFix fx of+        AssocRight -> (fixity+1, fixity + infixSafe e2 AssocLeft fixity)+        AssocLeft  -> (fixity + infixSafe e1 AssocRight fixity, fixity+1)+        AssocNone  -> (fixity+1, fixity+1)++      -- This is a little bit awkward, but at least seems to produce no false+      -- results anymore+      infixSafe :: SExpr -> Assoc -> Int -> Int+      infixSafe (SInfix fx'' _ _) assoc fx'+        | lookupFix fx'' == (assoc, fx') = 1+        | otherwise = 0+      infixSafe _ _ _ = 0 -- doesn't matter++instance Show Pattern where+  showsPrec _ (PVar v) = (v++)+  showsPrec _ (PTuple p1 p2) = showParen True $+    showsPrec 0 p1 . (", "++) . showsPrec 0 p2+  showsPrec p (PCons p1 p2) = showParen (p>5) $+    showsPrec 6 p1 . (':':) . showsPrec 5 p2++isOperator :: String -> Bool+isOperator = all (`elem` opchars)++getInfName :: String -> String+getInfName str = if isOperator str then str else "`"++str++"`"++getPrefName :: String -> String+getPrefName str = if isOperator str || ',' `elem` str then "("++str++")" else str++instance Eq Assoc where+  AssocLeft  == AssocLeft  = True+  AssocRight == AssocRight = True+  AssocNone  == AssocNone  = True+  _          == _          = False++{-+instance Show Assoc where+  show AssocLeft  = "AssocLeft"+  show AssocRight = "AssocRight"+  show AssocNone  = "AssocNone"++instance Ord Assoc where+  AssocNone <= _ = True+  _ <= AssocNone = False+  AssocLeft <= _ = True+  _ <= AssocLeft = False+  _ <= _ = True+-}
+ src/Lambdabot/Plugin/Pl/RuleLib.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE FlexibleInstances, PatternGuards, ScopedTypeVariables #-}++-- | This marvellous module contributed by Thomas J\344ger+module Lambdabot.Plugin.Pl.RuleLib+       (  -- Using rules+          RewriteRule(..), fire+       ,  -- Defining rules+          rr,rr0,rr1,rr2,up,down+       ) where++import Lambdabot.Plugin.Pl.Common+import Lambdabot.Plugin.Pl.Names++import Data.Array+import qualified Data.Set as S++import Control.Monad.Fix (fix)++-- Next time I do somthing like this, I'll actually think about the combinator+-- language before, instead of producing something ad-hoc like this:+data RewriteRule+  = RR     Rewrite Rewrite           -- ^ A 'Rewrite' rule, rewrite the first to the second+                                     --   'Rewrite's can contain 'Hole's+  | CRR    (Expr -> Maybe Expr)      -- ^ Haskell function as a rule, applied to subexpressions+  | Down   RewriteRule RewriteRule   -- ^ Like Up, but applied to subexpressions+  | Up     RewriteRule RewriteRule   -- ^ Apply the first rule, then try the second rule on the first result+                                     --   if it fails, returns the result of the first rule+  | Or     [RewriteRule]             -- ^ Use all rules+  | OrElse RewriteRule RewriteRule   -- ^ Try the first rule, if it fails use the second rule+  | Then   RewriteRule RewriteRule   -- ^ Apply the first rule, apply the second rule to the result+  | Opt    RewriteRule               -- ^ Optionally apply the rewrite rule, Opt x == Or [identity,x]+  | If     RewriteRule RewriteRule   -- ^ Apply the second rule only if the first rule has some results+  | Hard   RewriteRule               -- ^ Apply the rule only in the first pass++-- | An expression with holes to match or replace+data Rewrite = Rewrite {+  holes :: MExpr,  -- ^ Expression with holes+  rid   :: Int     -- ^ Number of holes+}++-- What are you gonna do when no recursive modules are possible?+class RewriteC a where+  getRewrite :: a -> Rewrite++instance RewriteC MExpr where+  getRewrite rule = Rewrite {+    holes = rule,+    rid   = 0+  }++-- lift functions to rewrite rules+instance RewriteC a => RewriteC (MExpr -> a) where+  getRewrite rule = Rewrite {+    holes = holes . getRewrite . rule . Hole $ pid,+    rid   = pid + 1+  } where+     pid = rid $ getRewrite (undefined :: a)+++----------------------------------------------------------------------------------------+-- Applying/matching Rewrites++type ExprArr = Array Int Expr++-- | Fill in the holes in a 'MExpr'+myFire :: ExprArr -> MExpr -> MExpr+myFire xs (MApp e1 e2) = MApp (myFire xs e1) (myFire xs e2)+myFire xs (Hole h) = Quote $ xs ! h+myFire _ me = me++nub' :: Ord a => [a] -> [a]+nub' = S.toList . S.fromList++-- | Create an array, only if the keys in 'lst' are unique and all keys [0..n-1] are given+uniqueArray :: Ord v => Int -> [(Int, v)] -> Maybe (Array Int v)+uniqueArray n lst+  | length (nub' lst) == n = Just $ array (0,n-1) lst+  | otherwise = Nothing++-- | Try to match a Rewrite to an expression,+--   if there is a match, returns the expressions in the holes+match :: Rewrite -> Expr -> Maybe ExprArr+match (Rewrite hl rid') e  = uniqueArray rid' =<< matchWith hl e++-- | Fill in the holes in a 'Rewrite'+fire' :: Rewrite -> ExprArr -> MExpr+fire' (Rewrite hl _)   = (`myFire` hl)++fire :: Rewrite -> Rewrite -> Expr -> Maybe Expr+fire r1 r2 e = (fromMExpr . fire' r2) `fmap` match r1 e++-- | Match an Expr to a MExpr template, return the values used in the holes+matchWith :: MExpr -> Expr -> Maybe [(Int, Expr)]+matchWith (MApp e1 e2) (App e1' e2') =+  liftM2 (++) (matchWith e1 e1') (matchWith e2 e2')+matchWith (Quote e) e' = if e == e' then Just [] else Nothing+matchWith (Hole k) e = Just [(k,e)]+matchWith _ _ = Nothing++fromMExpr :: MExpr -> Expr+fromMExpr (MApp e1 e2)  = App (fromMExpr e1) (fromMExpr e2)+fromMExpr (Hole _)      = Var Pref "Hole" -- error "Hole in MExpr"+fromMExpr (Quote e)     = e++----------------------------------------------------------------------------------------+-- Difining rules++-- | Yet another pointless transformation:+--   Bring an MExpr to (more pointless) form by seeing it as a function+--     \hole_n -> ...+--   and writing that in pointless form+transformM :: Int -> MExpr -> MExpr+transformM _ (Quote e) = constE `a` Quote e+transformM n (Hole n') = if n == n' then idE else constE `a` Hole n'+transformM n (Quote (Var _ ".") `MApp` e1 `MApp` e2)+  | e1 `hasHole` n && not (e2 `hasHole` n)+  = flipE `a` compE `a` e2 `c` transformM n e1+transformM n e@(MApp e1 e2)+  | fr1 && fr2 = sE `a` transformM n e1 `a` transformM n e2+  | fr1        = flipE `a` transformM n e1 `a` e2+  | fr2, Hole n' <- e2, n' == n = e1+  | fr2        = e1 `c` transformM n e2+  | otherwise  = constE `a` e+  where+    fr1 = e1 `hasHole` n+    fr2 = e2 `hasHole` n++-- | Is there a (Hole n) in an expression?+hasHole :: MExpr -> Int -> Bool+hasHole (MApp e1 e2) n = e1 `hasHole` n || e2 `hasHole` n+hasHole (Quote _)    _ = False+hasHole (Hole n')    n = n == n'++-- | Variants of a rewrite rule: fill in (some of) the holes+--+-- haddock doesn't like n+k patterns, so rewrite them+--+getVariants, getVariants' :: Rewrite -> [Rewrite]+getVariants' r@(Rewrite _ 0)  = [r]+getVariants' r@(Rewrite e nk)+    | nk >= 1    = r : getVariants (Rewrite e' (nk-1))+    | otherwise  = error "getVariants' : nk went negative"+    where+        e' = decHoles $ transformM 0 e++        -- decrement all hole numbers+        decHoles (Hole n')    = Hole (n'-1)+        decHoles (MApp e1 e2) = decHoles e1 `MApp` decHoles e2+        decHoles me           = me++getVariants = getVariants' -- r = trace (show vs) vs where vs = getVariants' r++-- | Use this rewrite rule and rewrite rules derived from it by iterated+--   pointless transformation+rrList :: RewriteC a => a -> a -> [RewriteRule]+rrList r1 r2 = zipWith RR (getVariants r1') (getVariants r2') where+  r1' = getRewrite r1+  r2' = getRewrite r2++-- | Construct a 'RR' rewrite rule+rr, rr0, rr1, rr2 :: RewriteC a => a -> a -> RewriteRule+rr  r1 r2 = Or          $ rrList r1 r2+rr1 r1 r2 = Or . take 2 $ rrList r1 r2+rr2 r1 r2 = Or . take 3 $ rrList r1 r2+-- use only this rewrite rule, no variants+rr0 r1 r2 = RR r1' r2' where+  r1' = getRewrite r1+  r2' = getRewrite r2++-- | Apply Down/Up repeatedly+down, up :: RewriteRule -> RewriteRule+down = fix . Down+up   = fix . Up
+ src/Lambdabot/Plugin/Pl/Rules.hs view
@@ -0,0 +1,562 @@+{-# LANGUAGE ExistentialQuantification, PatternGuards, Rank2Types #-}++-- | This marvellous module contributed by Thomas J\344ger+module Lambdabot.Plugin.Pl.Rules (RewriteRule(..), fire, rules) where++import Lambdabot.Util.Serial (readM)++import Lambdabot.Plugin.Pl.Common+import Lambdabot.Plugin.Pl.RuleLib+import Lambdabot.Plugin.Pl.Names+++----------------------------------------------------------------------------------------+-- Operator rules++collapseLists :: Expr -> Maybe Expr+collapseLists (Var _ "++" `App` e1 `App` e2)+  | (xs,x) <- getList e1, x==nil,+    (ys,y) <- getList e2, y==nil = Just $ makeList $ xs ++ ys+collapseLists _ = Nothing++data Binary = forall a b c. (Read a, Show a, Read b, Show b, Read c, Show c) => BA (a -> b -> c)++evalBinary :: [(String, Binary)] -> Expr -> Maybe Expr+evalBinary fs (Var _ f' `App` Var _ x' `App` Var _ y')+  | Just (BA f) <- lookup f' fs = (Var Pref . show) `fmap` liftM2 f (readM x') (readM y')+evalBinary _ _ = Nothing++data Unary = forall a b. (Read a, Show a, Read b, Show b) => UA (a -> b)++evalUnary :: [(String, Unary)] -> Expr -> Maybe Expr+evalUnary fs (Var _ f' `App` Var _ x')+  | Just (UA f) <- lookup f' fs = (Var Pref . show . f) `fmap` readM x'+evalUnary _ _ = Nothing++assocR, assocL, assoc :: [String] -> Expr -> Maybe Expr+-- (f `op` g) `op` h --> f `op` (g `op` h)+assocR ops (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2) `App` e3)+  | op1 == op2 && op1 `elem` ops+  = Just (Var f1 op1 `App` e1 `App` (Var f2 op2 `App` e2 `App` e3))+assocR _ _ = Nothing++-- f `op` (g `op` h) --> (f `op` g) `op` h+assocL ops (Var f1 op1 `App` e1 `App` (Var f2 op2 `App` e2 `App` e3))+  | op1 == op2 && op1 `elem` ops+  = Just (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2) `App` e3)+assocL _ _ = Nothing++-- op f . op g --> op (f `op` g)+assoc ops (Var _ "." `App` (Var f1 op1 `App` e1) `App` (Var f2 op2 `App` e2))+  | op1 == op2 && op1 `elem` ops+  = Just (Var f1 op1 `App` (Var f2 op2 `App` e1 `App` e2))+assoc _ _ = Nothing++commutative :: [String] -> Expr -> Maybe Expr+commutative ops (Var f op `App` e1 `App` e2)+  | op `elem` ops = Just (Var f op `App` e2 `App` e1)+commutative ops (Var _ "flip" `App` e@(Var _ op)) | op `elem` ops = Just e+commutative _ _ = Nothing++----------------------------------------------------------------------------------------+-- Rewrite rules+++-- TODO: Move rules into a file.+{-# INLINE simplifies #-}+simplifies :: RewriteRule+simplifies = Or [+  -- (f . g) x --> f (g x)+  rr0 (\f g x -> (f `c` g) `a` x)+      (\f g x -> f `a` (g `a` x)),+  -- id x --> x+  rr0 (\x -> idE `a` x)+      (\x -> x),+  -- flip (flip x) --> x+  rr  (\x -> flipE `a` (flipE `a` x))+      (\x -> x),+  -- flip id x . f --> flip f x+  rr0 (\f x -> (flipE `a` idE `a` x) `c` f)+      (\f x -> flipE `a` f `a` x),+  -- id . f --> f+  rr0 (\f -> idE `c` f)+      (\f -> f),+  -- f . id --> f+  rr0 (\f -> f `c` idE)+      (\f -> f),+  -- const x y --> x+  rr0 (\x y -> constE `a` x `a` y)+      (\x _ -> x),+  -- not (not x) --> x+  rr  (\x -> notE `a` (notE `a` x))+      (\x -> x),+  -- fst (x,y) --> x+  rr  (\x y -> fstE `a` (commaE `a` x `a` y))+      (\x _ -> x),+  -- snd (x,y) --> y+  rr  (\x y -> sndE `a` (commaE `a` x `a` y))+      (\_ y -> y),+  -- head (x:xs) --> x+  rr  (\x xs -> headE `a` (consE `a` x `a` xs))+      (\x _  -> x),+  -- tail (x:xs) --> xs+  rr  (\x xs -> tailE `a` (consE `a` x `a` xs))+      (\_ xs -> xs),+  -- uncurry f (x,y) --> f x y+  rr1 (\f x y -> uncurryE `a` f `a` (commaE `a` x `a` y))+      (\f x y -> f `a` x `a` y),+  -- uncurry (,) --> id+  rr  (uncurryE `a` commaE)+      (idE),+  -- uncurry f . s (,) g --> s f g+  rr1 (\f g -> (uncurryE `a` f) `c` (sE `a` commaE `a` g))+      (\f g -> sE `a` f `a` g),+  -- curry fst --> const+  rr (curryE `a` fstE) (constE),+  -- curry snd --> const id+  rr (curryE `a` sndE) (constE `a` idE),+  -- s f g x --> f x (g x)+  rr0 (\f g x -> sE `a` f `a` g `a` x)+      (\f g x -> f `a` x `a` (g `a` x)),+  -- flip f x y --> f y x+  rr0 (\f x y -> flipE `a` f `a` x `a` y)+      (\f x y -> f `a` y `a` x),+  -- flip (=<<) --> (>>=)+  rr0 (flipE `a` extE)+      bindE,++  -- TODO: Think about map/fmap+  -- fmap id --> id+  rr (fmapE `a` idE)+     (idE),+  -- map id --> id+  rr (mapE `a` idE)+     (idE),+  -- (f . g) . h --> f . (g . h)+  rr0 (\f g h -> (f `c` g) `c` h)+      (\f g h -> f `c` (g `c` h)),+  -- fmap f . fmap g -> fmap (f . g)+  rr0 (\f g -> fmapE `a` f `c` fmapE `a` g)+      (\f g -> fmapE `a` (f `c` g)),+  -- map f . map g -> map (f . g)+  rr0 (\f g -> mapE `a` f `c` mapE `a` g)+      (\f g -> mapE `a` (f `c` g))++  ]++onceRewrites :: RewriteRule+onceRewrites = Hard $ Or [+  -- ($) --> id+  rr0 (dollarE)+      idE,+  -- concatMap --> (=<<)+  rr concatMapE extE,+  -- concat    --> join+  rr concatE joinE,+  -- liftM --> fmap+  rr liftME fmapE,+  -- map --> fmap+  rr mapE fmapE,+  -- subtract -> flip (-)+  rr  subtractE+      (flipE `a` minusE)+  ]++-- Now we can state rewrite rules in a nice high level way+-- Rewrite rules should be as pointful as possible since the pointless variants+-- will be derived automatically.+rules :: RewriteRule+rules = Or [+  -- f (g x) --> (f . g) x+  Hard $+  rr  (\f g x -> f `a` (g `a` x))+      (\f g x -> (f `c` g) `a` x),+  -- (>>=) --> flip (=<<)+  Hard $+  rr  bindE+      (flipE `a` extE),+  -- (.) id --> id+  rr (compE `a` idE)+     idE,+  -- (++) [x] --> (:) x+  rr  (\x -> appendE `a` (consE `a` x `a` nilE))+      (\x -> consE `a` x),+  -- (=<<) return --> id+  rr  (extE `a` returnE)+      idE,+  -- (=<<) f (return x) -> f x+  rr  (\f x -> extE `a` f `a` (returnE `a` x))+      (\f x -> f `a` x),+  -- (=<<) ((=<<) f . g) --> (=<<) f . (=<<) g+  rr  (\f g -> extE `a` ((extE `a` f) `c` g))+      (\f g -> (extE `a` f) `c` (extE `a` g)),+  -- flip (f . g) --> flip (.) g . flip f+  Hard $+  rr  (\f g -> flipE `a` (f `c` g))+      (\f g -> (flipE `a` compE `a` g) `c` (flipE `a` f)),+  -- flip (.) f . flip id --> flip f+  rr  (\f -> (flipE `a` compE `a` f) `c` (flipE `a` idE))+      (\f -> flipE `a` f),+  -- flip (.) f . flip flip --> flip (flip . f)+  rr  (\f -> (flipE `a` compE `a` f) `c` (flipE `a` flipE))+      (\f -> flipE `a` (flipE `c` f)),+  -- flip (flip (flip . f) g) --> flip (flip . flip f) g+  rr1 (\f g -> flipE `a` (flipE `a` (flipE `c` f) `a` g))+      (\f g -> flipE `a` (flipE `c` flipE `a` f) `a` g),++  -- flip (.) id --> id+  rr (flipE `a` compE `a` idE)+     idE,+  -- (.) . flip id --> flip flip+  rr  (compE `c` (flipE `a` idE))+      (flipE `a` flipE),+  -- s const x y --> y+  rr  (\x y -> sE `a` constE `a` x `a` y)+      (\_ y -> y),+  -- s (const . f) g --> f+  rr1 (\f g -> sE `a` (constE `c` f) `a` g)+      (\f _ -> f),+  -- s (const f) --> (.) f+  rr  (\f -> sE `a` (constE `a` f))+      (\f -> compE `a` f),+  -- (`ap` f) . const . h --> (. f) . h+  rr  (\f g h -> (flipE `a` sE `a` f) `c` (flipE `a` compE `a` g) `c` constE `c` h)+      (\f _ h -> (flipE `a` compE `a` f) `c` h),+  -- s (f . fst) snd --> uncurry f+  rr  (\f -> sE `a` (f `c` fstE) `a` sndE)+      (\f -> uncurryE `a` f),+  -- fst (join (,) x) --> x+  rr (\x -> fstE `a` (joinE `a` commaE `a` x))+     (\x -> x),+  -- snd (join (,) x) --> x+  rr (\x -> sndE `a` (joinE `a` commaE `a` x))+     (\x -> x),+  -- The next two are `simplifies', strictly speaking, but invoked rarely.+  -- uncurry f (x,y) --> f x y+--  rr  (\f x y -> uncurryE `a` f `a` (commaE `a` x `a` y))+--      (\f x y -> f `a` x `a` y),+  -- curry (uncurry f) --> f+  rr (\f -> curryE `a` (uncurryE `a` f))+     (\f -> f),+  -- uncurry (curry f) --> f+  rr (\f -> uncurryE `a` (curryE `a` f))+     (\f -> f),+  -- (const id . f) --> const id+  rr  (\f -> (constE `a` idE) `c` f)+      (\_ -> constE `a` idE),+  -- const x . f --> const x+  rr (\x f -> constE `a` x `c` f)+     (\x _ -> constE `a` x),+  -- (. f) . const --> const+  rr (\f -> (flipE `a` compE `a` f) `c` constE)+     (\_ -> constE),+  -- (. f) . const . g --> const . g+  rr (\f g -> (flipE `a` compE `a` f) `c` constE `c` g)+     (\_ g -> constE `c` g),+  -- fix f --> f (fix x)+  Hard $+  rr0 (\f -> fixE `a` f)+      (\f -> f `a` (fixE `a` f)),+  -- f (fix f) --> fix x+  Hard $+  rr0 (\f -> f `a` (fixE `a` f))+      (\f -> fixE `a` f),+  -- fix f --> f (f (fix x))+  Hard $+  rr0 (\f -> fixE `a` f)+      (\f -> f `a` (f `a` (fixE `a` f))),+  -- fix (const f) --> f+  rr (\f -> fixE `a` (constE `a` f))+     (\f -> f),+  -- flip const x --> id+  rr  (\x -> flipE `a` constE `a` x)+      (\_ -> idE),+  -- const . f --> flip (const f)+  Hard $+  rr  (\f -> constE `c` f)+      (\f -> flipE `a` (constE `a` f)),+  -- not (x == y) -> x /= y+  rr2 (\x y -> notE `a` (equalsE `a` x `a` y))+      (\x y -> nequalsE `a` x `a` y),+  -- not (x /= y) -> x == y+  rr2 (\x y -> notE `a` (nequalsE `a` x `a` y))+      (\x y -> equalsE `a` x `a` y),+  If (Or [rr plusE plusE, rr minusE minusE, rr multE multE]) $ down $ Or [+    -- 0 + x --> x+    rr  (\x -> plusE `a` zeroE `a` x)+        (\x -> x),+    -- 0 * x --> 0+    rr  (\x -> multE `a` zeroE `a` x)+        (\_ -> zeroE),+    -- 1 * x --> x+    rr  (\x -> multE `a` oneE `a` x)+        (\x -> x),+    -- x - x --> 0+    rr  (\x -> minusE `a` x `a` x)+        (\_ -> zeroE),+    -- x - y + y --> x+    rr  (\y x -> plusE `a` (minusE `a` x `a` y) `a` y)+        (\_ x -> x),+    -- x + y - y --> x+    rr  (\y x -> minusE `a` (plusE `a` x `a` y) `a` y)+        (\_ x -> x),+    -- x + (y - z) --> x + y - z+    rr  (\x y z -> plusE `a` x `a` (minusE `a` y `a` z))+        (\x y z -> minusE `a` (plusE `a` x `a` y) `a` z),+    -- x - (y + z) --> x - y - z+    rr  (\x y z -> minusE `a` x `a` (plusE `a` y `a` z))+        (\x y z -> minusE `a` (minusE `a` x `a` y) `a` z),+    -- x - (y - z) --> x + y - z+    rr  (\x y z -> minusE `a` x `a` (minusE `a` y `a` z))+        (\x y z -> minusE `a` (plusE `a` x `a` y) `a` z)+  ],++  Hard onceRewrites,+  -- join (fmap f x) --> f =<< x+  rr (\f x -> joinE `a` (fmapE `a` f `a` x))+     (\f x -> extE `a` f `a` x),+  -- (=<<) id --> join+  rr (extE `a` idE) joinE,+  -- join --> (=<<) id+  Hard $+  rr joinE (extE `a` idE),+  -- join (return x) --> x+  rr (\x -> joinE `a` (returnE `a` x))+     (\x -> x),+  -- (return . f) =<< m --> fmap f m+  rr (\f m -> extE `a` (returnE `c` f) `a` m)+     (\f m -> fmapIE `a` f `a` m),+  -- (x >>=) . (return .) . f  --> flip (fmap . f) x+  rr (\f x -> bindE `a` x `c` (compE `a` returnE) `c` f)+     (\f x -> flipE `a` (fmapIE `c` f) `a` x),+  -- (>>=) (return f) --> flip id f+  rr (\f -> bindE `a` (returnE `a` f))+     (\f -> flipE `a` idE `a` f),+  -- liftM2 f x --> ap (f `fmap` x)+  Hard $+  rr (\f x -> liftM2E `a` f `a` x)+     (\f x -> apE `a` (fmapIE `a` f `a` x)),+  -- liftM2 f (return x) --> fmap (f x)+  rr (\f x -> liftM2E `a` f `a` (returnE `a` x))+     (\f x -> fmapIE `a` (f `a` x)),+  -- f `fmap` return x --> return (f x)+  rr (\f x -> fmapE `a` f `a` (returnE `a` x))+     (\f x -> returnE `a` (f `a` x)),+  -- (=<<) . flip (fmap . f) --> flip liftM2 f+  Hard $+  rr (\f -> extE `c` flipE `a` (fmapE `c` f))+     (\f -> flipE `a` liftM2E `a` f),++  -- (.) -> fmap+  Hard $+  rr compE fmapE,++  -- map f (zip xs ys) --> zipWith (curry f) xs ys+  Hard $+  rr (\f xs ys -> mapE `a` f `a` (zipE `a` xs `a` ys))+     (\f xs ys -> zipWithE `a` (curryE `a` f) `a` xs `a` ys),+  -- zipWith (,) --> zip (,)+  rr (zipWithE `a` commaE) zipE,++  -- all f --> and . map f+  Hard $+  rr (\f -> allE `a` f)+     (\f -> andE `c` mapE `a` f),+  -- and . map f --> all f+  rr (\f -> andE `c` mapE `a` f)+     (\f -> allE `a` f),+  -- any f --> or . map f+  Hard $+  rr (\f -> anyE `a` f)+     (\f -> orE `c` mapE `a` f),+  -- or . map f --> any f+  rr (\f -> orE `c` mapE `a` f)+     (\f -> anyE `a` f),++  -- return f `ap` x --> fmap f x+  rr (\f x -> apE `a` (returnE `a` f) `a` x)+     (\f x -> fmapIE `a` f `a` x),+  -- ap (f `fmap` x) --> liftM2 f x+  rr (\f x -> apE `a` (fmapIE `a` f `a` x))+     (\f x -> liftM2E `a` f `a` x),+  -- f `ap` x --> (`fmap` x) =<< f+  Hard $+  rr (\f x -> apE `a` f `a` x)+     (\f x -> extE `a` (flipE `a` fmapIE `a` x) `a` f),+  -- (`fmap` x) =<< f --> f `ap` x+  rr (\f x -> extE `a` (flipE `a` fmapIE `a` x) `a` f)+     (\f x -> apE `a` f `a` x),+  -- (x >>=) . flip (fmap . f) -> liftM2 f x+  rr (\f x -> bindE `a` x `c` flipE `a` (fmapE `c` f))+     (\f x -> liftM2E `a` f `a` x),++  -- (f =<< m) x --> f (m x) x+  rr0 (\f m x -> extE `a` f `a` m `a` x)+      (\f m x -> f `a` (m `a` x) `a` x),+  -- (fmap f g x) --> f (g x)+  rr0 (\f g x -> fmapE `a` f `a` g `a` x)+      (\f g x -> f `a` (g `a` x)),+  -- return x y --> y+  rr  (\y x -> returnE `a` x `a` y)+      (\y _ -> y),+  -- liftM2 f g h x --> g x `h` h x+  rr0 (\f g h x -> liftM2E `a` f `a` g `a` h `a` x)+      (\f g h x -> f `a` (g `a` x) `a` (h `a` x)),+  -- ap f id --> join f+  rr  (\f -> apE `a` f `a` idE)+      (\f -> joinE `a` f),++  -- (=<<) const q --> flip (>>) q+  Hard $ -- ??+  rr (\q p -> extE `a` (constE `a` q) `a` p)+     (\q p -> seqME `a` p `a` q),+  -- p >> q --> const q =<< p+  Hard $+  rr (\p q -> seqME `a` p `a` q)+     (\p q -> extE `a` (constE `a` q) `a` p),++  -- experimental support for Control.Arrow stuff+  -- (costs quite a bit of performace)+  -- uncurry ((. g) . (,) . f) --> f *** g+  rr (\f g -> uncurryE `a` ((flipE `a` compE `a` g) `c` commaE `c` f))+     (\f g -> crossE `a` f `a` g),+  -- uncurry ((,) . f) --> first f+  rr (\f -> uncurryE `a` (commaE `c` f))+     (\f -> firstE `a` f),+  -- uncurry ((. g) . (,)) --> second g+  rr (\g -> uncurryE `a` ((flipE `a` compE `a` g) `c` commaE))+     (\g -> secondE `a` g),+  -- I think we need all three of them:+  -- uncurry (const f) --> f . snd+  rr (\f -> uncurryE `a` (constE `a` f))+     (\f -> f `c` sndE),+  -- uncurry const --> fst+  rr (uncurryE `a` constE)+     (fstE),+  -- uncurry (const . f) --> f . fst+  rr (\f -> uncurryE `a` (constE `c` f))+     (\f -> f `c` fstE),++  -- TODO is this the right place?+  -- [x] --> return x+  Hard $+  rr (\x -> consE `a` x `a` nilE)+     (\x -> returnE `a` x),+  -- list destructors+  Hard $+  If (Or [rr consE consE, rr nilE nilE]) $ Or [+    down $ Or [+      -- length [] --> 0+      rr (lengthE `a` nilE)+         zeroE,+      -- length (x:xs) --> 1 + length xs+      rr (\x xs -> lengthE `a` (consE `a` x `a` xs))+         (\_ xs -> plusE `a` oneE `a` (lengthE `a` xs))+    ],+    -- map/fmap elimination+    down $ Or [+      -- map f (x:xs) --> f x: map f xs+      rr (\f x xs -> mapE `a` f `a` (consE `a` x `a` xs))+         (\f x xs -> consE `a` (f `a` x) `a` (mapE `a` f `a` xs)),+      -- fmap f (x:xs) --> f x: Fmap f xs+      rr (\f x xs -> fmapE `a` f `a` (consE `a` x `a` xs))+         (\f x xs -> consE `a` (f `a` x) `a` (fmapE `a` f `a` xs)),+      -- map f []     --> []+      rr (\f -> mapE `a` f `a` nilE)+         (\_ -> nilE),+      -- fmap f []     --> []+      rr (\f -> fmapE `a` f `a` nilE)+         (\_ -> nilE)+    ],+    -- foldr elimination+    down $ Or [+      -- foldr f z (x:xs) --> f x (foldr f z xs)+      rr (\f x xs z -> (foldrE `a` f `a` z) `a` (consE `a` x `a` xs))+         (\f x xs z -> (f `a` x) `a` (foldrE `a` f `a` z `a` xs)),+      -- foldr f z [] --> z+      rr (\f z -> foldrE `a` f `a` z `a` nilE)+         (\_ z -> z)+    ],+    -- foldl elimination+    down $ Opt (CRR $ assocL ["."]) `Then` Or [+      -- sum xs --> foldl (+) 0 xs+      rr (\xs -> sumE `a` xs)+         (\xs -> foldlE `a` plusE `a` zeroE `a` xs),+      -- product xs --> foldl (*) 1 xs+      rr (\xs -> productE `a` xs)+         (\xs -> foldlE `a` multE `a` oneE `a` xs),+      -- foldl1 f (x:xs) --> foldl f x xs+      rr (\f x xs -> foldl1E `a` f `a` (consE `a` x `a` xs))+         (\f x xs -> foldlE `a` f `a` x `a` xs),+      -- foldl f z (x:xs) --> foldl f (f z x) xs+      rr (\f z x xs -> (foldlE `a` f `a` z) `a` (consE `a` x `a` xs))+         (\f z x xs -> foldlE `a` f `a` (f `a` z `a` x) `a` xs),+      -- foldl f z [] --> z+      rr (\f z -> foldlE `a` f `a` z `a` nilE)+         (\_ z -> z),+      -- special rule:+      -- foldl f z [x] --> f z x+      rr (\f z x -> foldlE `a` f `a` z `a` (returnE `a` x))+         (\f z x -> f `a` z `a` x),+      rr (\f z x -> foldlE `a` f `a` z `a` (consE `a` x `a` nilE))+         (\f z x -> f `a` z `a` x)+    ] `OrElse` (+      -- (:) x --> (++) [x]+      Opt (rr0 (\x -> consE `a` x)+         (\x -> appendE `a` (consE `a` x `a` nilE))) `Then`+      -- More special rule: (:) x . (++) ys --> (++) (x:ys)+      up (rr0 (\x ys -> (consE `a` x) `c` (appendE `a` ys))+         (\x ys -> appendE `a` (consE `a` x `a` ys)))+      )+  ],++  -- Complicated Transformations+  CRR (collapseLists),+  up $ Or [CRR (evalUnary unaryBuiltins), CRR (evalBinary binaryBuiltins)],+  up $ CRR (assoc assocOps),+  up $ CRR (assocL assocOps),+  up $ CRR (assocR assocOps),+  Up (CRR (commutative commutativeOps)) $ down $ Or [CRR $ assocL assocLOps,+                                                     CRR $ assocR assocROps],++  Hard $ simplifies+  ] `Then` Opt (up simplifies)++----------------------------------------------------------------------------------------+-- Operator information++assocLOps, assocROps, assocOps :: [String]+assocLOps = ["+", "*", "&&", "||", "max", "min"]+assocROps = [".", "++"]+assocOps  = assocLOps ++ assocROps++commutativeOps :: [String]+commutativeOps = ["*", "+", "==", "/=", "max", "min"]++unaryBuiltins :: [(String,Unary)]+unaryBuiltins = [+    ("not",    UA (not    :: Bool -> Bool)),+    ("negate", UA (negate :: Integer -> Integer)),+    ("signum", UA (signum :: Integer -> Integer)),+    ("abs",    UA (abs    :: Integer -> Integer))+  ]++binaryBuiltins :: [(String,Binary)]+binaryBuiltins = [+    ("+",    BA ((+)  :: Integer -> Integer -> Integer)),+    ("-",    BA ((-)  :: Integer -> Integer -> Integer)),+    ("*",    BA ((*)  :: Integer -> Integer -> Integer)),+    ("^",    BA ((^)  :: Integer -> Integer -> Integer)),+    ("<",    BA ((<)  :: Integer -> Integer -> Bool)),+    (">",    BA ((>)  :: Integer -> Integer -> Bool)),+    ("==",   BA ((==) :: Integer -> Integer -> Bool)),+    ("/=",   BA ((/=) :: Integer -> Integer -> Bool)),+    ("<=",   BA ((<=) :: Integer -> Integer -> Bool)),+    (">=",   BA ((>=) :: Integer -> Integer -> Bool)),+    ("div",  BA (div  :: Integer -> Integer -> Integer)),+    ("mod",  BA (mod  :: Integer -> Integer -> Integer)),+    ("max",  BA (max  :: Integer -> Integer -> Integer)),+    ("min",  BA (min  :: Integer -> Integer -> Integer)),+    ("&&",   BA ((&&) :: Bool -> Bool -> Bool)),+    ("||",   BA ((||) :: Bool -> Bool -> Bool))+  ]
+ src/Lambdabot/Plugin/Pl/Transform.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE PatternGuards #-}+module Lambdabot.Plugin.Pl.Transform (+    transform,+  ) where++import Lambdabot.Plugin.Pl.Common++import qualified Data.Map as M++import Data.Graph (stronglyConnComp, flattenSCC, flattenSCCs)+import Control.Monad.State++-- | Does a name occur in a pattern?+occursP :: String -> Pattern -> Bool+occursP v (PVar v') = v == v'+occursP v (PTuple p1 p2) = v `occursP` p1 || v `occursP` p2+occursP v (PCons  p1 p2) = v `occursP` p1 || v `occursP` p2++-- | How often does the given name occur free in an expression?+freeIn :: String -> Expr -> Int+freeIn v (Var _ v') = fromEnum $ v == v'+freeIn v (Lambda pat e) = if v `occursP` pat then 0 else freeIn v e+freeIn v (App e1 e2) = freeIn v e1 + freeIn v e2+freeIn v (Let ds e') = if v `elem` map declName ds then 0+  else freeIn v e' + sum [freeIn v e | Define _ e <- ds]++-- | Does a name occur free in an expression?+isFreeIn :: String -> Expr -> Bool+isFreeIn v e = freeIn v e > 0++tuple :: [Expr] -> Expr+tuple es  = foldr1 (\x y -> Var Inf "," `App` x `App` y) es++tupleP :: [String] -> Pattern+tupleP vs = foldr1 PTuple $ PVar `map` vs++-- | The subset of ds that d depends on+dependsOn :: [Decl] -> Decl -> [Decl]+dependsOn ds d = [d' | d' <- ds, declName d' `isFreeIn` declExpr d]++-- | Convert recursive lets to lambdas with tuple patterns and fix calls+unLet :: Expr -> Expr+unLet (App e1 e2) = App (unLet e1) (unLet e2)+unLet (Let [] e) = unLet e+unLet (Let ds e) = unLet $+  (Lambda (tupleP $ declName `map` dsYes) (Let dsNo e)) `App`+    (fix' `App` (Lambda (tupleP $ declName `map` dsYes)+                        (tuple  $ declExpr `map` dsYes)))+    where+  comps = stronglyConnComp [(d',d',dependsOn ds d') | d' <- ds]+  dsYes = flattenSCC $ head comps+  dsNo = flattenSCCs $ tail comps++unLet (Lambda v e) = Lambda v (unLet e)+unLet (Var f x) = Var f x++type Env = M.Map String String++-- | Rename all variables to (locally) unqiue fresh ones+--+-- It's a pity we still need that for the pointless transformation.+-- Otherwise a newly created id/const/... could be bound by a lambda+-- e.g. transform' (\id x -> x) ==> transform' (\id -> id) ==> id+alphaRename :: Expr -> Expr+alphaRename e = alpha e `evalState` M.empty where+  alpha :: Expr -> State Env Expr+  alpha (Var f v)     = do fm <- get; return $ Var f $ maybe v id (M.lookup v fm)+  alpha (App e1 e2)   = liftM2 App (alpha e1) (alpha e2)+  alpha (Let _ _)     = assert False undefined+  alpha (Lambda v e') = inEnv $ liftM2 Lambda (alphaPat v) (alpha e')++  -- act like a reader monad+  inEnv :: State s a -> State s a+  inEnv f = state $ \s -> (fst $ runState f s, s)++  alphaPat (PVar v) = do+    fm <- get+    let v' = "$" ++ show (M.size fm)+    put $ M.insert v v' fm+    return $ PVar v'+  alphaPat (PTuple p1 p2) = liftM2 PTuple (alphaPat p1) (alphaPat p2)+  alphaPat (PCons  p1 p2) = liftM2 PCons  (alphaPat p1) (alphaPat p2)++-- | Make an expression points free+transform :: Expr -> Expr+transform = transform' . alphaRename . unLet++-- | Transform patterns to:+--     fst/snd for tuple patterns+--     head/tail for cons patterns+--     id/const/flip/. for variable paterns+transform' :: Expr -> Expr+transform' (Let {}) = assert False undefined+transform' (Var f v) = Var f v+transform' (App e1 e2) = App (transform' e1) (transform' e2)+transform' (Lambda (PTuple p1 p2) e)+  = transform' $ Lambda (PVar "z") $+      (Lambda p1 $ Lambda p2 $ e) `App` f `App` s where+    f = Var Pref "fst" `App` Var Pref "z"+    s = Var Pref "snd" `App` Var Pref "z"+transform' (Lambda (PCons p1 p2) e)+  = transform' $ Lambda (PVar "z") $+      (Lambda p1 $ Lambda p2 $ e) `App` f `App` s where+    f = Var Pref "head" `App` Var Pref "z"+    s = Var Pref "tail" `App` Var Pref "z"+transform' (Lambda (PVar v) e) = transform' $ getRidOfV e where+  getRidOfV (Var f v') | v == v'   = id'+                       | otherwise = const' `App` Var f v'+  getRidOfV l@(Lambda pat _) = assert (not $ v `occursP` pat) $+    getRidOfV $ transform' l+  getRidOfV (Let {}) = assert False bt+  getRidOfV e'@(App e1 e2)+    | fr1 && fr2 = scomb `App` getRidOfV e1 `App` getRidOfV e2+    | fr1 = flip' `App` getRidOfV e1 `App` e2+    | Var _ v' <- e2, v' == v = e1+    | fr2 = comp `App` e1 `App` getRidOfV e2+    | True = const' `App` e'+    where+      fr1 = v `isFreeIn` e1+      fr2 = v `isFreeIn` e2
+ src/Lambdabot/Plugin/Pointful.hs view
@@ -0,0 +1,232 @@+-- Undo pointfree transformations. Plugin code derived from Pl.hs.+module Lambdabot.Plugin.Pointful (theModule) where++import Lambdabot.Module as Lmb (Module)+import Lambdabot.Plugin+import Lambdabot.Util.Parser (withParsed)++import Control.Monad.State+import Data.Functor.Identity (Identity)+import Data.Generics+import qualified Data.Map as M+import Data.Maybe+import Language.Haskell.Exts as Hs++theModule :: Lmb.Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "pointful")+            { aliases = ["pointy","repoint","unpointless","unpl","unpf"]+            , help = say "pointful <expr>. Make code pointier."+            , process = mapM_ say . lines . pointful+            }+        ]+    }++---- Utilities ----++extT' :: (Typeable a, Typeable b) => (a -> a) -> (b -> b) -> a -> a+extT' = extT+infixl `extT'`++unkLoc :: SrcLoc+unkLoc = SrcLoc "<new>" 1 1++stabilize :: Eq a => (a -> a) -> a -> a+stabilize f x = let x' = f x in if x' == x then x else stabilize f x'++namesIn :: Data a => a -> [Name]+namesIn h = everything (++) (mkQ [] (\x -> case x of UnQual name' -> [name']; _ -> [])) h++pVarsIn :: Data a => a -> [Name]+pVarsIn h = everything (++) (mkQ [] (\x -> case x of PVar name' -> [name']; _ -> [])) h++succName :: Name -> Name+succName (Ident s) = Ident . reverse . succAlpha . reverse $ s+succName (Symbol _ ) = error "Pointful plugin error: cannot determine successor for a Symbol"++succAlpha :: String -> String+succAlpha ('z':xs) = 'a' : succAlpha xs+succAlpha (x  :xs) = succ x : xs+succAlpha []       = "a"++---- Optimization (removing explicit lambdas) and restoration of infix ops ----++-- move lambda patterns into LHS+optimizeD :: Decl -> Decl+optimizeD (PatBind locat (PVar fname) Nothing (UnGuardedRhs (Lambda _ pats rhs)) (BDecls []))+        =  FunBind [Match locat fname pats Nothing (UnGuardedRhs rhs) (BDecls [])]+---- combine function binding and lambda+optimizeD (FunBind [Match locat fname pats1 Nothing (UnGuardedRhs (Lambda _ pats2 rhs)) (BDecls [])])+        =  FunBind [Match locat fname (pats1 ++ pats2) Nothing (UnGuardedRhs rhs) (BDecls [])]+optimizeD x = x++-- remove parens+optimizeRhs :: Rhs -> Rhs+optimizeRhs (UnGuardedRhs (Paren x))+          =  UnGuardedRhs x+optimizeRhs x = x++optimizeE :: Exp -> Exp+-- apply ((\x z -> ...x...) y) yielding (\z -> ...y...) if there is only one x or y is simple+  -- TODO: avoid captures while substituting+optimizeE (App (Paren (Lambda locat (PVar ident : pats) body)) arg) | single || simple arg+        = Paren (Lambda locat pats (everywhere (mkT (\x -> if x == (Var (UnQual ident)) then arg else x)) body))+  where single = gcount (mkQ False (== ident)) body <= 1+        simple e = case e of Var _ -> True; Lit _ -> True; Paren e' -> simple e'; _ -> False+-- apply ((\_ z -> ...) y) yielding (\z -> ...)+optimizeE (App (Paren (Lambda locat (PWildCard : pats) body)) _)+        = Paren (Lambda locat pats body)+-- remove 0-arg lambdas resulting from application rules+optimizeE (Lambda _ [] b)+        = b+-- replace (\x -> \y -> z) with (\x y -> z)+optimizeE (Lambda locat p1 (Lambda _ p2 body))+        = Lambda locat (p1 ++ p2) body+-- remove double parens+optimizeE (Paren (Paren x))+        = Paren x+-- remove lambda body parens+optimizeE (Lambda l p (Paren x))+        = Lambda l p x+-- remove var, lit parens+optimizeE (Paren x@(Var _))+        = x+optimizeE (Paren x@(Lit _))+        = x+-- remove infix+lambda parens+optimizeE (InfixApp a o (Paren l@(Lambda _ _ _)))+        = InfixApp a o l+-- remove left-assoc application parens+optimizeE (App (Paren (App a b)) c)+        = App (App a b) c+-- restore infix+optimizeE (App (App (Var name'@(UnQual (Symbol _))) l) r)+        = (InfixApp l (QVarOp name') r)+-- eta reduce+optimizeE (Lambda l ps@(_:_) (App e (Var (UnQual v))))+  | free && last ps == PVar v+        = Lambda l (init ps) e+  where free = gcount (mkQ False (== v)) e == 0+-- fail+optimizeE x = x++---- Decombinatorization ----++-- fresh name generation. TODO: prettify this+fresh :: StateT (Name, [Name]) Identity Name+fresh = do (_,    used) <- get+           modify (\(v,u) -> (until (not . (`elem` used)) succName (succName v), u))+           (name', _) <- get+           return name'++-- rename all lambda-bound variables. TODO: rewrite lets as well+rename :: Exp -> StateT (Name, [Name]) Identity  Exp+rename = do everywhereM (mkM (\e -> case e of+              (Lambda _ ps _) -> do+                let pVars = concatMap pVarsIn ps+                newVars <- mapM (const fresh) pVars+                let replacements = zip pVars newVars+                return (everywhere (mkT (\n -> fromMaybe n (lookup n replacements))) e)+              _ -> return e))++uncomb' :: Exp -> State (Name, [Name]) Exp++uncomb' (Paren (Paren e)) = return (Paren e)++-- expand plain combinators+uncomb' (Var qname) | isJust maybeDef = rename (fromJust maybeDef)+  where maybeDef = M.lookup qname combinators++-- eliminate sections+uncomb' (RightSection op' arg)+  = do a <- fresh+       return (Paren (Lambda unkLoc [PVar a] (InfixApp (Var (UnQual a)) op' arg)))+uncomb' (LeftSection arg op')+  = do a <- fresh+       return (Paren (Lambda unkLoc [PVar a] (InfixApp arg op' (Var (UnQual a)))))+-- infix to prefix for canonicality+uncomb' (InfixApp lf (QVarOp name') rf)+  = return (Paren (App (App (Var name') (Paren lf)) (Paren rf)))++-- Expand (>>=) when it is obviously the reader monad:++-- rewrite: (>>=) (\x -> e)+-- to:      (\ a b -> a ((\ x -> e) b) b)+uncomb' (App (Var (UnQual (Symbol ">>="))) (Paren lam@Lambda{}))+  = do a <- fresh+       b <- fresh+       return (Paren (Lambda unkLoc [PVar a, PVar b]+                 (App (App (Var (UnQual a)) (Paren (App lam (Var (UnQual b))))) (Var (UnQual b)))))+-- rewrite: ((>>=) e1) (\x y -> e2)+-- to:      (\a -> (\x y -> e2) (e1 a) a)+uncomb' (App (App (Var (UnQual (Symbol ">>="))) e1) (Paren lam@(Lambda _ (_:_:_) _)))+  = do a <- fresh+       return (Paren (Lambda unkLoc [PVar a]+                (App (App lam (App e1 (Var (UnQual a)))) (Var (UnQual a)))))++-- fail+uncomb' expr = return expr++---- Simple combinator definitions ---+combinators :: M.Map QName Exp+combinators = M.fromList $ map declToTuple defs+  where defs = case parseModule combinatorModule of+          ParseOk (Hs.Module _ _ _ _ _ _ d) -> d+          f@(ParseFailed _ _) -> error ("Combinator loading: " ++ show f)+        declToTuple (PatBind _ (PVar fname) _ (UnGuardedRhs body) (BDecls []))+          = (UnQual fname, Paren body)+        declToTuple _ = error "Pointful Plugin error: can't convert declaration to tuple"++-- the names we recognize as combinators, so we don't generate them as temporaries then substitute them.+-- TODO: more generally correct would be to not substitute any variable which is bound by a pattern+recognizedNames :: [Name]+recognizedNames = map (\(UnQual n) -> n) $ M.keys combinators++combinatorModule :: String+combinatorModule = unlines [+  "(.)    = \\f g x -> f (g x)                                          ",+  "($)    = \\f x   -> f x                                              ",+  "flip   = \\f x y -> f y x                                            ",+  "const  = \\x _ -> x                                                  ",+  "id     = \\x -> x                                                    ",+  "(=<<)  = flip (>>=)                                                  ",+  "liftM2 = \\f m1 m2 -> m1 >>= \\x1 -> m2 >>= \\x2 -> return (f x1 x2) ",+  "join   = (>>= id)                                                    ",+  "ap     = liftM2 id                                                   ",+  "(>=>)  = flip (<=<)                                                  ",+  "(<=<)  = \\f g x -> f >>= g x                                        ",+  "                                                                     ",+  "-- ASSUMED reader monad                                              ",+  "-- (>>=)  = (\\f k r -> k (f r) r)                                   ",+  "-- return = const                                                    ",+  ""]++---- Top level ----++uncombOnce :: (Data a) => a -> a+uncombOnce x = evalState (everywhereM (mkM uncomb') x) (Ident "`", namesIn x ++ recognizedNames)+uncomb :: (Eq a, Data a) => a -> a+uncomb = stabilize uncombOnce++optimizeOnce :: (Data a) => a -> a+optimizeOnce x = everywhere (mkT optimizeD `extT'` optimizeRhs `extT'` optimizeE) x+optimize :: (Eq a, Data a) => a -> a+optimize = stabilize optimizeOnce++pointful :: String -> String+pointful = withParsed (stabilize (optimize . uncomb))++-- TODO: merge this into a proper test suite once one exists+-- test s = case parseModule s of+--   f@(ParseFailed _ _) -> fail (show f)+--   ParseOk (Hs.Module _ _ _ _ _ _ defs) ->+--     flip mapM_ defs $ \def -> do+--       putStrLn . prettyPrintInLine  $ def+--       putStrLn . prettyPrintInLine  . uncomb $ def+--       putStrLn . prettyPrintInLine  . optimize . uncomb $ def+--       putStrLn . prettyPrintInLine  . stabilize (optimize . uncomb) $ def+--       putStrLn ""+--+-- main = test "f = tail . head; g = head . tail; h = tail + tail; three = g . h . i; dontSub = (\\x -> x + x) 1; ofHead f = f . head; fm = flip mapM_ xs (\\x -> g x); po = (+1); op = (1+); g = (. f); stabilize = fix (ap . flip (ap . (flip =<< (if' .) . (==))) =<<)"+--
+ src/Lambdabot/Plugin/Poll.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE TypeFamilies #-}+-- | Module: Vote+-- | Support for voting+-- |+-- | License: lGPL+-- |+-- | added by Kenneth Hoste (boegel), 22/11/2005+-- |  inspiration: Where plugin (thanks shapr,dons)+module Lambdabot.Plugin.Poll (theModule) where++import Lambdabot.Plugin+import qualified Data.ByteString.Char8 as P+import Data.List+import qualified Data.Map as M++newPoll :: Poll+newPoll = (True,[])++appendPoll :: String -> Poll -> (Maybe Poll)+appendPoll choice (o,ls) = Just (o,(choice,0):ls)++voteOnPoll :: Poll -> String -> (Poll,String)+voteOnPoll (o,poll) choice =+    if any (\(x,_) -> x == choice) poll+        then ((o,map (\(c,n) ->+                    if c == choice then (c,n+1)+                                   else (c,n)) poll)+                                        ,"voted on " ++ show choice)+        else ((o,poll),show choice ++ " is not currently a candidate in this poll")++------------------------------------------------------------------------++type Count             = Int+type Candidate         = String+type PollName          = P.ByteString+type Poll              = (Bool, [(Candidate, Count)])+type VoteState         = M.Map PollName Poll+type VoteWriter        = VoteState -> Cmd Vote ()+type Vote              = ModuleT VoteState LB++------------------------------------------------------------------------+-- Define a serialiser++voteSerial :: Serial VoteState+voteSerial = Serial (Just . showPacked) (Just . readPacked)++------------------------------------------------------------------------++theModule :: Module (M.Map PollName Poll)+theModule = newModule+    { moduleCmds = return+        [ (command "poll-list")+            { help = say "poll-list                   Shows all current polls"+            , process = \_ -> do+                result <- withMS $ \factFM writer -> processCommand factFM writer "poll-list" []+                say result+            }+        , (command "poll-show")+            { help = say "poll-show <poll>            Shows all choices for some poll"+            , process = process_ "poll-show"+            }+        , (command "poll-add")+            { help = say "poll-add <name>             Adds a new poll, with no candidates"+            , process = process_ "poll-add"+            }+        , (command "choice-add")+            { help = say "choice-add <poll> <choice>  Adds a new choice to the given poll"+            , process = process_ "choice-add"+            }+        , (command "vote")+            -- todo, should @vote foo automagically add foo as a possibility?+            { help = say "vote <poll> <choice>        Vote for <choice> in <poll>"+            , process = process_ "vote"+            }+        , (command "poll-result")+            { help = say "poll-result <poll>          Show result for given poll"+            , process = process_ "poll-result"+            }+        , (command "poll-close")+            { help = say "poll-close <poll>           Closes a poll"+            , process = process_ "poll-close"+            }+        , (command "poll-remove")+            { help = say "poll-remove <poll>          Removes a poll"+            , process = process_ "poll-remove"+            }+        ]++    , moduleDefState  = return M.empty+    , moduleSerialize = Just voteSerial+    }++process_ :: [Char] -> [Char] -> Cmd Vote ()+process_ cmd [] = say ("Missing argument. Check @help " ++ cmd ++ " for info.")+process_ cmd dat = do+    result <- withMS $ \fm writer -> processCommand fm writer cmd (words dat)+    say result++------------------------------------------------------------------------++processCommand :: VoteState -> VoteWriter -> String -> [String] -> Cmd Vote String+processCommand fm writer cmd dat = case cmd of++    -- show all current polls+    "poll-list"  -> return $ listPolls fm++    -- show candidates+    "poll-show"    -> return $ case length dat of+                        1 -> showPoll fm (head dat)+                        _ -> "usage: @poll-show <poll>"++    -- declare a new poll+    "poll-add"     -> case length dat of+                        1 -> addPoll fm writer (head dat)+                        _ -> return "usage: @poll-add <poll>   with \"ThisTopic\" style names"++    "choice-add"   -> case length dat of+                        2 -> addChoice fm writer (head dat) (last dat)+                        _ -> return "usage: @choice-add <poll> <choice>"++    "vote"          -> case length dat of+                        2 -> vote fm writer (head dat) (last dat)+                        _ -> return "usage: @vote <poll> <choice>"++    "poll-result"   -> return $ case length dat of+                        1 -> showResult fm (head dat)+                        _ -> "usage: @poll-result <poll>"++    "poll-close"    -> case length dat of+                        1 -> closePoll fm writer (head dat)+                        _ -> return "usage: @poll-close <poll>"++    "poll-remove"   -> case length dat of+                        1 -> removePoll fm writer (head dat)+                        _ -> return "usage: @poll-remove <poll>"++    _ -> return "Unknown command."++------------------------------------------------------------------------++listPolls :: VoteState -> String+listPolls fm = show $ map fst (M.toList fm)++showPoll :: VoteState -> String -> String+showPoll fm poll =+    case M.lookup (P.pack poll) fm of+        Nothing -> "No such poll: " ++ show poll ++ " Use @poll-list to see the available polls."+        Just p  -> show $ map fst (snd p)++addPoll :: VoteState -> VoteWriter -> String -> Cmd Vote String+addPoll fm writer poll =+    case M.lookup (P.pack poll) fm of+        Nothing -> do writer $ M.insert (P.pack poll) newPoll fm+                      return $ "Added new poll: " ++ show poll+        Just _  -> return $ "Poll " ++ show poll +++                            " already exists, choose another name for your poll"++addChoice :: VoteState -> VoteWriter -> String -> String -> Cmd Vote String+addChoice fm writer poll choice = case M.lookup (P.pack poll) fm of+    Nothing -> return $ "No such poll: " ++ show poll+    Just _  -> do writer $ M.update (appendPoll choice) (P.pack poll) fm+                  return $ "New candidate " ++ show choice +++                           ", added to poll " ++ show poll ++ "."++vote :: VoteState -> VoteWriter -> String -> String -> Cmd Vote String+vote fm writer poll choice = case M.lookup (P.pack poll) fm of+    Nothing          -> return $ "No such poll:" ++ show poll+    Just (False,_)   -> return $ "The "++ show poll ++ " poll is closed, sorry !"+    Just p@(True,_)  -> do let (np,msg) = voteOnPoll p choice+                           writer $ M.update (const (Just np)) (P.pack poll) fm+                           return msg++showResult :: VoteState -> String -> String+showResult fm poll = case M.lookup (P.pack poll) fm of+    Nothing     -> "No such poll: "  ++ show poll+    Just (o,p)  -> "Poll results for " ++ poll ++ " (" ++ (status o) ++ "): "+                   ++ (concat $ intersperse ", " $ map ppr p)+        where+            status s | s         = "Open"+                     | otherwise = "Closed"+            ppr (x,y) = x ++ "=" ++ show y++removePoll :: VoteState -> VoteWriter -> String -> Cmd Vote String+removePoll fm writer poll = case M.lookup (P.pack poll) fm of+    Just (True,_)  -> return "Poll should be closed before you can remove it."+    Just (False,_) -> do writer $ M.delete (P.pack poll) fm+                         return $ "poll " ++ show poll ++ " removed."+    Nothing        -> return $ "No such poll: " ++ show poll++closePoll :: VoteState -> VoteWriter -> String -> Cmd Vote String+closePoll fm writer poll = case M.lookup (P.pack poll) fm of+    Nothing     -> return $ "No such poll: " ++ show poll+    Just (_,p)  -> do writer $ M.update (const (Just (False,p))) (P.pack poll) fm+                      return $ "Poll " ++ show poll ++ " closed."
+ src/Lambdabot/Plugin/Pretty.hs view
@@ -0,0 +1,83 @@+{- | Pretty-Printing echo++example:++> @pretty fun x = case x of {3 -> "hello" ; 5 -> "world" ; _ -> "else"}++> fun x+>  = case x of+>   3 -> "hello"+>   5 -> "world"+>   _ -> "else"++(c) Johannes Ahlmann, 2005-12-13, released under GPL 2 -}++module Lambdabot.Plugin.Pretty (theModule) where++import Lambdabot.Plugin++import Data.List+import qualified Language.Haskell.Exts as Hs+import Language.Haskell.Exts hiding (Module, Pretty)++type Pretty = ModuleT () LB++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "pretty")+            { help = say "pretty <expr>. Display haskell code in a pretty-printed manner"+            , process = prettyCmd+            }+        ]+    }++------------------------------------------------------------------------++prettyCmd :: String -> Cmd Pretty ()+prettyCmd rest =+    let code = dropWhile (`elem` " \t>") rest+        modPrefix1 = "module Main where "+        modPrefix2 = "module Main where __expr__ = "+        prefLen1 = length modPrefix1+        result = case (parseModule (modPrefix1 ++ code ++ "\n"), parseModule (modPrefix2 ++ code ++ "\n"))  of+            (ParseOk a, _)            -> doPretty a+            (_, ParseOk a)            -> doPretty a+            (ParseFailed locat msg,_) -> let (SrcLoc _ _ col) = locat in+                   (show msg ++ " at column " ++ show (col - prefLen1)) : []+    in mapM_ say result -- XXX will this work? No, spaces are compressed.++-- | calculates "desired" indentation and return pretty-printed declarations+-- the indentation calculations are still pretty much rough guesswork.+-- i'll have to figure out a way to do some _reliable_ pretty-printing!+doPretty :: Hs.Module -> [String]+doPretty (Hs.Module _ _ _ _ _ _ decls) =+    let defaultLen = 4+        declLen (FunBind mtches)   = maximum $ map matchLen mtches+        declLen (PatBind _ pat _ _ _) = patLen pat+        declLen _  = defaultLen+        patLen (PVar nm) = nameLen nm+        patLen  _  = defaultLen+        nameLen (Ident s)  = length s + 1+        nameLen _  = defaultLen+        matchLen (Match _ nm pats _ _ _) =+            let l = (nameLen nm + sum (map patLen pats) + 1)+            in if l > 16 then defaultLen else l+        makeMode decl = defaultMode {+            doIndent     = 3,+            caseIndent   = 4,+            onsideIndent = declLen decl+        }+        makeModeExp _ = defaultMode {+            doIndent     = 3,+            caseIndent   = 4,+            onsideIndent = 0+        }+        prettyDecl (PatBind _ (PVar (Ident "__expr__")) _ (UnGuardedRhs e) (BDecls [])) -- pretty printing an expression+                     = prettyPrintWithMode (makeModeExp e) e+        prettyDecl d = prettyPrintWithMode (makeMode d) d+    -- TODO: prefixing with hashes is done, because i didn't find a way+    --   to disable the indentation filter of lambdabot only for this module...+    in map (" "++) . lines . concat . intersperse "\n"+       -- . map show $ decls+       . map prettyDecl $ decls
+ src/Lambdabot/Plugin/Quote.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE CPP, PatternGuards #-}+-- | Support for quotes+module Lambdabot.Plugin.Quote (theModule) where++import Lambdabot.Plugin++import qualified Data.ByteString.Char8 as P+import Data.Char+import Data.Fortune+import Data.List+import qualified Data.Map as M+import Data.Maybe+import Text.Regex.TDFA++type Key    = P.ByteString+type Quotes = M.Map Key [P.ByteString]+type Quote  = ModuleT Quotes LB++theModule :: Module (M.Map P.ByteString [P.ByteString])+theModule = newModule+    { moduleSerialize = Just mapListPackedSerial+    , moduleDefState  = return M.empty+    , moduleInit      = modifyMS (M.filter (not . null))++    , moduleCmds = return+        [ (command "quote")+            { help = say "quote <nick>: Quote <nick> or a random person if no nick is given"+            , process = runQuote . dropSpace+            }+        , (command "remember")+            { help = say "remember <nick> <quote>: Remember that <nick> said <quote>."+            , process = runRemember . dropSpace+            }+        , (command "forget")+            { help = say "forget nick quote.  Delete a quote"+            , process = runForget . dropSpace+            }+        , (command "ghc")+            { help = say "ghc. Choice quotes from GHC."+            , process = const (fortune ["ghc"])+            }+        , (command "fortune")+            { help = say "fortune. Provide a random fortune"+            , process = const (fortune [])+            }+        , (command "yow")+            { help = say "yow. The zippy man."+            , process = const (fortune ["zippy"])+            }+        , (command "arr")+            { help = say "arr. Talk to a pirate"+            , process = const (fortune ["arr"])+            }+        , (command "yarr")+            { help = say "yarr. Talk to a scurvy pirate"+            , process = const (fortune ["arr", "yarr"])+            }+        , (command "keal")+            { help = say "keal. Talk like Keal"+            , process = const (fortune ["keal"])+            }+        , (command "b52s")+            { help = say "b52s. Anyone noticed the b52s sound a lot like zippy?"+            , process = const (fortune ["b52s"])+            }+        , (command "pinky")+            { help = say "pinky. Pinky and the Brain"+            , process = \s -> fortune $ if "pondering" `isInfixOf` s+                then ["pinky-pondering"]+                else ["pinky-pondering", "pinky"]+            }+        , (command "brain")+            { help = say "brain. Pinky and the Brain"+            , process = const (fortune ["brain"])+            }+        , (command "palomer")+            { help = say "palomer. Sound a bit like palomer on a good day."+            , process = const (fortune ["palomer"])+            }+        , (command "girl19")+            { help = say "girl19 wonders what \"discriminating hackers\" are."+            , process = const (fortune ["girl19"])+            }+        , (command "v")+            { aliases = ["yhjulwwiefzojcbxybbruweejw"]+            , help = getCmdName >>= \v -> case v of+                "v" -> say "let v = show v in v"+                _   -> say "V RETURNS!"+            , process = const (fortune ["notoriousV"])+            }+        , (command "protontorpedo")+            { help = say "protontorpedo is silly"+            , process = const (fortune ["protontorpedo"])+            }+        , (command "nixon")+            { help = say "Richard Nixon's finest."+            , process = const (fortune ["nixon"])+            }+        , (command "farber")+            { help = say "Farberisms in the style of David Farber."+            , process = const (fortune ["farber"])+            }+        ]+    }++fortune :: [FilePath] -> Cmd Quote ()+fortune xs = io (resolveFortuneFiles All xs >>= randomFortune) >>= say++------------------------------------------------------------------------++-- the @remember command stores away a quotation by a user, for future+-- use by @quote++-- error handling!+runRemember :: String -> Cmd Quote ()+runRemember str+    | null rest = say "Incorrect arguments to quote"+    | otherwise = do+        withMS $ \fm writer -> do+            let ss  = fromMaybe [] (M.lookup (P.pack nm) fm)+                fm' = M.insert (P.pack nm) (P.pack q : ss) fm+            writer fm'+        say =<< random confirmation+    where+        (nm,rest) = break isSpace str+        q         = drop 1 rest++-- @forget, to remove a quote+runForget :: String -> Cmd Quote ()+runForget str+    | null rest = say "Incorrect arguments to quote"+    | otherwise = do+        ss <- withMS $ \fm writer -> do+            let ss  = fromMaybe [] (M.lookup (P.pack nm) fm)+                fm' = case delete (P.pack q) ss of+                    []  -> M.delete (P.pack nm)     fm+                    ss' -> M.insert (P.pack nm) ss' fm+            writer fm'+            return ss+        say $ if P.pack q `elem` ss+            then "Done."+            else "No match."+    where+        (nm,rest) = break isSpace str+        q         = drop 1 rest++--+--  the @quote command, takes a user nm to choose a random quote from+--+runQuote :: String -> Cmd Quote ()+runQuote str =+    say =<< io . search (P.pack nm) (P.pack pat) =<< readMS+  where (nm, p) = break isSpace str+        pat     = drop 1 p++search :: Key -> P.ByteString -> Quotes -> IO String+search key pat db+    | M.null db          = return "No quotes yet."++    | P.null key         = do+        (key', qs) <- random (M.toList db) -- quote a random person+        fmap (display key') (random qs)++    | P.null pat, Just qs <- mquotes =+        fmap (display key) (random qs)++    | P.null pat         = match' key allquotes++    | Just qs <- mquotes = match' pat (zip (repeat key) qs)++    | otherwise          = do+        r <- random insult+        return $ "No quotes for this person. " ++ r++  where+    mquotes   = M.lookup key db+    allquotes = concat [ zip (repeat who) qs | (who, qs) <- M.assocs db ]++    match' p ss = do+        re <- makeRegexOptsM defaultCompOpt {caseSensitive = False, newSyntax = True}+                             defaultExecOpt {captureGroups = False} p++        let rs = filter (match re . snd) ss+        if null rs+            then do r <- random insult+                    return $ "No quotes match. " ++ r+            else do (who, saying) <- random rs+                    return $ P.unpack who ++ " says: " ++ P.unpack saying++    display k msg = (if P.null k then "  " else who ++ " says: ") ++ saying+          where saying = P.unpack msg+                who    = P.unpack k
+ src/Lambdabot/Plugin/Search.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE ViewPatterns #-}+-- | Search various things, Wikipedia and google for now.+--+-- (c) 2005 Samuel Bronson+-- (c) 2006 Don Stewart++-- Joel Koerwer 11-01-2005 generalized query for different methods+--   and added extractConversion to make things like @google 1+2 work+module Lambdabot.Plugin.Search (theModule) where++import Lambdabot.Plugin+import Lambdabot.Util.Browser++import Data.Maybe+import Network.HTTP+import Network.HTTP.Proxy+import Network.URI hiding (path, query)+import Text.HTML.TagSoup+import Text.HTML.TagSoup.Match (anyAttr, tagOpen)++engines :: [(String, (URI, String -> String, [Header]))]+engines =+   [("google", (googleUri, (\s -> "?hl=en&q="++s++"&btnI=I'm+Feeling+Lucky"), googleHeaders)),+    -- ("wikipedia", (wikipediaUri, ("?search="++), [])), -- this has changed and Wikipedia requires a User-Agent string+    ("gsite", (googleUri, (\s -> "?hl=en&q=site%3A"++s++"&btnI=I'm+Feeling+Lucky"), googleHeaders)),+    ("gwiki", (googleUri, (\s -> "?hl=en&q=site%3Ahaskell.org/haskellwiki+" ++s++"&btnI=I'm+Feeling+Lucky"), googleHeaders))+   ]++googleHeaders :: [Header]+googleHeaders = [mkHeader HdrReferer "http://www.google.com/"]++normalizeOptions :: MonadLB m => m (NormalizeRequestOptions a)+normalizeOptions = do+    proxy' <- getConfig proxy+    let hasProxy = case proxy' of+            NoProxy -> False+            _       -> True+    return defaultNormalizeRequestOptions+        { normDoClose = True+        , normForProxy = hasProxy+        , normUserAgent = Nothing+        } -- there is a default user agent, perhaps we want it?++makeUri :: String -> String -> URI+makeUri regName path = nullURI {+    uriScheme = "http:",+    uriAuthority = Just (URIAuth { uriUserInfo = "", uriRegName = regName, uriPort = "" }),+    uriPath = path }++googleUri :: URI+googleUri = makeUri "www.google.com" "/search"+-- wikipediaUri = makeUri "en.wikipedia.org" "/wiki/Special:Search"++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command name)+            { help = say (moduleHelp name)+            , process = \e -> do+                s <- getCmdName+                lb (searchCmd s (dropSpace e)) >>= mapM_ say+            }+        | name <- map fst engines+        ]+    }++moduleHelp :: String -> String+moduleHelp s = case s of+    "google"    -> "google <expr>. Search google and show url of first hit"+    -- "wikipedia" -> "wikipedia <expr>. Search wikipedia and show url of first hit"+    "gsite"     -> "gsite <site> <expr>. Search <site> for <expr> using google"+    "gwiki"     -> "gwiki <expr>. Search (new) haskell.org wiki for <expr> using google."+    _           -> "Search Plugin does not have command \"" ++ s ++ "\""++------------------------------------------------------------------------++searchCmd :: String -> String -> LB [String]+searchCmd _          []   = return ["Empty search."]+searchCmd engineName (urlEncode -> query)+    | engineName == "google" = do -- for Google we do both to get conversions, e.g. for '3 lbs in kg'+        request <- request'+        doHTTP request $ \response ->+            case response of+                Response { rspCode = (3,0,2), rspHeaders = (lookupHeader HdrLocation -> Just url) } ->+                    doGoogle >>=  handleUrl url+                _ -> fmap (\extra -> if null extra then ["No Result Found."] else extra) doGoogle+    | otherwise = do+        request <- request'+        doHTTP request $ \response ->+            case response of+                Response { rspCode = (3,0,2), rspHeaders = (lookupHeader HdrLocation -> Just url) } ->+                    handleUrl url []+                _ -> return ["No Result Found."]+  where handleUrl url extra = do+            title <- browseLB (urlPageTitle url)+            return $ extra ++ maybe [url] (\t -> [url, "Title: " ++ t]) title+        Just (uri, makeQuery, headers) = lookup engineName engines+        request' = do+            opts <- normalizeOptions+            return $ normalizeRequest opts $ Request+                { rqURI = uri { uriQuery = makeQuery query }+                , rqMethod = HEAD+                , rqHeaders = headers+                , rqBody = ""+                }+        doGoogle = do+            request <- request'+            doHTTP (request { rqMethod = GET, rqURI = uri { uriQuery = "?hl=en&q=" ++ query } }) $ \response ->+                case response of+                    Response { rspCode = (2,_,_), rspBody = (extractConversion -> Just result) } ->+                        return [result]+                    _ -> return []++doHTTP :: HStream a => Request a -> (Response a -> LB [String]) -> LB [String]+doHTTP request handler = do+    result <- io $ simpleHTTP request+    case result of+        Left connError -> return ["Connection error: "++show connError]+        Right response -> handler response++-- This is clearly fragile.+extractConversion :: String -> Maybe String+extractConversion (parseTags -> tags) = listToMaybe [txt |+    section <- sections (tagOpen ("h2"==) (anyAttr (\(name, value) -> name == "class" && value == "r"))) tags,+    txt <- [dropSpace $ drop 1 $ dropWhile (/= '=') t | TagText t <- section],+    not (null txt)]
+ src/Lambdabot/Plugin/Seen.hs view
@@ -0,0 +1,331 @@+-- Copyright (c) 2004 Thomas Jaeger+-- Copyright (c) 2005-6 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++-- | Keep track of IRC users.+module Lambdabot.Plugin.Seen (theModule) where++import Lambdabot+import Lambdabot.Compat.AltTime+import Lambdabot.Compat.PackedNick+import Lambdabot.IRC+import qualified Lambdabot.Message as G+import Lambdabot.Nick+import Lambdabot.Plugin+import Lambdabot.Plugin.Seen.StopWatch+import Lambdabot.Plugin.Seen.UserStatus++import Control.Exception+import Control.Monad+import Control.Monad.Trans+import Data.Binary+import qualified Data.ByteString.Char8 as P+import qualified Data.ByteString.Lazy as L+import Data.Char+import Data.List+import qualified Data.Map as M+import System.IO+import Text.Printf++type SeenState = (MaxMap, SeenMap)+type SeenMap   = M.Map PackedNick UserStatus+type MaxMap    = M.Map Channel Int++type Seen = ModuleT SeenState LB++------------------------------------------------------------------------++theModule :: Module (M.Map Channel Int, M.Map PackedNick UserStatus)+theModule = newModule+    { moduleDefState = return (M.empty,M.empty)++    , moduleCmds = return+        [ (command "users")+            { help = say "users [chan]. Report the maximum number of users seen in a channel, and active users in the last 30 minutes"+            , process = doUsers+            }+        , (command "seen")+            { help = say "seen <user>. Report if a user has been seen by the bot"+            , process = doSeen+            }+        ]++    , moduleInit = do+        sequence_+            [ ircSignalConnect signal =<< bindModule1 (withSeenFM cb)+            | (signal, cb) <- zip+                ["JOIN", "PART", "QUIT", "NICK", "353",      "PRIVMSG"]+                [joinCB, partCB, quitCB, nickCB, joinChanCB, msgCB]+            ]++        c <- lb $ findOrCreateLBFile "seen"+        s <- io $ P.readFile c+        let ls = L.fromChunks [s]+        mbDecoded <- io . try . evaluate $ decode ls+        case mbDecoded of+            Left exc -> do+                -- try reading the old format (slightly different type... oh, "binary"...)+                mbOld <- io . try . evaluate $ decode ls+                case mbOld of+                    Left exc2 -> do+                        let _ = exc2 :: SomeException+                        io $ hPutStrLn stderr ("WARNING: failed to read Seen module state: "  ++ show (exc :: SomeException))+                    Right (maxMap, seenMap) ->+                        writeMS (M.mapKeys P.pack maxMap, seenMap)+            Right decoded -> writeMS decoded++    , moduleExit = do+        chans <- lift $ ircGetChannels+        unless (null chans) $ do+            ct    <- io getClockTime+            modifyMS $ \(n,m) -> (n, botPart ct (map packNick chans) m)++        -- and write out our state:+        withMS $ \s _ -> lb (findOrCreateLBFile "seen") >>= \ c -> io (encodeFile c s)+    }++lcNick :: Nick -> Nick+lcNick (Nick svr nck) = Nick svr (map toLower nck)++------------------------------------------------------------------------++doUsers :: String -> Cmd Seen ()+doUsers rest = withMsg $ \msg -> do+    -- first step towards tracking the maximum number of users+    chan <- getTarget+    (m, seenFM) <- readMS+    s <- io getClockTime+    let who = packNick $ lcNick $ if null rest then chan else parseNick (G.server msg) rest+        now = length [ () | (_,Present _ chans) <- M.toList seenFM+                          , who `elem` chans ]++        n = case M.lookup who m of Nothing -> 1; Just n' -> n'++        active = length [() | (_,st@(Present _ chans)) <- M.toList seenFM+                            , who `elem` chans && isActive st ]++        isActive (Present (Just (ct,_td)) _cs) = recent ct+        isActive _                             = False++        recent t = diffClockTimes s t < gap_minutes+        gap_minutes = TimeDiff 1800 -- 30 minutes++        percent p q = 100 * (fromIntegral p / fromIntegral q) :: Double++        total   0 0 = "0"+        total   p q = printf "%d (%0.1f%%)" p (percent p q)++    say $! printf "Maximum users seen in %s: %d, currently: %s, active: %s"+        (fmtNick (G.server msg) $ unpackNick who) n (total now n) (total active now)++doSeen :: String -> Cmd Seen ()+doSeen rest = withMsg $ \msg -> do+    target <- getTarget+    (_,seenFM) <- readMS+    now        <- io getClockTime+    let (txt,safe) = (getAnswer msg rest seenFM now)+    if safe || not ("#" `isPrefixOf` nName target)+        then mapM_ say txt+        else lb (ircPrivmsg (G.nick msg) (unlines txt))++getAnswer :: G.Message a => a -> String -> SeenMap -> ClockTime -> ([String], Bool)+getAnswer msg rest seenFM now+    | null nick' =+        let people  = map fst $ filter isActive $ M.toList seenFM+            isActive (_nick,state) = case state of+                (Present (Just (ct,_td)) _cs) -> recent ct+                _ -> False+            recent t = diffClockTimes now t < gap_minutes+            gap_minutes = TimeDiff 900 -- 15 minutes+         in (["Lately, I have seen " ++ (if null people then "nobody"+                 else listToStr "and" (map upAndShow people)) ++ "."], False)++    | pnick == G.lambdabotName msg =+        case M.lookup (packNick pnick) seenFM of+            Just (Present _ cs) ->+                (["Yes, I'm here. I'm in " ++ listToStr "and" (map upAndShow cs)], True)+            _ -> error "I'm here, but not here. And very confused!"++    | head (nName pnick) == '#' =+        let people  = map fst $ filter inChan $ M.toList seenFM+            inChan (_nick,state) = case state of+                (Present (Just _) cs)+                    -> packNick pnick `elem` cs+                _   -> False+         in (["In "++nick'++" I can see "+            ++ (if null people then "nobody"    -- todo, how far back does this go?+               else listToStr "and" (map upAndShow people)) ++ "."], False)++    | otherwise        = (return $ concat (case M.lookup (packNick pnick) seenFM of+        Just (Present mct cs)            -> nickPresent mct (map upAndShow cs)+        Just (NotPresent ct td chans)    -> nickNotPresent ct td (map upAndShow chans)+        Just (WasPresent ct sw _ chans)  -> nickWasPresent ct sw (map upAndShow chans)+        Just (NewNick newnick)           -> nickIsNew newnick+        _ -> ["I haven't seen ", nick, "."]), True)+    where+        -- I guess the only way out of this spagetty hell are printf-style responses.+        upAndShow = fmtNick (G.server msg) . unpackNick+        nickPresent mct cs =+            [ if you then "You are" else nick ++ " is"+            , " in ", listToStr "and" cs, "."+            , case mct of+                Nothing          -> concat [" I don't know when ", nick, " last spoke."]+                Just (ct,missed) -> prettyMissed (Stopped missed)+                       (concat [" I last heard ", nick, " speak ",+                                lastSpoke {-, ", but "-}])+                       (" Last spoke " ++ lastSpoke)+                    where lastSpoke = clockDifference ct+            ]+        nickNotPresent ct missed chans =+            [ "I saw ", nick, " leaving ", listToStr "and" chans, " "+            , clockDifference ct, prettyMissed missed ", and " ""+            ]+        nickWasPresent ct sw chans =+            [ "Last time I saw ", nick, " was when I left "+            , listToStr "and" chans , " ", clockDifference ct+            , prettyMissed sw ", and " ""+            ]+        nickIsNew newnick =+            [ if you then "You have" else nick++" has"+            , " changed nick to ", us, "."+            ] ++ fst (getAnswer msg us seenFM now)+            where+                us = upAndShow $ findFunc newnick+                findFunc pstr = case M.lookup pstr seenFM of+                    Just (NewNick pstr') -> findFunc pstr'+                    Just _               -> pstr+                    Nothing              -> error "SeenModule.nickIsNew: Nothing"++        nick' = takeWhile (not . isSpace) rest+        you   = pnick == lcNick (G.nick msg)+        nick  = if you then "you" else nick'+        pnick = lcNick $ parseNick (G.server msg) nick'+        clockDifference past+            | all (==' ') diff = "just now"+            | otherwise        = diff ++ " ago"+            where diff = timeDiffPretty . diffClockTimes now $ past++        prettyMissed (Stopped _) _ifMissed _     = "." -- ifMissed ++ "."+        prettyMissed _           _ _ifNotMissed  = "." -- ifNotMissed ++ "."++{-+        prettyMissed (Stopped missed) ifMissed _+            | missedPretty <- timeDiffPretty missed+            , any (/=' ') missedPretty+            = concat [ifMissed, "I have missed ", missedPretty, " since then."]++        prettyMissed _ _ ifNotMissed = ifNotMissed ++ "."+-}++-- | extract channels from message as packed, lower cased, strings.+msgChans :: G.Message a => a -> [Channel]+msgChans = map (packNick . lcNick) . G.channels++-- | Callback for when somebody joins. If it is not the bot that joins, record+--   that we have a new user in our state tree and that we have never seen the+--   user speaking.+joinCB :: IrcMessage -> ClockTime -> PackedNick -> SeenMap -> Either String SeenMap+joinCB msg _ct nick fm+    | nick == lbNick = Right fm+    | otherwise      = Right $! insertUpd (updateJ Nothing chans) nick newInfo fm+    where+        insertUpd f = M.insertWith (\_ -> f)+        lbNick  = packNick $ G.lambdabotName msg+        newInfo = Present Nothing chans+        chans   = msgChans msg++-- | Update the state to reflect the bot leaving channel(s)+botPart :: ClockTime -> [Channel] -> SeenMap -> SeenMap+botPart ct cs = fmap botPart'+    where+        botPart' (Present mct xs) = case xs \\ cs of+            [] -> WasPresent ct (startWatch ct zeroWatch) mct cs+            ys -> Present mct ys+        botPart' (NotPresent ct' missed c)+            | head c `elem` cs = NotPresent ct' (startWatch ct missed) c+        botPart' (WasPresent ct' missed mct c)+            | head c `elem` cs = WasPresent ct' (startWatch ct missed) mct c+        botPart' us = us++-- | when somebody parts+partCB :: IrcMessage -> ClockTime -> PackedNick -> SeenMap -> Either String SeenMap+partCB msg ct nick fm+    | nick == lbNick = Right $ botPart ct (msgChans msg) fm+    | otherwise      = case M.lookup nick fm of+        Just (Present mct xs) ->+            case xs \\ (msgChans msg) of+                [] -> Right $! M.insert nick (NotPresent ct zeroWatch xs) fm+                ys -> Right $! M.insert nick (Present mct ys)             fm+        _ -> Left "someone who isn't known parted"+    where lbNick = packNick $ G.lambdabotName msg++-- | when somebody quits+quitCB :: IrcMessage -> ClockTime -> PackedNick -> SeenMap -> Either String SeenMap+quitCB _ ct nick fm = case M.lookup nick fm of+    Just (Present _ct xs) -> Right $! M.insert nick (NotPresent ct zeroWatch xs) fm+    _                     -> Left "someone who isn't known has quit"++-- | when somebody changes his\/her name+nickCB :: IrcMessage -> ClockTime -> PackedNick -> SeenMap -> Either String SeenMap+nickCB msg _ nick fm = case M.lookup nick fm of+    Just status -> Right $! M.insert lcnewnick status+                          $ M.insert nick (NewNick lcnewnick) fm+    _           -> Left "someone who isn't here changed nick"+    where+        newnick = drop 1 $ head (ircMsgParams msg)+        lcnewnick = packNick $ lcNick $ parseNick (G.server msg) newnick++-- | when the bot joins a channel+joinChanCB :: IrcMessage -> ClockTime -> PackedNick -> SeenMap -> Either String SeenMap+joinChanCB msg now _nick fm+    = Right $! fmap (updateNP now chan) (foldl insertNick fm chanUsers)+    where+        l = ircMsgParams msg+        chan = packNick $ lcNick $ parseNick (G.server msg) $ l !! 2+        chanUsers = map (packNick . lcNick . parseNick (G.server msg)) $ words (drop 1 (l !! 3)) -- remove ':'+        unUserMode nick = Nick (nTag nick) (dropWhile (`elem` "@+") $ nName nick)+        insertUpd f = M.insertWith (\_ -> f)+        insertNick fm' u = insertUpd (updateJ (Just now) [chan])+            (packNick . unUserMode . lcNick . unpackNick $ u)+            (Present Nothing [chan]) fm'++-- | when somebody speaks, update their clocktime+msgCB :: IrcMessage -> ClockTime -> PackedNick -> SeenMap -> Either String SeenMap+msgCB _ ct nick fm =+    case M.lookup nick fm of+        Just (Present _ xs) -> Right $!+            M.insert nick (Present (Just (ct, noTimeDiff)) xs) fm+        _ -> Left "someone who isn't here msg us"+++-- | Callbacks are only allowed to use a limited knowledge of the world.+-- 'withSeenFM' is (up to trivial isomorphism) a monad morphism from the+-- restricted+--   'ReaderT (IRC.Message, ClockTime, Nick) (StateT SeenState (Error String))'+-- to the+--   'ReaderT IRC.Message (Seen IRC)'+-- monad.+withSeenFM :: G.Message a+           => (a -> ClockTime -> PackedNick -> SeenMap -> Either String SeenMap)+           -> (a -> Seen ())++withSeenFM f msg = do+    let chan = packNick . lcNick . head . G.channels $! msg+        nick = packNick . lcNick . G.nick $ msg++    withMS $ \(maxUsers,state) writer -> do+        ct <- io getClockTime+        case f msg ct nick state of+            Left _         -> return ()+            Right newstate -> do+                let curUsers = length $!+                        [ () | (_,Present _ chans) <- M.toList state+                        , chan `elem` chans ]++                    newMax = case M.lookup chan maxUsers of+                        Nothing -> M.insert chan curUsers maxUsers+                        Just  n -> if n < curUsers+                            then M.insert chan curUsers maxUsers+                            else maxUsers++                newMax `seq` newstate `seq` writer (newMax, newstate)
+ src/Lambdabot/Plugin/Seen/StopWatch.hs view
@@ -0,0 +1,30 @@+module Lambdabot.Plugin.Seen.StopWatch where++import Lambdabot.Compat.AltTime++import Data.Binary++data StopWatch+    = Stopped !TimeDiff+    | Running !ClockTime+    deriving (Show,Read)++instance Binary StopWatch where+    put (Stopped td) = putWord8 0 >> put td+    put (Running ct) = putWord8 1 >> put ct++    get = getWord8 >>= \h -> case h of+        0 -> fmap Stopped get+        1 -> fmap Running get+        _ -> error "Seen.StopWatch.get"++zeroWatch :: StopWatch+zeroWatch = Stopped noTimeDiff++startWatch :: ClockTime -> StopWatch -> StopWatch+startWatch now (Stopped td) = Running (td `addToClockTime` now)+startWatch _ alreadyStarted = alreadyStarted++stopWatch :: ClockTime -> StopWatch -> StopWatch+stopWatch now (Running t)  = Stopped (t `diffClockTimes` now)+stopWatch _ alreadyStopped = alreadyStopped
+ src/Lambdabot/Plugin/Seen/UserStatus.hs view
@@ -0,0 +1,77 @@+module Lambdabot.Plugin.Seen.UserStatus where++import Control.Applicative+import Data.Binary+import qualified Data.ByteString as BS+import Data.List+import Lambdabot.Compat.AltTime+import Lambdabot.Compat.PackedNick+import Lambdabot.Plugin.Seen.StopWatch++-- | The type of channels+type Channel = BS.ByteString++-- | We last heard the user speak at ClockTime; since then we have missed+--   TimeDiff of him because we were absent.+type LastSpoke = Maybe (ClockTime, TimeDiff)++-- | 'UserStatus' keeps track of the status of a given Nick name.+data UserStatus+    = Present    !LastSpoke [Channel]+        -- ^ Records when the nick last spoke and that the nick is currently+        --   in [Channel].+    | NotPresent !ClockTime !StopWatch [Channel]+        -- ^ The nick is not present and was last seen at ClockTime in Channel.+        --   The second argument records how much we've missed.+    | WasPresent !ClockTime !StopWatch !LastSpoke [Channel]+        -- ^ The bot parted a channel where the user was. The Clocktime+        --   records the time and Channel the channel this happened in.+        --   We also save the reliablility of our information and the+        --   time we last heard the user speak.+    | NewNick !PackedNick+        -- ^ The user changed nick to something new.+    deriving (Show, Read)++instance Binary UserStatus where+    put (Present sp ch)          = putWord8 0 >> put sp >> put ch+    put (NotPresent ct sw ch)    = putWord8 1 >> put ct >> put sw >> put ch+    put (WasPresent ct sw sp ch) = putWord8 2 >> put ct >> put sw >> put sp >> put ch+    put (NewNick n)              = putWord8 3 >> put n++    get = getWord8 >>= \h -> case h of+        0 -> Present    <$> get <*> get+        1 -> NotPresent <$> get <*> get <*> get+        2 -> WasPresent <$> get <*> get <*> get <*> get+        3 -> NewNick    <$> get+        _ -> error "Seen.UserStatus.get"++-- | Update the user status when a user joins a channel.+updateJ :: Maybe ClockTime -- ^ If the bot joined the channel, the time that+                           --   happened, i.e. now.+    -> [Channel]           -- ^ The channels the user joined.+    -> UserStatus          -- ^ The old status+    -> UserStatus          -- ^ The new status+-- The user was present before, so he's present now.+updateJ _ c (Present ct cs) = Present ct $ nub (c ++ cs)+-- The user was present when we left that channel and now we've come back.+-- We need to update the time we've missed.+updateJ (Just now) cs (WasPresent lastSeen _ (Just (lastSpoke, missed)) channels)+    | head channels `elem` cs+    ---                 newMissed+    --- |---------------------------------------|+    --- |-------------------|                   |+    ---        missed    lastSeen              now+    = let newMissed = addToClockTime missed now `diffClockTimes` lastSeen+       in newMissed `seq` Present (Just (lastSpoke, newMissed)) cs+-- Otherwise, we create a new record of the user.+updateJ _ cs _ = Present Nothing cs++-- | Update a user who is not present. We just convert absolute missing time+--   into relative time (i.e. start the "watch").+updateNP :: ClockTime -> Channel -> UserStatus -> UserStatus+updateNP now _ (NotPresent ct missed c)+    = NotPresent ct (stopWatch now missed) c+-- The user might be gone, thus it's meaningless when we last heard him speak.+updateNP now chan (WasPresent lastSeen missed _ cs)+    | head cs == chan = WasPresent lastSeen (stopWatch now missed) Nothing cs+updateNP _ _ status = status
+ src/Lambdabot/Plugin/Slap.hs view
@@ -0,0 +1,78 @@+-- | Support for quotes+module Lambdabot.Plugin.Slap (theModule) where++import Lambdabot.Plugin++type Slap = ModuleT () LB++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "slap")+            { aliases = ["smack"]+            , help = say "slap <nick>. Slap someone amusingly."+            , process = slap+            }+        ]+    }++------------------------------------------------------------------------++slap :: String -> Cmd Slap ()+slap "me" = do+    target <- showNick =<< getSender+    slapRandom target+slap "yourself" = do+    target <- showNick =<< getLambdabotName+    slapRandom target+slap target =+    slapRandom target++slapRandom :: String -> Cmd Slap ()+slapRandom tgt = say . ($ tgt) =<< random slapList++slapList :: [String -> String]+slapList =+    [(\x -> "/me slaps " ++ x)+    ,(\x -> "/me smacks " ++ x ++ " about with a large trout")+    ,(\x -> "/me beats up " ++ x)+    ,(\x -> "/me pokes " ++ x ++ " in the eye")+    ,(\x -> "why on earth would I slap " ++ x ++ "?")+    ,(\x -> "*SMACK*, *SLAM*, take that " ++ x ++ "!")+    ,(\_ -> "/me activates her slap-o-matic...")+    ,(\x -> "/me orders her trained monkeys to punch " ++ x)+    ,(\x -> "/me smashes a lamp on " ++ possesiveForm x ++ " head")+    ,(\x -> "/me hits " ++ x ++ " with a hammer, so they breaks into a thousand pieces")+    ,(\x -> "/me throws some pointy lambdas at " ++ x)+    ,(\x -> "/me loves " ++ x ++ ", so no slapping")+    ,(\x -> "/me would never hurt " ++ x ++ "!")+    ,(\x -> "go slap " ++ x ++ " yourself")+    ,(\_ -> "I won't; I want to go get some cookies instead.")+    ,(\x -> "I'd rather not; " ++ x ++ " looks rather dangerous.")+    ,(\_ -> "I don't perform such side effects on command!")+    ,(\_ -> "stop telling me what to do")+    ,(\x -> "/me clobbers " ++ x ++ " with an untyped language")+    ,(\x -> "/me pulls " ++ x ++ " through the Evil Mangler")+    ,(\x -> "/me secretly deletes " ++ possesiveForm x ++ " source code")+    ,(\x -> "/me places her fist firmly on " ++ possesiveForm x ++ " jaw")+    ,(\x -> "/me locks up " ++ x ++ " in a Monad")+    ,(\x -> "/me submits " ++ possesiveForm x ++ " email address to a dozen spam lists")+    ,(\x -> "/me moulds " ++ x ++ " into a delicous cookie, and places it in her oven")+    ,(\_ -> "/me will count to five...")+    ,(\x -> "/me jabs " ++ x ++ " with a C pointer")+    ,(\x -> "/me is overcome by a sudden desire to hurt " ++ x)+    ,(\x -> "/me karate-chops " ++ x ++ " into two equally sized halves")+    ,(\x -> "Come on, let's all slap " ++ x)+    ,(\x -> "/me pushes " ++ x ++ " from his chair")+    ,(\x -> "/me hits " ++ x ++ " with an assortment of kitchen utensils")+    ,(\x -> "/me slaps " ++ x ++ " with a slab of concrete")+    ,(\x -> "/me puts on her slapping gloves, and slaps " ++ x)+    ,(\x -> "/me decomposes " ++ x ++ " into several parts using the Banach-Tarski theorem and reassembles them to get two copies of " ++ x ++ "!")+    ]++-- | The possesive form of a name, "x's"+possesiveForm :: String -> String+possesiveForm [] = []+possesiveForm x+ | last x == 's' = x ++ "'"+ | otherwise     = x ++ "'s"
+ src/Lambdabot/Plugin/Source.hs view
@@ -0,0 +1,40 @@+-- Plugin.Source+-- Display source for specified identifiers+module Lambdabot.Plugin.Source (theModule) where++import Lambdabot.Plugin+import Control.Monad+import qualified Data.ByteString.Char8 as P+import qualified Data.Map as M++type Env = M.Map P.ByteString P.ByteString++theModule :: Module (M.Map P.ByteString P.ByteString)+theModule = newModule+    { moduleCmds = return+        [ (command "src")+            { help = say helpStr+            , process = \key -> readMS >>= \env -> case fetch (P.pack key) env of+                _ | M.null env -> say "No source in the environment yet"+                _ |   null key -> say helpStr+                Nothing        -> say . ("Source not found. " ++) =<< io (random insult)+                Just s         -> say (P.unpack s)+            }+        ]++    -- all the hard work is done to build the src map.+    -- uses a slighly custom Map format+    , moduleSerialize = Just . readOnly $ M.fromList . map pair . splat . P.lines+    }+        where+            pair (a:b) = (a, P.unlines b)+            pair _     = error "Source Plugin error: not a pair"+            splat []   = []+            splat s    = a : splat (tail b) where (a,b) = break P.null s++fetch :: P.ByteString -> Env -> Maybe P.ByteString+fetch x m = M.lookup x m `mplus`+            M.lookup (P.concat [P.singleton '(', x, P.singleton ')']) m++helpStr :: String+helpStr = "src <id>. Display the implementation of a standard function"
+ src/Lambdabot/Plugin/Spell.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE PatternGuards #-}+-- Copyright (c) 2004-6 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)+--+-- | Interface to /aspell/, an open source spelling checker, from a+-- suggestion by Kai Engelhardt. Requires you to install aspell.+module Lambdabot.Plugin.Spell (theModule) where++import Lambdabot.Plugin++import Control.Monad.Trans+import Data.Char+import Data.List.Split+import Data.Maybe+import System.Process+import Text.Regex.TDFA+++type Spell = ModuleT Bool LB++theModule :: Module Bool+theModule = newModule+    { moduleCmds = return+        [ (command "spell")+            { help = say helpStr+            , process = doSpell+            }+        , (command "spell-all")+            { help = say helpStr+            , process = spellAll+            }+        , (command "nazi-on")+            { privileged = True+            , help = say helpStr+            , process = const (nazi True)+            }+        , (command "nazi-off")+            { privileged = True+            , help = say helpStr+            , process = const (nazi False)+            }+        ]+    , moduleDefState = return False++    , contextual = \txt -> do+        alive <- readMS+        binary <- getConfig aspellBinary+        if alive then io (spellingNazi binary txt) >>= mapM_ say+                 else return ()+    }++helpStr :: String+helpStr = "spell <word>. Show spelling of word"++doSpell :: [Char] -> Cmd Spell ()+doSpell [] = say "No word to spell."+doSpell s  = do+    binary <- getConfig aspellBinary+    (say . showClean . take 5) =<< (io (spell binary s))++spellAll :: [Char] -> Cmd Spell ()+spellAll [] = say "No phrase to spell."+spellAll s  = do+    binary <- getConfig aspellBinary+    liftIO (spellingNazi binary s) >>= mapM_ say++nazi :: Bool -> Cmd (ModuleT Bool LB) ()+nazi True  = lift on  >> say "Spelling nazi engaged."+nazi False = lift off >> say "Spelling nazi disengaged."++on :: Spell ()+on  = writeMS True++off :: Spell ()+off = writeMS False++args :: [String]+args = ["pipe"]++--+-- | Find the first misspelled word in the input line, and return plausible+-- output.+--+spellingNazi :: String -> String -> IO [String]+spellingNazi binary lin = fmap (take 1 . concat) (mapM correct (words lin))+    where correct word = do+            var <- take 5 `fmap` spell binary word+            return $ if null var || any (equating' (map toLower) word) var+                then []+                else ["Did you mean " ++ listToStr "or" var ++ "?"]+          equating' f x y = f x == f y+--+-- | Return a list of possible spellings for a word+-- 'String' is a word to check the spelling of.+--+spell :: String -> String -> IO [String]+spell binary word = spellWithArgs binary word []++spellWithArgs :: String -> String -> [String] -> IO [String]+spellWithArgs binary word ex = do+    (_,out,err) <- readProcessWithExitCode binary (args++ex) word+    let o = fromMaybe [word] ((clean_ . lines) out)+        e = fromMaybe e      ((clean_ . lines) err)+    return $ case () of {_+        | null o && null e -> []+        | null o           -> e+        | otherwise        -> o+    }++--+-- Parse the output of aspell (would probably work for ispell too)+--+clean_ :: [String] -> Maybe [String]+clean_ (('@':'(':'#':')':_):rest) = clean' rest -- drop header+clean_ s = clean' s                             -- no header for some reason++--+-- Parse rest of aspell output.+--+-- Grammar is:+--      OK          ::=  *+--      Suggestions ::= & <original> <count> <offset>: <miss>, <miss>, ...+--      None        ::= # <original> <offset>+--+clean' :: [String] -> Maybe [String]+clean' (('*':_):_)    = Nothing                          -- correct spelling+clean' (('#':_):_)    = Just []                          -- no match+clean' (('&':rest):_) = Just $ splitOn ", " (clean'' rest) -- suggestions+clean' _              = Just []                          -- not sure++clean'' :: String -> String+clean'' s = maybe s mrAfter (s =~~ pat)+    where pat  = "[^:]*: "    -- drop header
+ src/Lambdabot/Plugin/Stats.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE GADTs #-}+module Lambdabot.Plugin.Stats (theModule) where++import Lambdabot.Plugin++import Network.StatsD+++type Stats = ModuleT StatsD LB++theModule :: Module StatsD+theModule = newModule+    { moduleDefState = io (openStatsD host port prefix)+    , contextual = \msg -> do+        let n = length msg++        user <- showNick =<< getSender+        chan <- showNick =<< getTarget++        counts+            [ (grp ++ [stat'], val')+            | grp <- [["user", user], ["channel", chan]]+            , (stat', val') <- [("lines", 1), ("chars", toInteger n) ]+            ]+    }++-- various helpers+host :: String+host = "stats.thecave.lan"++port :: String+port = "8125"++prefix :: [String]+prefix = ["lambdabot"]++report :: [Stat] -> Cmd Stats ()+report xs = do+    st <- readMS+    io (push st xs)++counts :: [([String], Integer)] -> Cmd Stats ()+counts xs = report [stat bucket' val' "c" Nothing | (bucket', val') <- xs]
+ src/Lambdabot/Plugin/System.hs view
@@ -0,0 +1,182 @@+-- | System module : IRC control functions+module Lambdabot.Plugin.System (theModule) where++import Lambdabot+import Lambdabot.Compat.FreenodeNick+import Lambdabot.IRC+import Lambdabot.Monad+import Lambdabot.Plugin+import Lambdabot.Compat.AltTime++import Control.Monad.State (gets, modify)+import Control.Monad.Trans+import qualified Data.Map as M+import qualified Data.Set as S++type SystemState = (ClockTime, TimeDiff)+type System = ModuleT SystemState LB++theModule :: Module SystemState+theModule = newModule+    { moduleDefState = flip (,) noTimeDiff `fmap` io getClockTime+    , moduleSerialize  = Just stdSerial++    , moduleInit = do+        (_, d) <- readMS+        t      <- io getClockTime+        writeMS (t, d)+    , moduleExit = do+        (initial, d) <- readMS+        now          <- liftIO getClockTime+        writeMS (initial, max d (diffClockTimes now initial))+    +    , moduleCmds = return $+        [ (command "listchans")+            { help = say "Show channels bot has joined"+            , process = \_ -> listKeys (M.mapKeysMonotonic (FreenodeNick . getCN) . ircChannels)+            }+        , (command "listmodules")+            { help = say "listmodules. Show available plugins"+            , process = \_ -> listKeys ircModules+            }+        , (command "listservers")+            { help = say "listservers. Show current servers"+            , process = \_ -> listKeys ircServerMap+            }+        , (command "list")+            { help = say "list [module|command]. Show commands for [module] or the module providing [command]."+            , process = doList+            }+        , (command "echo")+            { help = say "echo <msg>. echo irc protocol string"+            , process = doEcho+            }+        , (command "uptime")+            { help = say "uptime. Show uptime"+            , process = \_ -> do+                (uptime, maxUptime) <- lift getUptime+                say ("uptime: "           ++ timeDiffPretty uptime +++                     ", longest uptime: " ++ timeDiffPretty maxUptime)+            }+        +        , (command "listall")+            { privileged = True+            , help = say "list all commands"+            , process = \_ -> mapM_ doList . M.keys =<< lb (gets ircModules)+            }+        , (command "join")+            { privileged = True+            , help = say "join <channel>"+            , process = \rest -> do+                chan <- readNick rest+                lb $ send (joinChannel chan)+            }+        , (command "part")+            { privileged = True+            , help = say "part <channel>"+            , aliases = ["leave"]+            , process = \rest -> do+                chan <- readNick rest+                lb $ send (partChannel chan)+            }+        , (command "msg")+            { privileged = True+            , help = say "msg <nick or channel> <msg>"+            , process = \rest -> do+                -- writes to another location:+                let (tgt, txt) = splitFirstWord rest+                tgtNick <- readNick tgt+                lb $ ircPrivmsg tgtNick txt+            }+        , (command "quit")+            { privileged = True+            , help = say "quit [msg], have the bot exit with msg"+            , process = \rest -> do+                server <- getServer+                lb (ircQuit server $ if null rest then "requested" else rest)+            }+        , (command "flush")+            { privileged = True+            , help = say "flush. flush state to disk"+            , process = \_ -> lb flushModuleState+            }+        , (command "admin")+            { privileged = True+            , help = say "admin [+|-] nick. change a user's admin status."+            , process = doAdmin+            }+        , (command "ignore")+            { privileged = True+            , help = say "ignore [+|-] nick. change a user's ignore status."+            , process = doIgnore+            }+        , (command "reconnect")+            { privileged = True+            , help = say "reconnect to server"+            , process = \rest -> do+                server <- getServer+                lb (ircReconnect server $ if null rest then "requested" else rest)+            }+        ]+    }++------------------------------------------------------------------------++doList :: String -> Cmd System ()+doList "" = say "What module?  Try @listmodules for some ideas."+doList m  = say =<< lb (listModule m)++doEcho :: String -> Cmd System ()+doEcho rest = do+    rawMsg <- withMsg (return . show)+    target <- showNick =<< getTarget+    say (concat ["echo; msg:", rawMsg, " target:" , target, " rest:", show rest])++doAdmin :: String -> Cmd System ()+doAdmin = toggleNick $ \op nck s -> s { ircPrivilegedUsers = op nck (ircPrivilegedUsers s) }++doIgnore :: String -> Cmd System ()+doIgnore = toggleNick $ \op nck s -> s { ircIgnoredUsers = op nck (ircIgnoredUsers s) }++------------------------------------------------------------------------++--  | Print map keys+listKeys :: Show k => (IRCRWState -> M.Map k v) -> Cmd System ()+listKeys f = say . showClean . M.keys =<< lb (gets f)++getUptime :: System (TimeDiff, TimeDiff)+getUptime = do+    (loaded, m) <- readMS+    now         <- io getClockTime+    let diff = now `diffClockTimes` loaded+    return (diff, max diff m)++toggleNick :: (Ord a, MonadLB m) =>+    ((a -> S.Set a -> S.Set a) -> Nick -> IRCRWState -> IRCRWState)+    -> String -> Cmd m ()+toggleNick edit rest = do+    let (op, tgt) = splitAt 2 rest+    +    f <- case op of+        "+ " -> return S.insert+        "- " -> return S.delete+        _    -> fail "invalid usage"+    +    nck <- readNick tgt+    lb . modify $ edit f nck++listModule :: String -> LB String+listModule s = withModule s fromCommand printProvides+  where+    fromCommand = withCommand s+        (return $ "No module \""++s++"\" loaded") (const . printProvides)++    -- ghc now needs a type annotation here+    printProvides :: Module st -> ModuleT st LB String+    printProvides m = do+        cmds <- moduleCmds m+        let cmds' = filter (not . privileged) cmds+        name' <- getModuleName+        return . concat $ if null cmds'+                          then [name', " has no visible commands"]+                          else [name', " provides: ", showClean (concatMap cmdNames cmds')]
+ src/Lambdabot/Plugin/Tell.hs view
@@ -0,0 +1,235 @@+{- Leave a message with lambdabot, the faithful secretary++> 17:11 < davidhouse> @tell dmhouse foo+> 17:11 < hsbot> Consider it noted+> 17:11 < davidhouse> @tell dmhouse bar+> 17:11 < hsbot> Consider it noted+> 17:11 < dmhouse> hello!+> 17:11 < hsbot> dmhouse: You have 2 new messages. '/msg hsbot @messages' to read them.+> 17:11 < dmhouse> Notice how I'm speaking again, and hsbot isn't buzzing me more than that one time.+> 17:12 < dmhouse> It'll buzz me after a day's worth of not checking my messages.+> 17:12 < dmhouse> If I want to check them in the intermittent period, I can either send a /msg, or:+> 17:12 < dmhouse> @messages?+> 17:12 < hsbot> You have 2 messages+> 17:12 < dmhouse> Let's check them, shall we?+>+> [In a /msg to hsbot]+> 17:12 <hsbot> davidhouse said less than a minute ago: foo+> 17:12 <hsbot> davidhouse said less than a minute ago: bar+>+> [Back in the channel+> 17:12 < dmhouse> You needn't use a /msg, however. If you're not going to annoy the channel by printing 20 of+>                  your messages, feel free to just type '@messages' in the channel.+> 17:12 < davidhouse> @tell dmhouse foobar+> 17:12 < hsbot> Consider it noted+> 17:12 < davidhouse> @ask dmhouse barfoo+> 17:12 < hsbot> Consider it noted+> 17:12 < davidhouse> You can see there @ask. It's just a synonym for @tell, but it prints "foo asked X ago M",+>                     which is more natural. E.g. '@ask dons whether he's applied my latest patch yet?'+> 17:13 < dmhouse> For the admins, a useful little debugging tool is @print-notices.+> 17:13 < hsbot> dmhouse: You have 2 new messages. '/msg hsbot @messages' to read them.+> 17:14 < dmhouse> Notice that hsbot pinged me there, even though it's less than a day since I last checked my+>                  messages, because there have been some new ones posted.+> 17:14 < dmhouse> @print-notices+> 17:14 < hsbot> {"dmhouse":=(Just Thu Jun  8 17:13:46 BST 2006,[Note {noteSender = "davidhouse", noteContents =+>                "foobar", noteTime = Thu Jun  8 17:12:50 BST 2006, noteType = Tell},Note {noteSender =+                 "davidhouse", noteContents = "barfoo", noteTime = Thu Jun  8 17:12:55 BST 2006, noteType = Ask}])}+> 17:15 < dmhouse> There you can see the two notes. The internal state is a map from recipient nicks to a pair of+>                  (when we last buzzed them about having messages, a list of the notes they've got stacked up).+> 17:16 < dmhouse> Finally, if you don't want to bother checking your messages, then the following command will+>                  likely be useful.+> 17:16 < dmhouse> @clear-messages+> 17:16 < hsbot> Messages cleared.+> 17:16 < dmhouse> That's all, folks!+> 17:17 < dmhouse> Any comments, queries or complaints to dmhouse@gmail.com. The source should be fairly readable, so+>                  hack away!+-}++module Lambdabot.Plugin.Tell (theModule) where++import Lambdabot.Compat.FreenodeNick+import Lambdabot.Plugin+import Lambdabot.Compat.AltTime++import Control.Arrow (first)+import Control.Monad+import qualified Data.Map as M+import Text.Printf (printf)++-- | Was it @tell or @ask that was the original command?+data NoteType    = Tell | Ask deriving (Show, Eq, Read)+-- | The Note datatype. Fields self-explanatory.+data Note        = Note { noteSender   :: FreenodeNick,+                          noteContents :: String,+                          noteTime     :: ClockTime,+                          noteType     :: NoteType }+                   deriving (Eq, Show, Read)+-- | The state. A map of (times we last told this nick they've got messages, the+--   messages themselves)+type NoticeBoard = M.Map FreenodeNick (Maybe ClockTime, [Note])++type Tell = ModuleT NoticeBoard LB++theModule :: Module NoticeBoard+theModule = newModule+    { moduleCmds = return+        [ (command "tell")+            { help = say "tell <nick> <message>. When <nick> shows activity, tell them <message>."+            , process = doTell Tell . words+            }+        , (command "ask")+            { help = say "ask <nick> <message>. When <nick> shows activity, ask them <message>."+            , process = doTell Ask . words+            }+        , (command "messages")+            { help = say "messages. Check your messages, responding in private."+            , process = const (doMessages False)+            }+        , (command "messages-loud")+            { help = say "messages. Check your messages, responding in public."+            , process = const (doMessages True)+            }+        , (command "messages?")+            { help = say "messages?. Tells you whether you have any messages"+            , process = const $ do+                sender <- getSender+                ms <- getMessages sender+                case ms of+                    Just _ -> doRemind sender+                    Nothing   -> say "Sorry, no messages today."+            }+        , (command "clear-messages")+            { help = say "clear-messages. Clears your messages."+            , process = const $ do+                sender <- getSender+                clearMessages sender+                say "Messages cleared."+            }+        , (command "print-notices")+            { privileged = True+            , help = say "print-notices. Print the current map of notes."+            , process = const ((say . show) =<< readMS)+            }+        , (command "purge-notices")+            { privileged = True+            , help = say $+                "purge-notices [<nick> [<nick> [<nick> ...]]]]. "+                ++ "Clear all notes for specified nicks, or all notices if you don't "+                ++ "specify a nick."+            , process = \args -> do+                users <- mapM readNick (words args)+                if null users+                    then writeMS M.empty+                    else mapM_ clearMessages users+                say "Messages purged."+            }+        ]+    , moduleDefState  = return M.empty+    , moduleSerialize = Just mapSerial+    -- Hook onto contextual. Grab nicks of incoming messages, and tell them+    -- if they have any messages, if it's less than a day since we last did so.+    , contextual = const $ do+        sender <- getSender+        remp <- needToRemind sender+        if remp+            then doRemind sender+            else return ()+    }++-- | Take a note and the current time, then display it+showNote :: ClockTime -> Note -> Cmd Tell String+showNote time note = do+    sender <- showNick (getFreenodeNick (noteSender note))+    let diff    = time `diffClockTimes` noteTime note+        ago     = case timeDiffPretty diff of+                    [] -> "less than a minute"+                    pr -> pr+        action  = case noteType note of Tell -> "said"; Ask -> "asked"+    return $ printf "%s %s %s ago: %s" sender action ago (noteContents note)++-- | Is it less than a day since we last reminded this nick they've got messages?+needToRemind :: Nick -> Cmd Tell Bool+needToRemind n = do+  st  <- readMS+  now <- io getClockTime+  return $ case M.lookup (FreenodeNick n) st of+             Just (Just lastTime, _) ->+               let diff = now `diffClockTimes` lastTime+               in diff > TimeDiff 86400+             Just (Nothing,       _) -> True+             Nothing                 -> True++-- | Add a note to the NoticeBoard+writeDown :: Nick -> Nick -> String -> NoteType -> Cmd Tell ()+writeDown to from what ntype = do+  time <- io getClockTime+  let note = Note { noteSender   = FreenodeNick from,+                    noteContents = what,+                    noteTime     = time,+                    noteType     = ntype }+  modifyMS (M.insertWith (\_ (_, ns) -> (Nothing, ns ++ [note]))+                         (FreenodeNick to) (Nothing, [note]))++-- | Return a user's notes, or Nothing if they don't have any+getMessages :: Nick -> Cmd Tell (Maybe [Note])+getMessages sender = fmap (fmap snd . M.lookup (FreenodeNick sender)) readMS++-- | Clear a user's messages.+clearMessages :: Nick -> Cmd Tell ()+clearMessages sender = modifyMS (M.delete (FreenodeNick sender))++-- * Handlers+--++-- | Give a user their messages+doMessages :: Bool -> Cmd Tell ()+doMessages loud = do+    sender <- getSender+    msgs <- getMessages sender+    clearMessages sender++    let tellNote = if loud+            then say+            else lb . ircPrivmsg sender++    case msgs of+        Nothing -> say "You don't have any messages"+        Just mesgs -> do+            time <- io getClockTime+            mapM_ (showNote time >=> tellNote) mesgs++verb :: NoteType -> String+verb Ask = "ask"+verb Tell= "tell"++-- | Execute a @tell or @ask command.+doTell :: NoteType -> [String] -> Cmd Tell ()+doTell ntype []         = say ("Who should I " ++ verb ntype ++ "?")+doTell ntype (who:args) = do+    recipient <- readNick who+    sender <- getSender+    me <- getLambdabotName+    let rest = unwords args+        (record, res) | sender    == recipient   = (False, "You can " ++ verb ntype ++ " yourself!")+            | recipient == me          = (False, "Nice try ;)")+            | null args                = (False, "What should I " ++ verb ntype ++ " " ++ who ++ "?")+            | otherwise                = (True,  "Consider it noted.")+    when record (writeDown recipient sender rest ntype)+    say res++-- | Remind a user that they have messages.+doRemind :: Nick -> Cmd Tell ()+doRemind sender = do+    ms  <- getMessages sender+    now <- io getClockTime+    modifyMS (M.update (Just . first (const $ Just now)) (FreenodeNick sender))+    case ms of+        Just msgs -> do+           me <- showNick =<< getLambdabotName+           let (messages, pronoun)+                   | length msgs > 1   = ("messages", "them")+                   | otherwise         = ("message", "it")+               msg = printf "You have %d new %s. '/msg %s @messages' to read %s."+                       (length msgs) messages me pronoun+           lb (ircPrivmsg sender msg)+        Nothing -> return ()
+ src/Lambdabot/Plugin/Ticker.hs view
@@ -0,0 +1,134 @@+-- | Pull quotes down from yahoo.+module Lambdabot.Plugin.Ticker (theModule) where++import Lambdabot.Plugin+import Lambdabot.Util.Browser++import Control.Applicative+import Data.List+import Network.Browser (request)+import Network.HTTP+import Text.Printf++type Ticker = ModuleT () LB++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "ticker")+            { help = say "ticker symbols.  Look up quotes for symbols"+            , process = tickerCmd+            }+        , (command "bid")+            { help = say "bid symbols.  Sum up the bid and ask prices for symbols."+            , process = bidsCmd+            }+        ]+    }++------------------------------------------------------------------------++-- Fetch several ticker quotes and report them.+tickerCmd :: String -> Cmd Ticker ()+tickerCmd []        = say "Empty ticker."+tickerCmd tickers = do+    quotes <- getPage $ tickerUrl $ words tickers+    case [x | Just x <- map extractQuote quotes] of+      []       -> say "No Result Found."+      xs       -> mapM_ say xs++-- fetch: s symbol, l1 price, c change with percent, d1 date, t1 time.+tickerUrl :: [String] -> String+tickerUrl tickers =  "http://download.finance.yahoo.com/d/quotes.csv?f=sl1cd1t1&e=.csv&s=" ++ ts+    where ts = intercalate "+" $ map urlEncode tickers++-- $ curl "http://download.finance.yahoo.com/d/quotes.csv?f=sl1cd1t1&e=.csv&s=C"+-- "C",23.19,"-0.45 - -1.90%","5/13/2008","1:32pm"+-- "GBPUSD=X",1.9478,"N/A - N/A","5/13/2008","1:52pm"+extractQuote :: String -> Maybe String+extractQuote = getQuote . csv+    where+        getQuote [sym, price, change, date, time] =+            Just $ printf "%s: %s %s@ %s %s" sym price change' date time+            where change' = case words change of+                              ("N/A":_)    -> ""+                              [ch, _, pch] -> ch ++ " (" ++ pch ++ ") "+                              _            -> ""+        getQuote _ = Nothing++-- Fetch quotes for tickers and sum their bid/ask prices.+bidsCmd :: String -> Cmd Ticker ()+bidsCmd tickers =+    case words tickers of+        [] -> say (printf "Invalid argument '%s'" tickers)+        xs -> calcBids xs >>= say++-- fetch: b bid, a ask+bidsUrl :: [String] -> String+bidsUrl tickers = "http://download.finance.yahoo.com/d/quotes.csv?f=ba&e=.csv&s=" ++ ts+    where ts = intercalate "+" $ map urlEncode tickers++getBidAsks :: MonadLB m => [String] -> m [Maybe (Float, Float)]+getBidAsks tickers = do+    xs <- getPage $ bidsUrl tickers+    return $ map (extractPrice.csv) xs+    where+        extractPrice :: [String] -> Maybe (Float, Float)+        extractPrice [bid,ask] = liftA2 (,) (readMaybe bid) (readMaybe ask)+        extractPrice _         = Nothing++type AccumVal = Either String (Float, Float)++-- If we have a new bid/ask pair, accumulate it (normally add, but+-- if the ticker starts with '-' then subtract).  If there is no+-- value, make a note that it is an error.+accumOption :: AccumVal -> (String, Maybe (Float, Float)) -> AccumVal+accumOption err@(Left _) _ = err+accumOption (Right _) (ticker, Nothing) = Left $ printf "Can't find '%s'" ticker+accumOption (Right (a,b)) (('-':_), Just (a',b')) = Right (a-b', b-a')+accumOption (Right (a,b)) (_, Just (a',b')) = Right (a+a', b+b')++-- Take a list of tickers which are optionally prefixed with '+' or '-'+-- and add up (or subtract) the bid/ask prices on the based on the prefix.+calcBids :: MonadLB m => [String] -> m String+calcBids ticks = do+    xs <- getBidAsks $ map noPrefix ticks+    return $ case foldl accumOption (Right (0,0)) (zip ticks xs) of+        (Left err)        -> err+        (Right (bid,ask)) -> printf "%s: bid $%.02f, ask $%.02f" s bid ask+    where+        s = unwords ticks+        noPrefix ('+':xs) = xs+        noPrefix ('-':xs) = xs+        noPrefix xs = xs++-- | Fetch a page via HTTP and return its body as a list of lines.+getPage :: MonadLB m => String -> m [String]+getPage url = do+    let cleanup = (map (filter (/= '\r'))) . lines+    +    browseLB $ do+        (_, result) <- request (getRequest url)+        case rspCode result of+          (2,0,0) -> return (cleanup (rspBody result))+          (x,y,z) -> return ["Connection error: " ++ ([x,y,z] >>= show) ++ show (rspReason result)]++-- | Return a list of comma-separated values.+-- Quotes allowed in CSV if it's the first character of a field.+csv :: String -> [String]+csv ('"':xs) = case span (/= '"') xs of+                  (word, '"':',':rest) -> word : csv rest+                  (word, '"':[])       -> word : []+                  _                    -> error "invalid CSV"+csv xs = case span (/= ',') xs of+             (word, ',':rest) -> word : csv rest+             ([], [])         -> []+             (word, [])       -> [word]+             _                -> error "shouldn't happen"++-- | Read a value from a string.+readMaybe :: Read a => String -> Maybe a+readMaybe x = case readsPrec 0 x of+                [(y,"")] -> Just y+                _        -> Nothing+
+ src/Lambdabot/Plugin/Todo.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE PatternGuards #-}+-- | A todo list+--+-- (c) 2005 Samuel Bronson+module Lambdabot.Plugin.Todo (theModule) where++import Lambdabot.Compat.PackedNick+import Lambdabot.Plugin+import Control.Monad+import qualified Data.ByteString.Char8 as P++-- A list of key/elem pairs with an ordering determined by its position in the list+type TodoState = [(P.ByteString, P.ByteString)]+type Todo = ModuleT TodoState LB++theModule :: Module TodoState+theModule = newModule+    { moduleDefState  = return ([] :: TodoState)+    , moduleSerialize = Just assocListPackedSerial++    , moduleCmds = return+        [ (command "todo")+            { help = say "todo. List todo entries"+            , process = getTodo+            }+        , (command "todo-add")+            { help = say "todo-add <idea>. Add a todo entry"+            , process = addTodo+            }+        , (command "todo-delete")+            { privileged = True+            , help = say "todo-delete <n>. Delete a todo entry (for admins)"+            , process = delTodo+            }+        ]+    }++-- | Print todo list+getTodo :: String -> Cmd Todo ()+getTodo [] = readMS >>= sayTodo+getTodo _  = say "@todo has no args, try @todo-add or @list todo"++-- | Pretty print todo list+sayTodo :: [(P.ByteString, P.ByteString)] -> Cmd Todo ()+sayTodo [] = say "Nothing to do!"+sayTodo todoList = say . unlines =<< zipWithM fmtTodoItem ([0..] :: [Int]) todoList+    where+        fmtTodoItem n (idea, nick_) = do+            nick <- showNick (unpackNick nick_)+            return $ concat $+                [ show n,". ", nick ,": ",P.unpack idea ]++-- | Add new entry to list+addTodo :: String -> Cmd Todo ()+addTodo rest = do+    sender <- fmap packNick getSender+    modifyMS (++[(P.pack rest, sender)])+    say "Entry added to the todo list"++-- | Delete an entry from the list+delTodo :: String -> Cmd Todo ()+delTodo rest+    | Just n <- readM rest = say =<< withMS (\ls write -> case () of+          _ | null ls -> return "Todo list is empty"+            | n > length ls - 1 || n < 0+            -> return (show n ++ " is out of range")++            | otherwise -> do+                write (map snd . filter ((/= n) . fst) . zip [0..] $ ls)+                let (a,_) = ls !! n+                return ("Removed: " ++ P.unpack a))++    | otherwise = say "Syntax error. @todo <n>, where n :: Int"
+ src/Lambdabot/Plugin/Topic.hs view
@@ -0,0 +1,111 @@+-- | The Topic plugin is an interface for messing with the channel topic.+--   It can alter the topic in various ways and keep track of the changes.+--   The advantage of having the bot maintain the topic is that we get an+--   authoritative source for the current topic, when the IRC server decides+--   to delete it due to Network Splits.+module Lambdabot.Plugin.Topic (theModule) where++import Lambdabot.Plugin+import Lambdabot.Monad+import Lambdabot.IRC++import qualified Data.Map as M++import Control.Monad.State (gets)++type Topic = ModuleT () LB++type TopicAction = Nick -> String -> Cmd Topic ()+data TopicCommand = TopicCommand+    { _commandAliases    :: [String]+    , _commandHelp       :: String+    , _invokeCommand     :: TopicAction+    }++commands :: [TopicCommand]+commands =+    [ TopicCommand ["set-topic"]+      "Set the topic of the channel, without using all that listy stuff"+      (installTopic)+    , TopicCommand ["get-topic"]+      "Recite the topic of the channel"+      (reciteTopic)++    , TopicCommand ["unshift-topic", "queue-topic"]+      "Add a new topic item to the front of the topic list"+      (alterListTopic (:))+    , TopicCommand ["shift-topic"]+      "Remove a topic item from the front of the topic list"+      (alterListTopic (const tail))++    , TopicCommand ["push-topic"]+      "Add a new topic item to the end of the topic stack"+      (alterListTopic (\arg -> (++ [arg])))+    , TopicCommand ["pop-topic", "dequeue-topic"]+      "Pop an item from the end of the topic stack"+      (alterListTopic (const init))++    , TopicCommand ["clear-topic"]+      "Empty the topic stack"+      (alterListTopic (\_ _ -> []))+    ]++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command name)+            { help = say helpStr+            , aliases = aliases'+            , process = \args -> do+                tgt <- getTarget+                (chan, rest) <- case splitFirstWord args of+                        (c@('#':_), r)  -> do+                            c' <- readNick c+                            return (Just c', r)+                        _               -> case nName tgt of+                            ('#':_)         -> return (Just tgt, args)+                            _               -> return (Nothing, args)++                case chan of+                    Just chan' -> invoke chan' rest+                    Nothing    -> say "What channel?"+            }+        | TopicCommand (name:aliases') helpStr invoke <- commands+        ]+    }++------------------------------------------------------------------------+-- Topic action implementations++installTopic :: TopicAction+installTopic chan topic = withTopic chan $ \_ -> do+    lb (send (setTopic chan topic))++reciteTopic :: TopicAction+reciteTopic chan ""       = withTopic chan $ \topic -> do+    say (nName chan ++ ": " ++ topic)+reciteTopic _ ('#':_)     = say "One channel at a time.  Jeepers!"+reciteTopic _ _           = say "I don't know what all that extra stuff is about."++alterTopic :: (String -> String -> String) -> TopicAction+alterTopic f chan args = withTopic chan $ \oldTopic -> do+    lb (send (setTopic chan (f args oldTopic)))++alterListTopic :: (String -> [String] -> [String]) -> TopicAction+alterListTopic f = alterTopic $ \args topic -> show $ case reads topic of+    [(xs, "")]  -> f args xs+    _           -> f args [topic]++------------------------------------------------------------------------++lookupTopic :: Nick -> LB (Maybe String)+lookupTopic chan = gets (\s -> M.lookup (mkCN chan) (ircChannels s))++-- | 'withTopic' is like 'lookupTopic' except that it ditches the Maybe in+--   favor of just yelling at the user when things don't work out as planned.+withTopic :: Nick -> (String -> Cmd Topic ()) -> Cmd Topic ()+withTopic chan f = do+    maybetopic <- lb (lookupTopic chan)+    case maybetopic of+        Just t  -> f t+        Nothing -> say "I don't know that channel."
+ src/Lambdabot/Plugin/Type.hs view
@@ -0,0 +1,150 @@+{-# 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.Type (theModule, query_ghci) where++import Lambdabot.Plugin++import Lambdabot.Plugin.Eval (exts)++import Data.Char+import Data.Maybe+import System.Process+import Text.Regex.TDFA++theModule :: Module ()+theModule = 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 = \text ->+        let (prefix, expr) = splitAt 3 text+        in case prefix of+            ":t " -> runit ":t" expr+            ":k " -> runit ":k" expr+            _     -> return ()+    }++runit :: MonadLB m =>+         String -> String -> Cmd m ()+runit s expr = query_ghci s expr >>= 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 cmd foo = cmd ++ " " ++ foo++--     into GHCi and send any line matching++signature_regex :: Regex+signature_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 []          = []+stripComments ('\n':_)    = [] -- drop any newwline and rest. *security*+stripComments ('-':'-':_) = []  --+stripComments ('{':'-':cs)= stripComments (go 1 cs)+stripComments (c:cs)      = c : stripComments cs++-- Adapted from ghc/compiler/parser/Lexer.x+go :: Int -> String -> String+go 0 xs         = xs+go _ ('-':[])   = []   -- unterminated+go n ('-':x:xs)+    | x == '}'  = go (n-1) xs+    | otherwise = go n (x:xs)+go _ ('{':[])   = []  -- unterminated+go n ('{':x:xs)+    | x == '-'  = go (n+1) xs+    | otherwise = go n (x:xs)+go n (_:xs) = go n 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 output+        = fmap reverse . removeExp . reverse .+          unwords . map (dropWhile isSpace . expandTab 8) .+          mapMaybe ((>>= last') . fmap mrSubList . matchM signature_regex) .+          lines $ output+        where+        last' [] = Nothing+        last' xs = Just $ last xs++        removeExp :: String -> Maybe String+        removeExp [] = Nothing+        removeExp xs = removeExp' 0 xs++        removeExp' :: Int -> String -> Maybe String+        removeExp' 0 (' ':':':':':' ':_) = Just []+        removeExp' n ('(':xs)            = ('(':) `fmap` removeExp' (n+1) xs+        removeExp' n (')':xs)            = (')':) `fmap` removeExp' (n-1) xs+        removeExp' n (x  :xs)            = (x  :) `fmap` removeExp'  n    xs+        removeExp' _ []                  = Nothing++--+--     With this the command handler can be easily defined using readProcessWithExitCode:+--+query_ghci :: MonadLB m => String -> String -> m String+query_ghci cmd expr = do+    l <- lb $ findOrCreateLBFile "L.hs"+    let context = ":load "++l++"\n:m *L\n" -- using -fforce-recomp to make sure we get *L in scope instead of just L+        extFlags = ["-X" ++ ext | ext <- exts]+    ghci <- getConfig ghciBinary+    (_, output, errors) <- io $ readProcessWithExitCode ghci+        ("-v0":"-fforce-recomp":"-iState":extFlags)+        (context ++ theCommand cmd (stripComments expr))+    let ls = extract_signatures output+    return $ case ls of+               Nothing -> unlines . take 3 . filter (not . null) . map cleanRE2 .+                          lines . expandTab 8 . cleanRE . filter (/='\r') $ errors -- "bzzt"+               Just t -> t++    where+        cleanRE, cleanRE2 :: String -> String+        cleanRE s+            |           s =~  notfound  = "Couldn\'t find qualified module."+            | Just m <- s =~~ ghci_msg  = mrAfter m+            | otherwise                 = s+        cleanRE2 s+            | Just m <- s =~~ ghci_msg  = mrAfter m+            | otherwise                 = s+        ghci_msg = "<interactive>:[^:]*:[^:]*: ?"+        notfound = "Failed to load interface"
+ src/Lambdabot/Plugin/UnMtl.hs view
@@ -0,0 +1,179 @@+----------------------------------------------------------------------+-- |+-- Module      : Plugin.UnMtl+-- Copyright   : Don Stewart, Lennart Kolmodin 2007, Twan van Laarhoven 2008+-- License     : GPL-style (see LICENSE)+--+-- Unroll the MTL monads with your favorite bot!+--+----------------------------------------------------------------------++module Lambdabot.Plugin.UnMtl (theModule) where++import Lambdabot.Plugin+import qualified Lambdabot.Plugin as Lmb (Module)+import Lambdabot.Util.Parser (prettyPrintInLine)++import Control.Monad+import Language.Haskell.Exts as Hs hiding (tuple, var)++theModule :: Lmb.Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "unmtl")+            { help = say "unroll mtl monads"+            , process = say . either ("err: "++) prettyPrintInLine . mtlParser+            }+        ]+    }++-----------------------------------------------------------+-- 'PType' wrapper type++data PMonad a = PMonad+       { pResult :: a                      -- The result (trsnsformed type)+       , pError  :: Maybe String           -- An error message?+       , pFun    :: Maybe (PType -> PType) -- A type function+       }++type PType = PMonad Type++-- A monad instance so we get things like liftM and sequence for free+instance Monad PMonad where+    return t = PMonad t Nothing Nothing+    m >>= g  = let x = g (pResult m)+               in PMonad (pResult x) (pError m `mplus` pError x) Nothing++-----------------------------------------------------------+-- Lifiting function types++type P = PType++lift0 :: P                            -> Type -> P+lift1 :: (P -> P)                     -> Type -> P+lift2 :: (P -> P -> P)                -> Type -> P+lift3 :: (P -> P -> P -> P)           -> Type -> P+lift4 :: (P -> P -> P -> P -> P)      -> Type -> P+lift5 :: (P -> P -> P -> P -> P -> P) -> Type -> P++lift0 f _ = f+lift1 f n = mkPfun n (lift0 . f)+lift2 f n = mkPfun n (lift1 . f)+lift3 f n = mkPfun n (lift2 . f)+lift4 f n = mkPfun n (lift3 . f)+lift5 f n = mkPfun n (lift4 . f)++mkPfun :: Type -> (PType -> Type -> PType) -> PType+mkPfun n cont = PMonad n (Just msg) (Just fun)+  where fun p = cont p (TyApp n (pResult p))+        msg = "`" ++ prettyPrintInLine n ++ "' is not applied to enough arguments" ++ full fun ['A'..'Z'] "/\\"+        full p (x:xs) l = case p (con [x]) of+                   PMonad{pFun    = Just p'} -> full p' xs l'+                   PMonad{pError  = Just _}  -> "."+                   PMonad{pResult = t }      -> ", giving `" ++ init l' ++ ". " ++ prettyPrintInLine t ++ "'"+          where l' = l ++ [x] ++ " "+        full _ [] _ = error "UnMtl plugin error: ampty list"++-----------------------------------------------------------+-- Helpers for constructing types++infixr 5 -->+infixl 6 $$++-- Function type+(-->) :: PType -> PType -> PType+a --> b = liftM2 cu a b++cu :: Type -> Type -> Type+cu (TyTuple _ xs) y = foldr TyFun y xs+cu a b = TyFun a b++-- Type application:+--   If we have a type function, use that+--   Otherwise use TyApp, but check for stupid errors+($$) :: PType -> PType -> PType+($$) PMonad{ pFun=Just f } x = f x+($$) f x = PMonad+         { pResult = TyApp (pResult f) (pResult x)+         , pError  = pError f `mplus` -- ignore errors in x, the type constructor f might have a higher kind and ignore x+                      if isFunction (pResult f) then Nothing else+                            Just $ "`" ++ prettyPrintInLine (pResult f) ++ "' is not a type function."+         , pFun    = Nothing+         }+  where+    isFunction (TyFun _ _) = False+    isFunction (TyTuple _ _) = False+    isFunction _             = True++con, var :: String -> PType+con = return . TyCon . UnQual . Ident+var = return . TyVar . Ident++tuple :: [PType] -> PType+tuple = liftM (TyTuple Boxed . concatMap unpack) . sequence+    where+    unpack (TyTuple _ xs) = xs+    unpack x = [x]++-- a bit of a hack+forall_ :: String -> (PType -> PType) -> PType+forall_ x f = var ("forall "++x++".") $$ f (var x)++-----------------------------------------------------------+-- Definitions from the MTL library++-- MTL types (plus MaybeT)+types :: [(String, Type -> PType)]+types =+    [ ("Cont",     lift2 $ \r       a -> (a -->      r) -->      r)+    , ("ContT",    lift3 $ \r     m a -> (a --> m $$ r) --> m $$ r)+    , ("ErrorT",   lift3 $ \e     m a -> m $$ (con "Either" $$ e $$ a))+    , ("Identity", lift1 $ \        a -> a)+    , ("ListT",    lift2 $ \      m a -> m $$ (return list_tycon $$ a))+    , ("RWS",      lift4 $ \r w s   a -> r --> s -->      tuple [a, s, w])+    , ("RWST",     lift5 $ \r w s m a -> r --> s --> m $$ tuple [a, s, w])+    , ("Reader",   lift2 $ \r       a -> r -->            a)+    , ("ReaderT",  lift3 $ \r     m a -> r -->       m $$ a)+    , ("Writer",   lift2 $ \  w     a ->                  tuple [a,    w])+    , ("WriterT",  lift3 $ \  w   m a ->             m $$ tuple [a,    w])+    , ("State",    lift2 $ \    s   a ->       s -->      tuple [a, s   ])+    , ("StateT",   lift3 $ \    s m a ->       s --> m $$ tuple [a, s   ])+    -- very common:+    , ("MaybeT",   lift2 $ \      m a -> m $$ (con "Maybe" $$ a))+    -- from the Haskell wiki+    , ("Rand",     lift2 $ \g       a -> g -->      tuple [a, g])+    , ("RandT",    lift3 $ \g     m a -> g --> m $$ tuple [a, g])+    , ("NonDet",   lift1 $ \        a -> forall_ "b" $ \b -> (a --> b --> b) --> b --> b)+    , ("NonDetT",  lift2 $ \      m a -> forall_ "b" $ \b -> (a --> m $$ b --> m $$ b) --> m $$ b --> m $$ b)+    ]++--------------------------------------------------+-- Parsing of types++mtlParser :: String -> Either String Type+mtlParser input = do+    Hs.Module _ _ _ _ _ _ decls <- liftE $ parseModule ("type X = "++input++"\n")+    hsType <- case decls of+        (TypeDecl _ _ _ hsType:_) -> return hsType+        _ -> fail "No parse?"+    let result = mtlParser' hsType+    case pError result of+        Just e  -> fail e+        Nothing -> return (pResult result)+  where+    liftE (ParseOk a) = return a+    liftE (ParseFailed _src str) = fail str++mtlParser' :: Type -> PType+mtlParser' t@(TyCon (UnQual (Ident v))) = case lookup v types of+     Just pt -> pt t+     Nothing -> return t+mtlParser' (TyApp a b) = mtlParser' a $$ mtlParser' b+mtlParser' t = return t++-----------------------------------------------------------+-- Examples+--+-- ContT ByteString (StateT s IO) a+-- StateT s (ContT ByteString IO) a+-- ErrorT ByteString (WriterT String (State s)) a
+ src/Lambdabot/Plugin/Undo.hs view
@@ -0,0 +1,126 @@+-- Copyright (c) 2006 Spencer Janssen+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++module Lambdabot.Plugin.Undo (theModule) where++import Lambdabot.Plugin+import Lambdabot.Util.Parser (withParsed)++import Control.Monad+import Data.Generics+import qualified Data.Set as Set+import Language.Haskell.Exts.Syntax hiding (Module)++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "undo")+            { help = say "undo <expr>\nTranslate do notation to Monad operators."+            , process = say . transform undo+            }+        , (command "do")+            { help = say "do <expr>\nTranslate Monad operators to do notation."+            , process = say . transform do'+            }+        ]+    }++findVar :: Data a => a -> String+findVar e = head $ do+    i <- [0 ..]+    x <- ['a' .. 'z']+    let xi = x : replicate i '\''+    guard $ not $ Set.member xi s+    return xi+ where s = Set.fromList $ listify (const True :: String -> Bool) e++transform :: (String -> Exp -> Exp) -> String -> String+transform f = withParsed $ \e -> everywhere (mkT . f . findVar $ e) e++undo :: String -> Exp -> Exp+undo v (Do stms) = f stms+ where+    f [Qualifier e]          = e+    f (Qualifier e     : xs) = infixed e ">>" $ f xs+    f (LetStmt   ds    : xs) = Let ds $ f xs+    f (Generator s p e : xs)+        | irrefutable p = infixed e ">>=" $ Lambda s [p] $ f xs+        | otherwise     = infixed e ">>=" $+                            Lambda s [pvar v] $+                                Case (var v)+                                    [ alt p (f xs)+                                    , alt PWildCard $+                                        App+                                            (var "fail")+                                            (Lit $ String "")+                                    ]+        where alt pat x = Alt s pat (UnGuardedAlt x) (BDecls [])+    f _ = error "Undo plugin error: can't undo!"+undo v (ListComp e stms) = f stms+ where+    f []                                = List [e]+    f (QualStmt (Qualifier g    ) : xs) = If g (f xs) nil+    f (QualStmt (LetStmt   ds   ) : xs) = Let ds $ f xs+    f (QualStmt (Generator s p l) : xs)+        | irrefutable p = concatMap' $ Lambda s [p] $ f xs+        | otherwise     = concatMap' $+                            Lambda s [pvar v] $+                                Case (var v)+                                    [ alt p (f xs)+                                    , alt PWildCard nil+                                    ]+        where alt pat x = Alt s pat (UnGuardedAlt x) (BDecls [])+              concatMap' fun = App (App (var "concatMap") (Paren fun)) l+    f _ = error "Undo plugin error: can't undo!"+undo _ x           = x++irrefutable :: Pat -> Bool+irrefutable (PVar _)     = True+irrefutable (PIrrPat _)  = True+irrefutable PWildCard    = True+irrefutable (PAsPat _ p) = irrefutable p+irrefutable (PParen p)   = irrefutable p+irrefutable (PTuple ps)  = all irrefutable ps+irrefutable _              = False++infixed :: Exp -> String -> Exp -> Exp+infixed l o r = InfixApp l (QVarOp $ UnQual $ Symbol o) r++nil :: Exp+nil = Var list_tycon_name++var :: String -> Exp+var = Var . UnQual . Ident++pvar :: String -> Pat+pvar = PVar . Ident++do' :: String -> Exp -> Exp+do' _ (Let ds (Do s)) = Do (LetStmt ds : s)+do' v e@(InfixApp l (QVarOp (UnQual (Symbol op))) r) =+     case op of+         ">>=" ->+             case r of+                 (Lambda loc [p] (Do stms)) -> Do (Generator loc p l : stms)+                 (Lambda loc [PVar v1] (Case (Var (UnQual v2))+                                            [ Alt _ p (UnGuardedAlt s) (BDecls [])+                                            , Alt _ PWildCard (UnGuardedAlt (App (Var (UnQual (Ident "fail"))) _)) (BDecls [])+                                            ]))+                           | v1 == v2           -> case s of+                                                       Do stms -> Do (Generator loc p l : stms)+                                                       _         -> Do [Generator loc p l, Qualifier s]+                 (Lambda loc [p] s)           -> Do [Generator loc p l, Qualifier s]+                 _ -> Do [ Generator undefined (pvar v) l+                           , Qualifier . app r $ var v]+         ">>" ->+             case r of+                 (Do stms) -> Do (Qualifier l : stms)+                 _           -> Do [Qualifier l, Qualifier r]+         _    -> e+do' _ x = x++-- | 'app' is a smart constructor that inserts parens when the first argument+-- is an infix application.+app :: Exp -> Exp -> Exp+app e@(InfixApp {}) f = App (Paren e) f+app e                 f = App e f
+ src/Lambdabot/Plugin/Unlambda.hs view
@@ -0,0 +1,31 @@+-- Copyright (c) 2006 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)+--+-- | A plugin for the Haskell interpreter for the unlambda language+--+-- http://www.madore.org/~david/programs/unlambda/+module Lambdabot.Plugin.Unlambda (theModule) where++import Lambdabot.Plugin+import Lambdabot.Util.Process+import Text.Regex.TDFA++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "unlambda")+            { help = say "unlambda <expr>. Evaluate an unlambda expression"+            , process = \msg -> do+                binary <- getConfig unlambdaBinary+                ios80 (run binary msg scrub)+            }+        ]+    }++scrub :: String -> String+scrub = unlines . take 6 . map (' ':) . lines . cleanit++cleanit :: String -> String+cleanit s | s =~ terminated = "Terminated\n"+          | otherwise       = s+    where terminated = "waitForProc"
+ src/Lambdabot/Plugin/Url.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE PatternGuards #-}+-- | Fetch URL page titles of HTML links.+module Lambdabot.Plugin.Url (theModule) where++import Lambdabot.Plugin+import Lambdabot.Util.Browser++import Control.Monad+import Control.Monad.Trans+import Data.List+import Data.Maybe+import Network.Browser+import Network.HTTP+import Text.Regex.TDFA++theModule :: Module Bool+theModule = newModule+    { moduleCmds = return+        [ (command "url-title")+            { help = say "url-title <url>. Fetch the page title."+            , process =+                  maybe (say "Url not valid.") (mbSay <=< fetchTitle)+                . containsUrl+            }+        , (command "tiny-url")+            { help = say "tiny-url <url>. Shorten <url>."+            , process =+                  maybe (say "Url not valid.") (mbSay <=< fetchTiny)+                . containsUrl+            }+        , (command "url-on")+            { privileged = True+            , help = say "url-on: enable automatic URL summaries"+            , process = const $ do+                writeMS True+                say "Url enabled"+            }+        , (command "url-off")+            { privileged = True+            , help = say "url-off: disable automatic URL summaries"+            , process = const $ do+                writeMS False+                say "Url disabled"+            }+        ]+    , moduleDefState              = return True -- url on+    , moduleSerialize             = Just stdSerial++    , contextual = \text -> do+      alive <- lift readMS+      if alive && (not $ areSubstringsOf ignoredStrings text)+        then case containsUrl text of+               Nothing  -> return ()+               Just url+                 | length url > 60 -> do+                     title <- fetchTitle url+                     tiny  <- fetchTiny  url+                     say (intercalate ", " (catMaybes [title, tiny]))+                 | otherwise -> mbSay =<< fetchTitle url+        else return ()+    }++mbSay :: Maybe String -> Cmd (ModuleT Bool LB) ()+mbSay = maybe (return ()) say++------------------------------------------------------------------------++-- | The string that I prepend to the quoted page title.+urlTitlePrompt :: String+urlTitlePrompt = "Title: "++-- | Fetch the title of the specified URL.+fetchTitle :: MonadLB m => String -> m (Maybe String)+fetchTitle url = fmap (fmap (urlTitlePrompt ++)) (browseLB (urlPageTitle url))++-- | base url for fetching tiny urls+tinyurl :: String+tinyurl = "http://tinyurl.com/api-create.php?url="++-- | Fetch the title of the specified URL.+fetchTiny :: MonadLB m => String -> m (Maybe String)+fetchTiny url = do+    (_, response) <- browseLB (request (getRequest (tinyurl ++ url)))+    case rspCode response of+      (2,0,0) -> return $ findTiny (rspBody response)+      _       -> return Nothing++-- | Tries to find the start of a tinyurl+findTiny :: String -> Maybe String+findTiny text = do+    mr <- matchM begreg text+    let kind = mrMatch mr+        rest = mrAfter mr+        url = takeWhile (/=' ') rest+    return $ stripSuffixes ignoredUrlSuffixes $ kind ++ url+    where+        begreg :: Regex+        begreg = makeRegexOpts opts defaultExecOpt "http://tinyurl.com/"+        opts = defaultCompOpt {caseSensitive = False}++-- | List of strings that, if present in a contextual message, will+-- prevent the looking up of titles.  This list can be used to stop+-- responses to lisppaste for example.  Another important use is to+-- another lambdabot looking up a url title that contains another+-- url in it (infinite loop).  Ideally, this list could be added to+-- by an admin via a privileged command (TODO).+ignoredStrings :: [String]+ignoredStrings =+    ["paste",                -- Ignore lisppaste, rafb.net+     "cpp.sourcforge.net",   -- C++ paste bin+     "HaskellIrcPastePage",  -- Ignore paste page+     "title of that page",   -- Ignore others like the old me+     urlTitlePrompt]         -- Ignore others like me++-- | Suffixes that should be stripped off when identifying URLs in+-- contextual messages.  These strings may be punctuation in the+-- current sentence vs part of a URL.  Included here is the NUL+-- character as well.+ignoredUrlSuffixes :: [String]+ignoredUrlSuffixes = [".", ",", ";", ")", "\"", "\1", "\n"]++-- | Searches a string for an embeddded URL and returns it.+containsUrl :: String -> Maybe String+containsUrl text = do+    mr <- matchM begreg text+    let kind = mrMatch mr+        rest = mrAfter mr+        url = takeWhile (`notElem` " \n\t\v") rest+    return $ stripSuffixes ignoredUrlSuffixes $ kind ++ url+    where+        begreg = makeRegexOpts opts defaultExecOpt "https?://"+        opts = defaultCompOpt { caseSensitive = False }++-- | Utility function to remove potential suffixes from a string.+-- Note, once a suffix is found, it is stripped and returned, no other+-- suffixes are searched for at that point.+stripSuffixes :: [String] -> String -> String+stripSuffixes []   str   = str+stripSuffixes (s:ss) str+    | isSuffixOf s str   = take (length str - length s) $ str+    | otherwise          = stripSuffixes ss str+++-- | Utility function to check of any of the Strings in the specified+-- list are substrings of the String.+areSubstringsOf :: [String] -> String -> Bool+areSubstringsOf = flip (any . flip isSubstringOf)+    where+      isSubstringOf s str = any (isPrefixOf s) (tails str)
+ src/Lambdabot/Plugin/Version.hs view
@@ -0,0 +1,23 @@+-- Copyright (c) 2005-6 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++-- | Lambdabot version information+module Lambdabot.Plugin.Version (theModule) where++import Lambdabot.Plugin+import Paths_lambdabot (version)+import Data.Version (showVersion)++theModule :: Module ()+theModule = newModule+    { moduleCmds = return+        [ (command "version")+            { help = say $+                "version/source. Report the version " +++                "and git repo of this bot"+            , process = const $ do+                say $ "lambdabot " ++ showVersion version+                say "git clone git://github.com/mokus0/lambdabot.git"+            }+        ]+    }
+ src/Lambdabot/Plugin/Vixen.hs view
@@ -0,0 +1,96 @@+-- | Talk to hot chixxors.++-- (c) Mark Wotton+-- Serialisation (c) 2007 Don Stewart++module Lambdabot.Plugin.Vixen (theModule) where++import Lambdabot.Plugin++import Control.Arrow ((***))+import Control.Monad+import Data.Binary+import qualified Data.ByteString.Char8 as P+import System.Directory+import Text.Regex.TDFA++theModule :: Module (Bool, String -> IO [Char])+theModule = newModule+    { moduleCmds = return+        [ (command "vixen")+            { help = say "vixen <phrase>. Sergeant Curry's lonely hearts club"+            , process = \txt -> say =<< io . ($ txt) . snd =<< readMS+            }+        , (command "vixen-on")+            { privileged = True+            , help = do+                me <- showNick =<< getLambdabotName+                say ("vixen-on: turn " ++ me ++ " into a chatterbot")+            , process = const $ do+                modifyMS $ \(_,r) -> (True, r)+                say "What's this channel about?"+            }+        , (command "vixen-off")+            { privileged = True+            , help = do+                me <- showNick =<< getLambdabotName+                say ("vixen-off: shut " ++ me ++ "up")+            , process = const $ do+                modifyMS $ \(_,r) -> (False, r)+                say "Bye!"+            }+        ]++    -- if vixen-chat is on, we can just respond to anything+    , contextual = \txt -> do+        (alive, k) <- readMS+        if alive then io (k txt) >>= say+                 else return ()++    , moduleDefState = return (False, const (return "<undefined>"))++    -- suck in our (read only) regex state from disk+    -- compile it, and stick it in the plugin state+    , moduleInit = do+        vixenFile <- lb (findOrCreateLBFile "vixen")+        b <- io (doesFileExist vixenFile)+        when b $ do+            st <- io (decodeFile vixenFile)+            let compiled = map (makeRegex *** id) (st :: [(String, WTree)])+                s = vixen (mkResponses compiled)+            modifyMS $ \(v,_) -> (v, s)+    }++------------------------------------------------------------------------++vixen :: (String -> WTree) -> String -> IO String+vixen k key = P.unpack `fmap` randomW (k key)++randomW :: WTree -> IO P.ByteString+randomW (Leaf a)  = return a+randomW (Node ls) = random ls >>= randomW++mkResponses :: RChoice -> String -> WTree+mkResponses choices them = (\((_,wtree):_) -> wtree) $+    filter (\(reg,_) -> match reg them) choices++------------------------------------------------------------------------+-- serialisation for the vixen state+--+-- The tree of regexes and responses is written in binary form to+-- State/vixen, and we suck it in on module init, then lazily regexify it all++data WTree = Leaf !P.ByteString | Node ![WTree]+             deriving Show++instance Binary WTree where+    put (Leaf s)  = putWord8 0 >> put s+    put (Node ls) = putWord8 1 >> put ls+    get = do+        tag <- getWord8+        case tag of+            0 -> liftM Leaf get+            1 -> liftM Node get+            _ -> error "Vixen plugin error: unknown tag"++type RChoice = [(Regex, WTree)] -- compiled choices
+ src/Lambdabot/Plugin/Where.hs view
@@ -0,0 +1,73 @@+-- |+-- Module    : Where+-- Copyright : 2003 Shae Erisson+--+-- License:     lGPL+--+-- Slightly specialised version of Where for associating projects with their urls.+-- Code almost all copied.+module Lambdabot.Plugin.Where (theModule) where++import Lambdabot.Plugin+import qualified Data.ByteString.Char8 as P+import Data.Char+import qualified Data.Map as M++type WhereState         = M.Map P.ByteString P.ByteString+type WhereWriter        = WhereState -> Cmd Where ()+type Where              = ModuleT WhereState LB++theModule :: Module (M.Map P.ByteString P.ByteString)+theModule = newModule+    { moduleDefState  = return M.empty+    , moduleSerialize = Just mapPackedSerial++    , moduleCmds = return+        [ (command "where")+            { help = say "where <key>. Return element associated with key"+            , process = doCmd "where"+            }+        , (command "url")+            { help = say "url <key>. Return element associated with key"+            , process = doCmd "url"+            }+        , (command "what")+            { help = say "what <key>. Return element associated with key"+            , process = doCmd "what"+            }+        , (command "where+")+            { help = say "where+ <key> <elem>. Define an association"+            , process = doCmd "where+"+            }+        ]+    }++doCmd :: String -> String -> Cmd Where ()+doCmd cmd rest = (say =<<) . withMS $ \factFM writer ->+    case words rest of+        []         -> return "@where <key>, return element associated with key"+        (fact:dat) -> processCommand factFM writer+                            (map toLower fact) cmd (unwords dat)++------------------------------------------------------------------------++processCommand :: WhereState -> WhereWriter+               -> String -> String -> String -> Cmd Where String++processCommand factFM writer fact cmd dat = case cmd of+        "where"     -> return $ getWhere factFM fact+        "what"      -> return $ getWhere factFM fact -- an alias+        "url"       -> return $ getWhere factFM fact -- an alias+        "where+"    -> updateWhere True factFM writer fact dat+        _           -> return "Unknown command."++getWhere :: WhereState -> String -> String+getWhere fm fact =+    case M.lookup (P.pack fact) fm of+        Nothing -> "I know nothing about " ++ fact ++ "."+        Just x  -> P.unpack x++updateWhere :: Bool -> WhereState -> WhereWriter -> String -> String -> Cmd Where String+updateWhere _guard factFM writer fact dat = do+        writer $ M.insert (P.pack fact) (P.pack dat) factFM+        random confirmation
+ src/Lambdabot/State.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-- | Support for the LB (LambdaBot) monad+module Lambdabot.State+    ( -- ** Functions to access the module's state+      MonadLBState(..)+    , readMS+    , writeMS+    , modifyMS+    +    -- ** Utility functions for modules that need state for each target.+    , GlobalPrivate -- (global)+    , mkGlobalPrivate+    +    , withPS+    , readPS+    , writePS+    +    , withGS+    , readGS+    , writeGS+    +    -- ** Handling global state+    , flushModuleState+    , readGlobalState+    , writeGlobalState+  ) where++import Lambdabot.File+import Lambdabot.Logging+import Lambdabot.Monad+import Lambdabot.Module+import Lambdabot.Nick+import Lambdabot.Command+import Lambdabot.Util+import Lambdabot.Util.Serial++import Control.Concurrent.Lifted+import Control.Exception.Lifted as E+import Control.Monad.Trans+import Control.Monad.Trans.Control+import qualified Data.ByteString.Char8 as P+import Data.IORef.Lifted++-- | Thread-safe modification of an MVar.+withMWriter :: MonadBaseControl IO m => MVar a -> (a -> (a -> m ()) -> m b) -> m b+withMWriter mvar f = bracket+  (do x <- takeMVar mvar; ref <- newIORef x; return (x,ref))+  (\(_,ref) -> tryPutMVar mvar =<< readIORef ref)+  (\(x,ref) -> f x $ writeIORef ref)++class MonadLB m => MonadLBState m where+    type LBState m+    +    -- | Update the module's private state.+    -- This is the preferred way of changing the state. The state will be locked+    -- until the body returns. The function is exception-safe, i.e. even if+    -- an error occurs or the thread is killed (e.g. because it deadlocked and+    -- therefore exceeded its time limit), the state from the last write operation+    -- will be restored. If the writer escapes, calling it will have no observable+    -- effect.+    -- @withMS@ is not composable, in the sense that a readMS from within the body+    -- will cause a dead-lock. However, all other possibilies to access the state+    -- that came to my mind had even more serious deficiencies such as being prone+    -- to race conditions or semantic obscurities.+    withMS :: (LBState m -> (LBState m -> m ()) -> m a) -> m a++instance MonadLB m => MonadLBState (ModuleT st m) where+    type LBState (ModuleT st m) = st+    withMS f = do+        ref <- getRef+        withMWriter ref f++instance MonadLBState m => MonadLBState (Cmd m) where+    type LBState (Cmd m) = LBState m+    withMS f = do+        x <- liftWith $ \run -> +            withMS $ \st wr -> +                run (f st (lift . wr))+        restoreT (return x)++-- | Read the module's private state.+readMS :: MonadLBState m => m (LBState m)+readMS = withMS (\st _ -> return st)++-- | Modify the module's private state.+modifyMS :: MonadLBState m => (LBState m -> LBState m) -> m ()+modifyMS f = withMS $ \st wr -> wr (f st)++-- | Write the module's private state. Try to use withMS instead.+writeMS :: MonadLBState m => LBState m -> m ()+writeMS = modifyMS . const++-- | This datatype allows modules to conviently maintain both global+--   (i.e. for all clients they're interacting with) and private state.+--   It is implemented on top of readMS\/withMS.+--+-- This simple implementation is linear in the number of private states used.+data GlobalPrivate g p = GP {+  global :: !g,+  private :: ![(Nick,MVar (Maybe p))],+  maxSize :: Int+}++-- | Creates a @GlobalPrivate@ given the value of the global state. No private+--   state for clients will be created.+mkGlobalPrivate :: Int -> g -> GlobalPrivate g p+mkGlobalPrivate ms g = GP {+  global = g,+  private = [],+  maxSize = ms+}++-- Needs a better interface. The with-functions are hardly useful.+-- | Writes private state. For now, it locks everything.+withPS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)+  => Nick  -- ^ The target+  -> (Maybe p -> (Maybe p -> LB ()) -> LB a)+    -- ^ @Just x@ writes x in the user's private state, @Nothing@ removes it.+  -> m a+withPS who f = do+  mvar <- accessPS return id who+  lb $ withMWriter mvar f++-- | Reads private state.+readPS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)+  => Nick -> m (Maybe p)+readPS = accessPS (liftIO . readMVar) (\_ -> return Nothing)++-- | Reads private state, executes one of the actions success and failure+-- which take an MVar and an action producing a @Nothing@ MVar, respectively.+accessPS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)+  => (MVar (Maybe p) -> m a) -> (m (MVar (Maybe p)) -> m a)+  -> Nick+  -> m a+accessPS success failure who = withMS $ \state writer ->+  case lookup who $ private state of+    Just mvar -> do+      let newPrivate = (who,mvar):+            filter ((/=who) . fst) (private state)+      length newPrivate `seq` writer (state { private = newPrivate })+      success mvar+    Nothing -> failure $ do+      mvar <- liftIO $ newMVar Nothing+      let newPrivate = take (maxSize state) $ (who,mvar): private state+      length newPrivate `seq` writer (state { private = newPrivate })+      return mvar++-- | Writes global state. Locks everything+withGS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)+  => (g -> (g -> m ()) -> m ()) -> m ()+withGS f = withMS $ \state writer ->+  f (global state) $ \g -> writer $ state { global = g }++-- | Reads global state.+readGS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)+  => m g+readGS = fmap global readMS+++-- The old interface, as we don't wanna be too fancy right now.+writePS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)+  => Nick -> Maybe p -> m ()+writePS who x = withPS who (\_ writer -> writer x)++writeGS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)+  => g -> m ()+writeGS g = withGS (\_ writer -> writer g)++-- ---------------------------------------------------------------------+--+-- Handling global state+--++-- | flush state of modules+flushModuleState :: LB ()+flushModuleState = withAllModules (\m -> getModuleName >>= writeGlobalState m)++-- | Peristence: write the global state out+writeGlobalState :: Module st -> String -> ModuleT st LB ()+writeGlobalState module' name = do+    debugM ("saving state for module " ++ show name)+    case moduleSerialize module' of+        Nothing  -> return ()+        Just ser -> do+            state' <- readMS+            case serialize ser state' of+                Nothing  -> return ()   -- do not write any state+                Just out -> do+                    stateFile <- lb (findOrCreateLBFile name)+                    io (P.writeFile stateFile out)++-- | Read it in+readGlobalState :: Module st -> String -> LB (Maybe st)+readGlobalState module' name = do+    debugM ("loading state for module " ++ show name)+    case moduleSerialize module' of+        Just ser -> do+            mbStateFile <- findLBFile name+            case mbStateFile of+                Nothing         -> return Nothing+                Just stateFile  -> io $ do+                    state' <- Just `fmap` P.readFile stateFile `E.catch` \SomeException{} -> return Nothing+                    E.catch (evaluate $ maybe Nothing (Just $!) (deserialize ser =<< state')) -- Monad Maybe)+                        (\e -> do+                            errorM $ "Error parsing state file for: "+                                ++ name ++ ": " ++ show (e :: SomeException)+                            errorM $ "Try removing: "++ show stateFile+                            return Nothing) -- proceed regardless+        Nothing -> return Nothing
+ src/Lambdabot/Util.hs view
@@ -0,0 +1,174 @@+-- Copyright (c) 2006 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++-- | String and other utilities+module Lambdabot.Util (+        dropSpace,+        dropSpaceEnd,+        dropNL,+        splitFirstWord,+        limitStr,+        listToStr,+        showClean,+        expandTab,+        arePrefixesWithSpaceOf,+        arePrefixesOf,+        +        io,+        +        random,+        insult,+        confirmation+    ) where++import Control.Monad.Trans+import Data.Char+import Data.List+import Data.Random++------------------------------------------------------------------------++-- | Break a String into it's first word, and the rest of the string. Example:+--+-- > split_first_word "A fine day" ===> ("A", "fine day)+splitFirstWord :: String -- ^ String to be broken+                 -> (String, String)+splitFirstWord xs = (w, dropWhile isSpace xs')+  where (w, xs') = break isSpace xs++-- | Truncate a string to the specified length, putting ellipses at the+-- end if necessary.+limitStr :: Int -> String -> String+limitStr n s = let (b, t) = splitAt n s in+           if null t then b else take (n-3) b ++ "..."++-- | Form a list of terms using a single conjunction. Example:+--+-- > listToStr "and" ["a", "b", "c"] ===> "a, b and c"+listToStr :: String -> [String] -> String+listToStr _    []           = []+listToStr conj (item:items) =+  let listToStr' [] = []+      listToStr' [y] = concat [" ", conj, " ", y]+      listToStr' (y:ys) = concat [", ", y, listToStr' ys]+  in  item ++ listToStr' items++------------------------------------------------------------------------++-- | Pick a random element of the list.+random :: MonadIO m => [a] -> m a+random = io . sample . randomElement++------------------------------------------------------------------------++-- | 'dropSpace' takes as input a String and strips spaces from the+--   prefix as well as the suffix of the String. Example:+--+-- > dropSpace "   abc  " ===> "abc"+dropSpace :: [Char] -> [Char]+dropSpace = let f = reverse . dropWhile isSpace in f . f++-- | Drop space from the end of the string+dropSpaceEnd :: [Char] -> [Char]+dropSpaceEnd = reverse . dropWhile isSpace . reverse++------------------------------------------------------------------------++-- | show a list without heavyweight formatting+-- NB: assumes show instance outputs a quoted 'String'.+-- under that assumption, strips the outer quotes.+showClean :: (Show a) => [a] -> String+showClean = intercalate " " . map (init . tail . show)++dropNL :: [Char] -> [Char]+dropNL = reverse . dropWhile (== '\n') . reverse++-- | untab an string+expandTab :: Int -> String -> String+expandTab w = go 0+  where+    go _ []         = []+    go i ('\t':xs)  = replicate (w - i `mod` w) ' ' ++ go 0 xs+    go i (x:xs)     = x : go (i+1) xs++------------------------------------------------------------------------++-- convenience:+io :: MonadIO m => IO a -> m a+io = liftIO+{-# INLINE io #-}++arePrefixesWithSpaceOf :: [String] -> String -> Bool+arePrefixesWithSpaceOf = arePrefixesOf . map (++ " ")++arePrefixesOf :: [String] -> String -> Bool+arePrefixesOf = flip (any . flip isPrefixOf)++--+-- Amusing insults from OpenBSD sudo+--+insult :: [String]+insult =+   ["Just what do you think you're doing Dave?",+    "It can only be attributed to human error.",+    "That's something I cannot allow to happen.",+    "My mind is going. I can feel it.",+    "Sorry about this, I know it's a bit silly.",+    "Take a stress pill and think things over.",+    "This mission is too important for me to allow you to jeopardize it.",+    "I feel much better now.",++    "Wrong!  You cheating scum!",+    "And you call yourself a Rocket Scientist!",+    "And you call yourself a Rocket Surgeon!",+    "Where did you learn to type?",+    "Are you on drugs?",+    "My pet ferret can type better than you!",+    "You type like i drive.",+    "Do you think like you type?",+    "Your mind just hasn't been the same since the electro-shock, has it?",+    "I don't think I can be your friend on Facebook anymore.",++    "Maybe if you used more than just two fingers...",+    "BOB says:  You seem to have forgotten your passwd, enter another!",+    "stty: unknown mode: doofus",+    "I can't hear you -- I'm using the scrambler.",+    "The more you drive -- the dumber you get.",+    "Listen, broccoli brains, I don't have time to listen to this trash.",+    "I've seen penguins that can type better than that.",+    "Have you considered trying to match wits with a rutabaga?",+    "You speak an infinite deal of nothing.",++    -- other+    "Are you typing with your feet?",+    "Abort, Retry, Panic?",++    -- More haskellish insults+    "You untyped fool!",+    "My brain just exploded",++    -- some more friendly replies+    "I am sorry.","Sorry.",+    "Maybe you made a typo?",+    "Just try something else.",+    "There are some things that I just don't know.",+    "Whoa.",+    -- sometimes don't insult at all+    ":(",":(",+    "","",""+    ]++--+-- Some more interesting confirmations for @remember and @where+--+confirmation :: [String]+confirmation =+   ["Done.","Done.",+    "Okay.",+    "I will remember.",+    "Good to know.",+    "It is stored.",+    "I will never forget.",+    "It is forever etched in my memory.",+    "Nice!"+   ]
+ src/Lambdabot/Util/Browser.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE PatternGuards #-}++-- | URL Utility Functions++module Lambdabot.Util.Browser+    ( urlPageTitle+    , browseLB+    ) where++import Codec.Binary.UTF8.String+import Control.Applicative+import Control.Monad.Trans+import Lambdabot.Config.Core+import Lambdabot.Monad+import Lambdabot.Util (limitStr)+import Network.Browser+import Network.HTTP+import Network.URI+import Text.HTML.TagSoup+import Text.HTML.TagSoup.Match++-- | Run a browser action with some standardized settings+browseLB :: MonadLB m => BrowserAction conn a -> m a+browseLB act = lb $ do+    proxy' <- getConfig proxy+    liftIO . browse $ do+        setOutHandler (const (return ()))+        setErrHandler (const (return ()))+        +        setAllowRedirects True+        setMaxRedirects (Just 5)+        setProxy proxy'+        act++-- | Limit the maximum title length to prevent jokers from spamming+-- the channel with specially crafted HTML pages.+maxTitleLength :: Int+maxTitleLength = 80++-- | Fetches a page title suitable for display.  Ideally, other+-- plugins should make use of this function if the result is to be+-- displayed in an IRC channel because it ensures that a consistent+-- look is used (and also lets the URL plugin effectively ignore+-- contextual URLs that might be generated by another instance of+-- lambdabot; the URL plugin matches on 'urlTitlePrompt').+urlPageTitle :: String -> BrowserAction (HandleStream String) (Maybe String)+urlPageTitle = fmap (fmap (limitStr maxTitleLength)) . rawPageTitle++-- | Fetches a page title for the specified URL.  This function should+-- only be used by other plugins if and only if the result is not to+-- be displayed in an IRC channel.  Instead, use 'urlPageTitle'.+rawPageTitle :: String -> BrowserAction (HandleStream String) (Maybe String)+rawPageTitle url = do+    (_, result) <- request (getRequest (takeWhile (/='#') url))+    case rspCode result of+        (2,0,0)   -> do+            case takeWhile (/= ';') <$> lookupHeader HdrContentType (rspHeaders result) of+                Just "text/html"       -> return $ extractTitle (rspBody result)+                Just "application/pdf" -> rawPageTitle (googleCacheURL url)+                _                      -> return $ Nothing+        _         -> return Nothing+    +    where googleCacheURL = (gURL++) . escapeURIString (const False)+          gURL = "http://www.google.com/search?hl=en&q=cache:"++-- | Given a server response (list of Strings), return the text in+-- between the title HTML element, only if it is text/html content.+-- Now supports all(?) HTML entities thanks to TagSoup.+extractTitle :: String -> Maybe String+extractTitle = content . tags . decodeString where+    tags = closing . opening . canonicalizeTags . parseTags+    opening = dropWhile (not . tagOpenLit "title" (const True))+    closing = takeWhile (not . tagCloseLit "title")++    content = maybeText . format . innerText+    format = unwords . words+    maybeText [] = Nothing+    maybeText t  = Just (encodeString t)
+ src/Lambdabot/Util/Parser.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE Rank2Types #-}++-- Haskell expression parser.  Big hack, but only uses documented APIs so it+-- should be more robust than the previous hack.+module Lambdabot.Util.Parser+    ( withParsed+    , prettyPrintInLine+    ) where++import Data.Generics+import Language.Haskell.Exts++-- |Parse a string as an 'Exp' or a 'Decl', apply the given generic transformation to it,+-- and re-render it back to text.+withParsed :: (forall a. (Data a, Eq a) => a -> a) -> String -> String+withParsed _ "" = "Error: expected a Haskell expression or declaration"+withParsed f s  = case (parseExp s, parseDecl s) of+    (ParseOk a, _)          -> prettyPrintInLine $ f a+    (_, ParseOk a)          -> prettyPrintInLine $ f a+    (ParseFailed l e,  _)   -> prettyPrint l ++ ':' : e++-- |Render haskell code in a compact format+prettyPrintInLine :: Pretty a => a -> String+prettyPrintInLine = prettyPrintWithMode (defaultMode { layout = PPInLine })
+ src/Lambdabot/Util/Process.hs view
@@ -0,0 +1,19 @@+-- Copyright (c) 2004-6 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++module Lambdabot.Util.Process+    ( run+    ) where++import System.Process++run :: FilePath -> String -> (String -> String) -> IO String+run binary src scrub = do+    (_,out,err) <- readProcessWithExitCode binary [] src+    let o = scrub out+        e = scrub err+    return $ case () of {_+        | null o && null e -> "Done."+        | null o           -> e+        | otherwise        -> o+    }
+ src/Lambdabot/Util/Serial.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE FlexibleInstances #-}++{- Copyright (c) 2004-5 Thomas Jaeger, Don Stewart++This program is free software; you can redistribute it and/or+modify it under the terms of the GNU General Public License as+published by the Free Software Foundation; either version 2 of+the License, or (at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA+02111-1307, USA. -}++-- | Serialisation+module Lambdabot.Util.Serial+    ( Serial(..)+    +    , stdSerial+    , mapSerial+    , mapPackedSerial+    , assocListPackedSerial+    , mapListPackedSerial+    , readM+    , Packable(..) {- instances of Packable -}+    , readOnly+    ) where++import Data.Maybe               (mapMaybe)++import Data.Map (Map)+import qualified Data.Map as M++import qualified Data.ByteString.Char8 as P+import Data.ByteString.Char8 (ByteString)++import Data.ByteString.Lazy (fromChunks,toChunks)++import Codec.Compression.GZip++------------------------------------------------------------------------++-- A flexible (moreso than a typeclass) way to define introduction and+-- elimination for persistent state on a per-module basis.+--+data Serial s = Serial {+        serialize   :: s -> Maybe ByteString,+        deserialize :: ByteString -> Maybe s+     }++gzip   :: ByteString -> ByteString+gzip   = P.concat . toChunks . compress . fromChunks . (:[])++gunzip :: ByteString -> ByteString+gunzip = P.concat . toChunks . decompress . fromChunks . (:[])++--+-- read-only serialisation+--+readOnly :: (ByteString -> b) -> Serial b+readOnly f = Serial (const Nothing) (Just . f)++-- | Default `instance' for a Serial+stdSerial :: (Show s, Read s) => Serial s+stdSerial = Serial (Just. P.pack.show) (readM.P.unpack)++-- | Serializes a 'Map' type if both the key and the value are instances+-- of Read and Show. The serialization is done by converting the map to+-- and from lists. Results are saved line-wise, for better editing and+-- revison control.+--+mapSerial :: (Ord k, Show k, Show v, Read k, Read v) => Serial (Map k v)+mapSerial = Serial {+        serialize   = Just . P.pack . unlines . map show . M.toList,+        deserialize = Just . M.fromList . mapMaybe (readM . P.unpack) . P.lines+   }++------------------------------------------------------------------------++-- | 'readM' behaves like read, but catches failure in a monad.+-- this allocates a 20-30 M on startup...+readM :: (Monad m, Read a) => String -> m a+readM s = case [x | (x,t) <- {-# SCC "Serial.readM.reads" #-} reads s    -- bad!+               , ("","")  <- lex t] of+        [x] -> return x+        []  -> fail "Serial.readM: no parse"+        _   -> fail "Serial.readM: ambiguous parse"++class Packable t where+        readPacked :: ByteString -> t+        showPacked :: t -> ByteString++-- | An instance for Map Packed [Packed]+-- uses gzip compression+instance Packable (Map ByteString [ByteString]) where+        readPacked ps = M.fromList (readKV ( P.lines . gunzip $ ps))+             where+                readKV :: [ByteString] -> [(ByteString,[ByteString])]+                readKV []       =  []+                readKV (k:rest) = let (vs, rest') = break (== P.empty) rest+                                  in  (k,vs) : readKV (drop 1 rest')++        showPacked m = gzip+                     . P.unlines+                     . concatMap (\(k,vs) -> k : vs ++ [P.empty]) $ M.toList m++-- assumes single line second strings+instance Packable (Map ByteString ByteString) where+        readPacked ps = M.fromList (readKV (P.lines . gunzip $ ps))+                where+                  readKV :: [ByteString] -> [(ByteString,ByteString)]+                  readKV []         = []+                  readKV (k:v:rest) = (k,v) : readKV rest+                  readKV _      = error "Serial.readPacked: parse failed"++        showPacked m  = gzip. P.unlines . concatMap (\(k,v) -> [k,v]) $ M.toList m++instance Packable ([(ByteString,ByteString)]) where+        readPacked ps = readKV (P.lines . gunzip $ ps)+                where+                  readKV :: [ByteString] -> [(ByteString,ByteString)]+                  readKV []         = []+                  readKV (k:v:rest) = (k,v) : readKV rest+                  readKV _          = error "Serial.readPacked: parse failed"++        showPacked = gzip . P.unlines . concatMap (\(k,v) -> [k,v])++instance Packable (M.Map P.ByteString (Bool, [(String, Int)])) where+    readPacked = M.fromList . readKV . P.lines+        where+          readKV :: [P.ByteString] -> [(P.ByteString,(Bool, [(String, Int)]))]+          readKV []         = []+          readKV (k:v:rest) = (k, (read . P.unpack) v) : readKV rest+          readKV _          = error "Vote.readPacked: parse failed"++    showPacked m = P.unlines . concatMap (\(k,v) -> [k,P.pack . show $ v]) $ M.toList m++-- And for packed string maps+mapPackedSerial :: Serial (Map ByteString ByteString)+mapPackedSerial = Serial (Just . showPacked) (Just . readPacked)++-- And for list of packed string maps+mapListPackedSerial :: Serial (Map ByteString [ByteString])+mapListPackedSerial = Serial (Just . showPacked) (Just . readPacked)++-- And for association list+assocListPackedSerial :: Serial ([(ByteString,ByteString)])+assocListPackedSerial = Serial (Just . showPacked) (Just . readPacked)++------------------------------------------------------------------------
+ src/Lambdabot/Util/Signals.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}++-- | The signal story.+-- Posix signals are external events that invoke signal handlers in+-- Haskell. The signal handlers in turn throw dynamic exceptions.  Our+-- instance of MonadError for LB maps the dynamic exceptions to+-- SignalCaughts, which can then be caught by a normal catchError++-- Here's where we do that.+module Lambdabot.Util.Signals+    ( Signal+    , SignalException(..)+    , ircSignalMessage+    , withIrcSignalCatch+    ) where++import Data.Typeable+import Control.Exception (Exception)++#ifdef mingw32_HOST_OS++type Signal = String+newtype SignalException = SignalException Signal deriving Typeable+instance Exception SignalException++ircSignalMessage :: Signal -> [Char]+ircSignalMessage s = s++withIrcSignalCatch :: MonadBaseControl IO m => m a -> m a+withIrcSignalCatch m = m++#else++import Control.Concurrent.Lifted (myThreadId, newEmptyMVar, putMVar, MVar, ThreadId)+import Control.Exception.Lifted (bracket, throwTo)+import Control.Monad+import Control.Monad.Base+import Control.Monad.Trans.Control++import System.IO.Unsafe+import System.Posix.Signals++newtype SignalException = SignalException Signal deriving (Show, Typeable)+instance Exception SignalException++--+-- A bit of sugar for installing a new handler+--+withHandler :: MonadBaseControl IO m => Signal -> Handler -> m a -> m a+withHandler s h m = bracket+    (liftBase (installHandler s h Nothing))+    (liftBase . flip (installHandler s) Nothing)+    (const m)++-- And more sugar for installing a list of handlers+withHandlerList :: MonadBaseControl IO m => [Signal] -> (Signal -> Handler) -> m a -> m a+withHandlerList sl h m = foldr (withHandler `ap` h) m sl++--+-- Signals we care about. They're all fatal.+--+-- Be careful adding signals, some signals can't be caught and+-- installHandler just raises an exception if you try+--+ircSignalsToCatch :: [(Signal, String)]+ircSignalsToCatch = +    [ (busError,              "SIGBUS"  )+    , (segmentationViolation, "SIGSEGV" )+    , (keyboardSignal,        "SIGINT"  )+    , (softwareTermination,   "SIGTERM" )+    , (keyboardTermination,   "SIGQUIT" )+    , (lostConnection,        "SIGHUP"  )+    , (internalAbort,         "SIGABRT" )+    ]++--+-- User friendly names for the signals that we can catch+--+ircSignalMessage :: Signal -> String+ircSignalMessage sig = case lookup sig ircSignalsToCatch of+    Just sigName -> sigName+    Nothing      -> "killed by unknown signal"++--+-- The actual signal handler. It is this function we register for each+-- signal flavour. On receiving a signal, the signal handler maps the+-- signal to a a dynamic exception, and throws it out to the main+-- thread. The LB MonadError instance can then do its trickery to catch+-- it in handler/catchError+--+ircSignalHandler :: ThreadId -> Signal -> Handler+ircSignalHandler threadid s+    = CatchOnce $ do+        putMVar catchLock ()+        releaseSignals+        throwTo threadid $ SignalException s++--+-- | Release all signal handlers+--+releaseSignals :: IO ()+releaseSignals = sequence_ +    [ installHandler sig Default Nothing+    | (sig, _) <- ircSignalsToCatch+    ]++--+-- Mututally exclusive signal handlers+--+-- This is clearly a hack, but I have no idea how to accomplish the same+-- thing correctly. The main problem is that signals are often thrown+-- multiple times, and the threads start killing each other if we allow+-- the SignalException to be thrown more than once.+{-# NOINLINE catchLock #-}+catchLock :: MVar ()+catchLock = unsafePerformIO newEmptyMVar++--+-- | Register signal handlers to catch external signals+--+withIrcSignalCatch :: MonadBaseControl IO m => m a -> m a+withIrcSignalCatch m = do+    _ <- liftBase $ installHandler sigPIPE Ignore Nothing+    _ <- liftBase $ installHandler sigALRM Ignore Nothing+    threadid <- myThreadId+    withHandlerList (map fst ircSignalsToCatch) (ircSignalHandler threadid) m+#endif