lambdabot-4.3.0.1/0000755000000000000000000000000012215111456011766 5ustar0000000000000000lambdabot-4.3.0.1/AUTHORS.md0000644000000000000000000000562012215111456013440 0ustar0000000000000000AUTHORS ======== The following people have made contributions to the Lambdabot project. There are probably others as well. * Andrew J. Bromage aka Pseudonym on #haskell - the 'bot itself - @free * Shae M. Erisson aka shapr on #haskell - FactModule - FortuneModule - StateModule - SystemModule * Taylor Campbell aka Riastradh on #haskell - KarmaModule * Derek Elkins aka Darius on #haskell - EvalModule * Sven M. Hallberg aka pesco on #haskell - TopicModule * Tom Moertel aka tmoertel on #haskell - DictModule * Mats-Ola Persson aka polli on #haskell - rewrite of the plugin system * Ganesh Sittampalam aka Heffalump on #haskell - Various restructuring to improve bot robustness - Dynamic module loading * Don Stewart 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 aka jlouis on #haskell - Code/Documentation cleanups * Thomas Jäger aka TheHunter on #haskell - PlModule - General hacking/refactoring. * Stefan Wehr 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 - Minor fixed and workarounds - @gsite * David House - Instances, Tell. * Pete Kazmier - Url page title chaser - Contextual messages * Stefan O'Rear aka sorear on #haskell - @nazi-on, @nazi-off, @activity - Non-flat nick namespace - Separation of servers out of base * Spencer Janssen aka sjanssen on #haskell - @undo, @redo * Gwern Branwen aka gwern on #haskell - Packaging of unlambda and brainfuck * James Cook aka mokus on #haskell - Stuff. I dedicate all my contributions to the public domain. * Jan Stolarek aka killy9999 on #haskell - More stuff, mostly code cleanup. lambdabot-4.3.0.1/COMMANDS0000644000000000000000000000420612215111456013114 0ustar0000000000000000activity 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+ lambdabot-4.3.0.1/COMMENTARY.md0000644000000000000000000001222712215111456013772 0ustar0000000000000000COMMENTARY 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. lambdabot-4.3.0.1/lambdabot.cabal0000644000000000000000000002323612215111456014705 0ustar0000000000000000name: lambdabot version: 4.3.0.1 license: GPL license-file: LICENSE author: Don Stewart maintainer: James Cook 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 build-type: Simple cabal-version: >= 1.8 tested-with: GHC==7.4.1, GHC == 7.6.3 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.14.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 lambdabot-4.3.0.1/LICENSE0000644000000000000000000000225612215111456013000 0ustar0000000000000000Copyright (c) 2003 Andrew J. Bromage Portions Copyright (c) 2003 Shae Erisson, Sven M. Hallberg, Taylor Campbell Portions Copyright (c) 2003-2006 Members of the AUTHORS file Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. lambdabot-4.3.0.1/README.md0000644000000000000000000000764712215111456013263 0ustar0000000000000000lambdabot ![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. - GNU talk-filters (optional) for the "filters" plugin. Available via most package managers, I believe. - `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 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. lambdabot-4.3.0.1/Setup.hs0000644000000000000000000000014212215111456013417 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMainWithHooks defaultUserHooks lambdabot-4.3.0.1/main/0000755000000000000000000000000012215111456012712 5ustar0000000000000000lambdabot-4.3.0.1/main/Main.hs0000644000000000000000000000442412215111456014136 0ustar0000000000000000-- -- | 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 "" onStartupCmds strs) "Run a lambdabot command instead of a REPL" , Option "l" [] (arg "" consoleLogLevel level) "Set the logging level" , Option "t" ["trust"] (arg "" trustedPackages strs) "Trust the specified packages when evaluating code" , Option "V" ["version"] (NoArg version) "Print the version of lambdabot" ] 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] ] versionString :: String versionString = ("lambdabot version " ++ showVersion lambdabotVersion) version :: IO a version = do putStrLn versionString exitWith ExitSuccess 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 versionString 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]) lambdabot-4.3.0.1/main/Modules.hs0000644000000000000000000000701012215111456014654 0ustar0000000000000000{-# 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 Lambdabot.Plugin.Activity import Lambdabot.Plugin.Base import Lambdabot.Plugin.BF import Lambdabot.Plugin.Check import Lambdabot.Plugin.Compose import Lambdabot.Plugin.Dice import Lambdabot.Plugin.Dict import Lambdabot.Plugin.Djinn import Lambdabot.Plugin.Dummy import Lambdabot.Plugin.Elite import Lambdabot.Plugin.Eval import Lambdabot.Plugin.Filter import Lambdabot.Plugin.Free import Lambdabot.Plugin.Fresh import Lambdabot.Plugin.Haddock import Lambdabot.Plugin.Help import Lambdabot.Plugin.Hoogle import Lambdabot.Plugin.Instances import Lambdabot.Plugin.IRC import Lambdabot.Plugin.Karma import Lambdabot.Plugin.Localtime import Lambdabot.Plugin.More import Lambdabot.Plugin.OEIS import Lambdabot.Plugin.OfflineRC import Lambdabot.Plugin.Pl import Lambdabot.Plugin.Pointful import Lambdabot.Plugin.Poll import Lambdabot.Plugin.Pretty import Lambdabot.Plugin.Quote import Lambdabot.Plugin.Search import Lambdabot.Plugin.Seen import Lambdabot.Plugin.Slap import Lambdabot.Plugin.Source import Lambdabot.Plugin.Spell import Lambdabot.Plugin.System import Lambdabot.Plugin.Tell import Lambdabot.Plugin.Ticker import Lambdabot.Plugin.Todo import Lambdabot.Plugin.Topic import Lambdabot.Plugin.Type import Lambdabot.Plugin.Undo import Lambdabot.Plugin.Unlambda import Lambdabot.Plugin.UnMtl import Lambdabot.Plugin.Url import Lambdabot.Plugin.Version import Lambdabot.Plugin.Vixen import 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: , "activityPlugin" , "bfPlugin" , "checkPlugin" , "composePlugin" , "dicePlugin" , "dictPlugin" , "djinnPlugin" , "dummyPlugin" , "elitePlugin" , "evalPlugin" , "filterPlugin" , "freePlugin" , "freshPlugin" , "haddockPlugin" , "helpPlugin" , "hooglePlugin" , "instancesPlugin" , "ircPlugin" , "karmaPlugin" , "localtimePlugin" , "morePlugin" , "oeisPlugin" , "plPlugin" , "pointfulPlugin" , "pollPlugin" , "prettyPlugin" , "quotePlugin" , "searchPlugin" , "seenPlugin" , "slapPlugin" , "sourcePlugin" , "spellPlugin" , "tellPlugin" , "tickerPlugin" , "todoPlugin" , "topicPlugin" , "typePlugin" , "undoPlugin" , "unlambdaPlugin" , "unmtlPlugin" , "urlPlugin" , "versionPlugin" , "vixenPlugin" , "wherePlugin" ]) lambdabot-4.3.0.1/scripts/0000755000000000000000000000000012215111456013455 5ustar0000000000000000lambdabot-4.3.0.1/scripts/ghci.sh0000755000000000000000000000241112215111456014724 0ustar0000000000000000#!/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 lambdabot-4.3.0.1/scripts/online.rc0000644000000000000000000000224412215111456015271 0ustar0000000000000000irc-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 lambdabot-4.3.0.1/scripts/vim/0000755000000000000000000000000012215111456014250 5ustar0000000000000000lambdabot-4.3.0.1/scripts/vim/bot0000644000000000000000000000076312215111456014765 0ustar0000000000000000#!/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> //' lambdabot-4.3.0.1/scripts/vim/pl0000644000000000000000000000107412215111456014610 0ustar0000000000000000#!/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> //' lambdabot-4.3.0.1/scripts/vim/README0000644000000000000000000000042112215111456015125 0ustar0000000000000000Vim 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. lambdabot-4.3.0.1/scripts/vim/run0000644000000000000000000000111212215111456014772 0ustar0000000000000000#!/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> //' lambdabot-4.3.0.1/scripts/vim/runwith0000644000000000000000000000175612215111456015704 0ustar0000000000000000#!/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> //' lambdabot-4.3.0.1/scripts/vim/typeOf0000644000000000000000000000046512215111456015446 0ustar0000000000000000#!/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 lambdabot-4.3.0.1/src/0000755000000000000000000000000012215111456012555 5ustar0000000000000000lambdabot-4.3.0.1/src/Lambdabot.hs0000644000000000000000000001423412215111456015002 0ustar0000000000000000{-# 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 ------------------------------------------------------------------------ -- -- | 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 noticeM "Quitting" 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)) |] lambdabot-4.3.0.1/src/Lambdabot/0000755000000000000000000000000012215111456014442 5ustar0000000000000000lambdabot-4.3.0.1/src/Lambdabot/ChanName.hs0000644000000000000000000000054112215111456016450 0ustar0000000000000000module 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 lambdabot-4.3.0.1/src/Lambdabot/Command.hs0000644000000000000000000001031412215111456016353 0ustar0000000000000000{-# 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)lambdabot-4.3.0.1/src/Lambdabot/Config.hs0000644000000000000000000000743412215111456016213 0ustar0000000000000000{-# 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 ] lambdabot-4.3.0.1/src/Lambdabot/File.hs0000644000000000000000000001007412215111456015657 0ustar0000000000000000module 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 lambdabot-4.3.0.1/src/Lambdabot/IRC.hs0000644000000000000000000000770712215111456015426 0ustar0000000000000000-- -- | 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!" } 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_] lambdabot-4.3.0.1/src/Lambdabot/Logging.hs0000644000000000000000000000313612215111456016367 0ustar0000000000000000module 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 lambdabot-4.3.0.1/src/Lambdabot/Main.hs0000644000000000000000000000610212215111456015661 0ustar0000000000000000{-# 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.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 x in [| ircLoadModule $module' x |] lambdabot-4.3.0.1/src/Lambdabot/Message.hs0000644000000000000000000000132412215111456016362 0ustar0000000000000000-- -- 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 lambdabot-4.3.0.1/src/Lambdabot/Module.hs0000644000000000000000000001143212215111456016224 0ustar0000000000000000{-# 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 lambdabot-4.3.0.1/src/Lambdabot/Monad.hs0000644000000000000000000002113112215111456016032 0ustar0000000000000000{-# 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) ------------------------------------------------------------------------ -- -- 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 -> warningM $ "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) lambdabot-4.3.0.1/src/Lambdabot/Monad.hs-boot0000644000000000000000000000012612215111456016774 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} module Lambdabot.Monad where data LB a instance Monad LB lambdabot-4.3.0.1/src/Lambdabot/Nick.hs0000644000000000000000000000265612215111456015673 0ustar0000000000000000module 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' lambdabot-4.3.0.1/src/Lambdabot/NickEq.hs0000644000000000000000000000367712215111456016165 0ustar0000000000000000-- -- | 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 lambdabot-4.3.0.1/src/Lambdabot/OutputFilter.hs0000644000000000000000000000370312215111456017447 0ustar0000000000000000module 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 -} lambdabot-4.3.0.1/src/Lambdabot/Plugin.hs0000644000000000000000000000345112215111456016237 0ustar0000000000000000-- -- 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.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 lambdabot-4.3.0.1/src/Lambdabot/State.hs0000644000000000000000000001645512215111456016071 0ustar0000000000000000{-# 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 lambdabot-4.3.0.1/src/Lambdabot/Util.hs0000644000000000000000000001232712215111456015720 0ustar0000000000000000-- 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!" ] lambdabot-4.3.0.1/src/Lambdabot/Compat/0000755000000000000000000000000012215111456015665 5ustar0000000000000000lambdabot-4.3.0.1/src/Lambdabot/Compat/AltTime.hs0000644000000000000000000001414712215111456017567 0ustar0000000000000000-- | 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) lambdabot-4.3.0.1/src/Lambdabot/Compat/FreenodeNick.hs0000644000000000000000000000225712215111456020563 0ustar0000000000000000-- | 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) lambdabot-4.3.0.1/src/Lambdabot/Compat/PackedNick.hs0000644000000000000000000000143112215111456020214 0ustar0000000000000000module 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 lambdabot-4.3.0.1/src/Lambdabot/Config/0000755000000000000000000000000012215111456015647 5ustar0000000000000000lambdabot-4.3.0.1/src/Lambdabot/Config/Core.hs0000644000000000000000000000576012215111456017103 0ustar0000000000000000{-# 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 |] lambdabot-4.3.0.1/src/Lambdabot/Plugin/0000755000000000000000000000000012215111456015700 5ustar0000000000000000lambdabot-4.3.0.1/src/Lambdabot/Plugin/Activity.hs0000644000000000000000000000351112215111456020030 0ustar0000000000000000-- | Logging an IRC channel.. module Lambdabot.Plugin.Activity (activityPlugin) where import Lambdabot import Lambdabot.Plugin import Lambdabot.Util 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 activityPlugin :: Module [(UTCTime, Nick)] activityPlugin = 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Base.hs0000644000000000000000000002506112215111456017112 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} -- | Lambdabot base module. Controls message send and receive module Lambdabot.Plugin.Base (base) 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 Lambdabot.Util 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 base :: Module (GlobalPrivate () ()) base = 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 () -} lambdabot-4.3.0.1/src/Lambdabot/Plugin/BF.hs0000644000000000000000000000230212215111456016520 0ustar0000000000000000-- 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 (bfPlugin) where import Lambdabot.Plugin import Lambdabot.Util.Process import Data.Char import Text.Regex.TDFA bfPlugin :: Module () bfPlugin = newModule { moduleCmds = return [ (command "bf") { help = say "bf . 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Check.hs0000644000000000000000000000154512215111456017256 0ustar0000000000000000-- 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 (checkPlugin) where import Lambdabot.Plugin import Lambdabot.Plugin.Eval (runGHC) import qualified Language.Haskell.Exts as Hs checkPlugin :: Module () checkPlugin = newModule { moduleCmds = return [ (command "check") { help = do say "check " 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{} -> runGHC ("myquickcheck (" ++ src ++ ") `seq` hsep[]") lambdabot-4.3.0.1/src/Lambdabot/Plugin/Compose.hs0000644000000000000000000001403612215111456017645 0ustar0000000000000000{-# 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 (composePlugin) 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 composePlugin :: Module () composePlugin = 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 [ ". [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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Dice.hs0000644000000000000000000000216212215111456017101 0ustar0000000000000000-- | This module is for throwing dice for e.g. RPGs. (\@dice 3d6+2) -- Original version copyright Einar Karttunen 2005-04-06. -- Massive rewrite circa 2008-10-20 copyright James Cook module Lambdabot.Plugin.Dice (dicePlugin) where import Lambdabot.Plugin import Lambdabot.Util import Data.List import Data.Random.Dice (rollEm) type Dice = ModuleT () LB dicePlugin :: Module () dicePlugin = newModule { moduleCmds = return [ (command "dice") { aliases = ["roll"] , help = say "@dice . Throw random dice. 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Dict.hs0000644000000000000000000000774112215111456017130 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} -- | DICT (RFC 2229) Lookup Module for lambdabot IRC robot. -- Tom Moertel module Lambdabot.Plugin.Dict (dictPlugin) where import Lambdabot.Plugin import qualified Lambdabot.Plugin.Dict.DictLookup as Dict import Lambdabot.Util import Control.Monad import Data.List type Dict = ModuleT () LB dictPlugin :: Module () dictPlugin = 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" lambdabot-4.3.0.1/src/Lambdabot/Plugin/Djinn.hs0000644000000000000000000001612712215111456017305 0ustar0000000000000000{-# 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 (djinnPlugin) where import Lambdabot.Config.Core import Lambdabot.Logging import Lambdabot.Plugin import Lambdabot.Util 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 djinnPlugin :: Module (Maybe DjinnEnv) djinnPlugin = 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 ." , "Generates Haskell code from a type." , "http://darcs.augustsson.net/Darcs/Djinn" ] , process = rejectingCmds djinnCmd } , (command "djinn-add") { help = do say "djinn-add ." say "Define a new function type or type synonym" , process = rejectingCmds djinnAddCmd } , (command "djinn-del") { help = do say "djinn-del ." 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> *)+" lambdabot-4.3.0.1/src/Lambdabot/Plugin/Dummy.hs0000644000000000000000000001052212215111456017327 0ustar0000000000000000-- | Simple template module -- Contains many constant bot commands. module Lambdabot.Plugin.Dummy (dummyPlugin) where import Lambdabot.Plugin import Lambdabot.Plugin.Dummy.DocAssocs (docAssocs) import Lambdabot.Util import Data.Char import qualified Data.ByteString.Char8 as P import qualified Data.Map as M import System.FilePath dummyPlugin :: Module () dummyPlugin = 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 . The identity plugin" "show" -> "show . Print \"\"" "wiki" -> "wiki . URLs of Haskell wiki pages" "paste" -> "paste. Paste page url" "docs" -> "docs . 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Elite.hs0000644000000000000000000000542712215111456017306 0ustar0000000000000000-- (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 (elitePlugin) where import Lambdabot.Plugin import Lambdabot.Util import Control.Arrow import Control.Monad import Data.Char import Data.Maybe import Text.Regex.TDFA elitePlugin :: Module () elitePlugin = newModule { moduleCmds = return [ (command "elite") { aliases = ["leet", "l33t", "1337"] , help = say "elite . 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" ) ] lambdabot-4.3.0.1/src/Lambdabot/Plugin/Error.hs0000644000000000000000000000200312215111456017320 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} module Lambdabot.Plugin.Error (errorPlugin, failOnLoad, errorOnLoad) where import Lambdabot.Config import Lambdabot.Plugin import Control.Monad config "failOnLoad" [t| Bool |] [| False |] config "errorOnLoad" [t| Bool |] [| False |] errorPlugin :: Module () errorPlugin = 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!") } lambdabot-4.3.0.1/src/Lambdabot/Plugin/Eval.hs0000644000000000000000000001466112215111456017133 0ustar0000000000000000-- 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 (evalPlugin, runGHC, exts) where import Lambdabot.Plugin import Lambdabot.Util 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 evalPlugin :: Module () evalPlugin = newModule { moduleCmds = return [ (command "run") { help = say "run . You have Haskell, 3 seconds and no IO. Go nuts!" , process = lim80 . runGHC } , (command "let") { aliases = ["define"] -- because @define always gets "corrected" to @undefine , help = say "let = . 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 (runGHC (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 runGHC :: MonadLB m => String -> m String runGHC 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) lambdabot-4.3.0.1/src/Lambdabot/Plugin/Filter.hs0000644000000000000000000000462112215111456017464 0ustar0000000000000000-- | GNU Talk Filters -- needs: http://www.hyperrealm.com/main.php?s=talkfilters -- Edward Kmett 2006 module Lambdabot.Plugin.Filter (filterPlugin) where import Lambdabot.Plugin import Lambdabot.Util import Control.Applicative import Data.Maybe import System.Directory (findExecutable) import System.Process -- State consists of a map from filter name to executable path filterPlugin :: Module [(String, FilePath, String)] filterPlugin = 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 ++ " ") t -> ios80 (runFilter path (unwords t)) } | (name, path, descr) <- activeFilters ] } filters :: [(String, String)] filters = [ ("austro", "austro . Talk like Ahhhnold") , ("b1ff", "b1ff . B1ff of usenet yore") , ("brooklyn", "brooklyn . Yo") , ("chef", "chef . Bork bork bork") , ("cockney", "cockney . Londoner accent") , ("drawl", "drawl . Southern drawl") , ("dubya", "dubya . Presidential filter") , ("fudd", "fudd . Fudd, Elmer") , ("funetak", "funetak . Southern drawl") , ("jethro", "jethro . Now listen to a story 'bout a man named Jed...") , ("jive", "jive . Slap ma fro") , ("kraut", "kraut . German accent") , ("pansy", "pansy . Effeminate male") , ("pirate", "pirate . Talk like a pirate") , ("postmodern", "postmodern . Feminazi") , ("redneck", "redneck . Deep south") , ("valspeak", "valley . Like, ya know?") , ("warez", "warez . 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Free.hs0000644000000000000000000000104412215111456017114 0ustar0000000000000000-- | Free theorems plugin -- Andrew Bromage, 2006 module Lambdabot.Plugin.Free (freePlugin) where import Lambdabot.Plugin import Lambdabot.Plugin.Free.FreeTheorem import Lambdabot.Plugin.Type (query_ghci) freePlugin :: Module () freePlugin = newModule { moduleCmds = return [ (command "free") { help = say "free . Generate theorems for free" , process = \xs -> do result <- freeTheoremStr (query_ghci ":t") xs say . unwords . lines $ result } ] } lambdabot-4.3.0.1/src/Lambdabot/Plugin/Fresh.hs0000644000000000000000000000155512215111456017311 0ustar0000000000000000-- | Haskell project name generation -- semi-joke module Lambdabot.Plugin.Fresh (freshPlugin) where import Lambdabot.Plugin import Control.Monad.Trans import Data.Char type Fresh = ModuleT Integer LB freshPlugin :: Module Integer freshPlugin = 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Haddock.hs0000644000000000000000000000172312215111456017574 0ustar0000000000000000-- | Hackish Haddock module. module Lambdabot.Plugin.Haddock (haddockPlugin) 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 haddockPlugin :: Module HaddockState haddockPlugin = newModule { moduleCmds = return [ (command "index") { help = say "index . Returns the Haskell modules in which 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 (=='(') lambdabot-4.3.0.1/src/Lambdabot/Plugin/Hello.hs0000644000000000000000000000063012215111456017276 0ustar0000000000000000-- -- | Hello world plugin -- module Lambdabot.Plugin.Hello (helloPlugin) where import Lambdabot.Plugin helloPlugin :: Module () helloPlugin = newModule { moduleCmds = return [ (command "hello") { aliases = ["goodbye"] , help = say "hello/goodbye . Simplest possible plugin" , process = \xs -> say ("Hello world. " ++ xs) } ] } lambdabot-4.3.0.1/src/Lambdabot/Plugin/Help.hs0000644000000000000000000000314612215111456017130 0ustar0000000000000000-- | Provide help for plugins module Lambdabot.Plugin.Help (helpPlugin) where import Lambdabot.Command import Lambdabot.Message (Message) import Lambdabot.Monad import Lambdabot.Plugin import Lambdabot.Util helpPlugin :: Module () helpPlugin = newModule { moduleCmds = return [ (command "help") { help = say "help . Ask for help for . 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Hoogle.hs0000644000000000000000000000425012215111456017452 0ustar0000000000000000-- 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 (hooglePlugin) where import Lambdabot.Plugin import Lambdabot.Util import System.Process hooglePlugin :: Module [String] hooglePlugin = newModule { moduleDefState = return [] , moduleCmds = return [ (command "hoogle") { help = say "hoogle . 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 . 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) lambdabot-4.3.0.1/src/Lambdabot/Plugin/Instances.hs0000644000000000000000000001252412215111456020167 0ustar0000000000000000{- | 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 (instancesPlugin) where import Text.ParserCombinators.Parsec import Lambdabot.Plugin import Lambdabot.Util import Control.Applicative ((*>)) import Control.Monad import Data.Char import Data.List import Data.List.Split import Data.Maybe import System.FilePath import System.Process import Text.Regex.TDFA type Instance = String type ClassName = String type ModuleName = String instancesPlugin :: Module () instancesPlugin = newModule { moduleCmds = return [ (command "instances") { help = say "instances . Fetch the instances of a typeclass." , process = fetchInstances >=> say } , (command "instances-importing") { help = say $ "instances-importing [ [ [. " ++ "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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/IRC.hs0000644000000000000000000001267112215111456016660 0ustar0000000000000000-- | The plugin-level IRC interface. module Lambdabot.Plugin.IRC (ircPlugin) where import Lambdabot.IRC import Lambdabot.Logging import Lambdabot.Monad import Lambdabot.Plugin import Lambdabot.Util 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 ircPlugin :: Module () ircPlugin = 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 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 errorM (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 :: Handle -> MVar () -> IrcMessage -> IO () sendMsg sock mv msg = E.catch (do takeMVar mv P.hPut sock $ P.pack $ encodeMessage msg "\r\n") (\err -> do errorM (show (err :: IOError)) hClose sock) lambdabot-4.3.0.1/src/Lambdabot/Plugin/Karma.hs0000644000000000000000000000750412215111456017275 0ustar0000000000000000-- | Karma module Lambdabot.Plugin.Karma (karmaPlugin) 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 karmaPlugin :: Module KarmaState karmaPlugin = newModule { moduleCmds = return [ (command "karma") { help = say "karma . 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+ . Increment someone's karma" , process = doCmd 1 } , (command "karma-") { help = say "karma- . 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 ++ "." lambdabot-4.3.0.1/src/Lambdabot/Plugin/Localtime.hs0000644000000000000000000000473412215111456020155 0ustar0000000000000000{-# 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 (localtimePlugin) 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 localtimePlugin :: Module TimeMap localtimePlugin = newModule { moduleDefState = return M.empty , moduleCmds = return [ (command "time") { aliases = ["localtime"] , help = say "time . Print a user's local time. User's client must support ctcp pings." , process = doLocalTime } , (command "localtime-reply") { help = say "time . 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Log.hs0000644000000000000000000001544612215111456016767 0ustar0000000000000000-- Copyright (c) 2004 Thomas Jaeger -- Copyright (c) 2005 Simon Winwood -- Copyright (c) 2005 Don Stewart -- Copyright (c) 2005 David House -- -- | Logging an IRC channel.. -- module Lambdabot.Plugin.Log (logPlugin) where import Lambdabot import Lambdabot.Compat.FreenodeNick import Lambdabot.IRC import qualified Lambdabot.Message as Msg import Lambdabot.Nick import Lambdabot.Plugin import Lambdabot.Util 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 -- logPlugin :: Module (M.Map Channel ChanState) logPlugin = 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/More.hs0000644000000000000000000000312112215111456017133 0ustar0000000000000000-- | Support for more(1) buffering module Lambdabot.Plugin.More (morePlugin) 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 morePlugin :: Module (GlobalPrivate () [String]) morePlugin = 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Numberwang.hs0000644000000000000000000000425612215111456020350 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module Lambdabot.Plugin.Numberwang (numberwangPlugin) 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) numberwangPlugin :: Module NumberwangState numberwangPlugin = newModule { moduleDefState = sample (State <$> cmdDist <*> conDist) , moduleCmds = return [ (command "numberwang") { help = say "@numberwang : 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/OEIS.hs0000644000000000000000000000102612215111456016772 0ustar0000000000000000-- | Look up sequences in the Online Encyclopedia of Integer Sequences -- Based on the Math.OEIS library module Lambdabot.Plugin.OEIS (oeisPlugin) where import Lambdabot.Plugin import Math.OEIS oeisPlugin :: Module () oeisPlugin = newModule { moduleCmds = return [ (command "oeis") { aliases = ["sequence"] , help = say "oeis . Look up a sequence in the Online Encyclopedia of Integer Sequences" , process = ios80 . fmap concat . lookupOEIS } ] } lambdabot-4.3.0.1/src/Lambdabot/Plugin/OfflineRC.hs0000644000000000000000000000672112215111456020051 0ustar0000000000000000-- | 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 ( offlineRC ) where import Lambdabot.Config.Core import Lambdabot.IRC import Lambdabot.Monad import Lambdabot.Plugin import Lambdabot.Util 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 offlineRC :: Module OfflineRCState offlineRC = 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) lambdabot-4.3.0.1/src/Lambdabot/Plugin/Pl.hs0000644000000000000000000000537612215111456016622 0ustar0000000000000000-- | 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 (plPlugin) where import Lambdabot.Plugin import Lambdabot.Util 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 plPlugin :: Module (GlobalPrivate () (Int, TopLevel)) plPlugin = newModule { moduleDefState = return $ mkGlobalPrivate 15 () , moduleCmds = return [ (command "pointless") { aliases = ["pl"] , help = say "pointless . 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) lambdabot-4.3.0.1/src/Lambdabot/Plugin/Pointful.hs0000644000000000000000000002216012215111456020035 0ustar0000000000000000-- Undo pointfree transformations. Plugin code derived from Pl.hs. module Lambdabot.Plugin.Pointful (pointfulPlugin) 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 pointfulPlugin :: Lmb.Module () pointfulPlugin = newModule { moduleCmds = return [ (command "pointful") { aliases = ["pointy","repoint","unpointless","unpl","unpf"] , help = say "pointful . 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 "" 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' .) . (==))) =<<)" --lambdabot-4.3.0.1/src/Lambdabot/Plugin/Poll.hs0000644000000000000000000001735712215111456017157 0ustar0000000000000000{-# 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 (pollPlugin) 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) ------------------------------------------------------------------------ pollPlugin :: Module (M.Map PollName Poll) pollPlugin = 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 Shows all choices for some poll" , process = process_ "poll-show" } , (command "poll-add") { help = say "poll-add Adds a new poll, with no candidates" , process = process_ "poll-add" } , (command "choice-add") { help = say "choice-add 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 Vote for in " , process = process_ "vote" } , (command "poll-result") { help = say "poll-result Show result for given poll" , process = process_ "poll-result" } , (command "poll-close") { help = say "poll-close Closes a poll" , process = process_ "poll-close" } , (command "poll-remove") { help = say "poll-remove 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 " -- declare a new poll "poll-add" -> case length dat of 1 -> addPoll fm writer (head dat) _ -> return "usage: @poll-add with \"ThisTopic\" style names" "choice-add" -> case length dat of 2 -> addChoice fm writer (head dat) (last dat) _ -> return "usage: @choice-add " "vote" -> case length dat of 2 -> vote fm writer (head dat) (last dat) _ -> return "usage: @vote " "poll-result" -> return $ case length dat of 1 -> showResult fm (head dat) _ -> "usage: @poll-result " "poll-close" -> case length dat of 1 -> closePoll fm writer (head dat) _ -> return "usage: @poll-close " "poll-remove" -> case length dat of 1 -> removePoll fm writer (head dat) _ -> return "usage: @poll-remove " _ -> 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." lambdabot-4.3.0.1/src/Lambdabot/Plugin/Pretty.hs0000644000000000000000000000572612215111456017535 0ustar0000000000000000{- | 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 (prettyPlugin) 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 prettyPlugin :: Module () prettyPlugin = newModule { moduleCmds = return [ (command "pretty") { help = say "pretty . 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Quote.hs0000644000000000000000000001473312215111456017341 0ustar0000000000000000{-# LANGUAGE CPP, PatternGuards #-} -- | Support for quotes module Lambdabot.Plugin.Quote (quotePlugin) where import Lambdabot.Plugin import Lambdabot.Util 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 quotePlugin :: Module (M.Map P.ByteString [P.ByteString]) quotePlugin = newModule { moduleSerialize = Just mapListPackedSerial , moduleDefState = return M.empty , moduleInit = modifyMS (M.filter (not . null)) , moduleCmds = return [ (command "quote") { help = say "quote : Quote or a random person if no nick is given" , process = runQuote . dropSpace } , (command "remember") { help = say "remember : Remember that said ." , 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Search.hs0000644000000000000000000001214712215111456017446 0ustar0000000000000000{-# 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 (searchPlugin) where import Lambdabot.Plugin import Lambdabot.Util 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" searchPlugin :: Module () searchPlugin = 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 . Search google and show url of first hit" -- "wikipedia" -> "wikipedia . Search wikipedia and show url of first hit" "gsite" -> "gsite . Search for using google" "gwiki" -> "gwiki . Search (new) haskell.org wiki for 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)] lambdabot-4.3.0.1/src/Lambdabot/Plugin/Seen.hs0000644000000000000000000003300612215111456017130 0ustar0000000000000000-- 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 (seenPlugin) where import Lambdabot import Lambdabot.Compat.AltTime import Lambdabot.Compat.PackedNick import Lambdabot.IRC import Lambdabot.Logging import qualified Lambdabot.Message as G import Lambdabot.Nick import Lambdabot.Plugin import Lambdabot.Util 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 Text.Printf type SeenState = (MaxMap, SeenMap) type SeenMap = M.Map PackedNick UserStatus type MaxMap = M.Map Channel Int type Seen = ModuleT SeenState LB ------------------------------------------------------------------------ seenPlugin :: Module (M.Map Channel Int, M.Map PackedNick UserStatus) seenPlugin = 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 . 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@SomeException{} -> do -- try reading the old format (slightly different type... oh, "binary"...) mbOld <- io . try . evaluate $ decode ls case mbOld of Left SomeException{} -> warningM ("WARNING: failed to read Seen module state: " ++ show exc) 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) lambdabot-4.3.0.1/src/Lambdabot/Plugin/Slap.hs0000644000000000000000000000615612215111456017143 0ustar0000000000000000-- | Support for quotes module Lambdabot.Plugin.Slap (slapPlugin) where import Lambdabot.Plugin import Lambdabot.Util type Slap = ModuleT () LB slapPlugin :: Module () slapPlugin = newModule { moduleCmds = return [ (command "slap") { aliases = ["smack"] , help = say "slap . 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" lambdabot-4.3.0.1/src/Lambdabot/Plugin/Source.hs0000644000000000000000000000271612215111456017502 0ustar0000000000000000-- Plugin.Source -- Display source for specified identifiers module Lambdabot.Plugin.Source (sourcePlugin) where import Lambdabot.Plugin import Lambdabot.Util import Control.Monad import qualified Data.ByteString.Char8 as P import qualified Data.Map as M type Env = M.Map P.ByteString P.ByteString sourcePlugin :: Module (M.Map P.ByteString P.ByteString) sourcePlugin = 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 . Display the implementation of a standard function"lambdabot-4.3.0.1/src/Lambdabot/Plugin/Spell.hs0000644000000000000000000000777212215111456017330 0ustar0000000000000000{-# 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 (spellPlugin) where import Lambdabot.Plugin import Lambdabot.Util 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 spellPlugin :: Module Bool spellPlugin = 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 . 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 ::= & : , , ... -- None ::= # -- 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Stats.hs0000644000000000000000000000175112215111456017336 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} module Lambdabot.Plugin.Stats (statsPlugin) where import Lambdabot.Plugin import Lambdabot.Util import Network.StatsD type Stats = ModuleT StatsD LB statsPlugin :: Module StatsD statsPlugin = 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] lambdabot-4.3.0.1/src/Lambdabot/Plugin/System.hs0000644000000000000000000001434012215111456017522 0ustar0000000000000000-- | System module : IRC control functions module Lambdabot.Plugin.System (system) where import Lambdabot import Lambdabot.Compat.AltTime import Lambdabot.Compat.FreenodeNick import Lambdabot.IRC import Lambdabot.Monad import Lambdabot.Plugin import Lambdabot.Util 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 system :: Module SystemState system = 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 . 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 " , process = \rest -> do chan <- readNick rest lb $ send (joinChannel chan) } , (command "part") { privileged = True , help = say "part " , aliases = ["leave"] , process = \rest -> do chan <- readNick rest lb $ send (partChannel chan) } , (command "msg") { privileged = True , help = say "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')] lambdabot-4.3.0.1/src/Lambdabot/Plugin/Tell.hs0000644000000000000000000002341512215111456017141 0ustar0000000000000000{- 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 davidhouse said less than a minute ago: foo > 17:12 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 (tellPlugin) where import Lambdabot.Compat.AltTime import Lambdabot.Compat.FreenodeNick import Lambdabot.Plugin import Lambdabot.Util 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 tellPlugin :: Module NoticeBoard tellPlugin = newModule { moduleCmds = return [ (command "tell") { help = say "tell . When shows activity, tell them ." , process = doTell Tell . words } , (command "ask") { help = say "ask . When shows activity, ask them ." , 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 [ [ [ ...]]]]. " ++ "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 () lambdabot-4.3.0.1/src/Lambdabot/Plugin/Ticker.hs0000644000000000000000000001166012215111456017461 0ustar0000000000000000-- | Pull quotes down from yahoo. module Lambdabot.Plugin.Ticker (tickerPlugin) 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 tickerPlugin :: Module () tickerPlugin = 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Todo.hs0000644000000000000000000000447212215111456017150 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} -- | A todo list -- -- (c) 2005 Samuel Bronson module Lambdabot.Plugin.Todo (todoPlugin) 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 todoPlugin :: Module TodoState todoPlugin = 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 . Add a todo entry" , process = addTodo } , (command "todo-delete") { privileged = True , help = say "todo-delete . 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 , where n :: Int" lambdabot-4.3.0.1/src/Lambdabot/Plugin/Topic.hs0000644000000000000000000000762612215111456017325 0ustar0000000000000000-- | 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 (topicPlugin) where import Lambdabot.IRC import Lambdabot.Monad import Lambdabot.Plugin import Lambdabot.Util 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 (\_ _ -> [])) ] topicPlugin :: Module () topicPlugin = 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." lambdabot-4.3.0.1/src/Lambdabot/Plugin/Type.hs0000644000000000000000000001222712215111456017161 0ustar0000000000000000{-# 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 (typePlugin, query_ghci) where import Lambdabot.Plugin import Lambdabot.Plugin.Eval (exts) import Lambdabot.Util import Data.Char import Data.Maybe import System.Process import Text.Regex.TDFA typePlugin :: Module () typePlugin = newModule { moduleCmds = return [ (command "type") { help = say "type . Return the type of a value" , process = runit ":t" } , (command "kind") { help = say "kind . 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 = ":[^:]*:[^:]*: ?" notfound = "Failed to load interface" lambdabot-4.3.0.1/src/Lambdabot/Plugin/Undo.hs0000644000000000000000000001117512215111456017146 0ustar0000000000000000-- Copyright (c) 2006 Spencer Janssen -- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) module Lambdabot.Plugin.Undo (undoPlugin) 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) undoPlugin :: Module () undoPlugin = newModule { moduleCmds = return [ (command "undo") { help = say "undo \nTranslate do notation to Monad operators." , process = say . transform undo } , (command "do") { help = say "do \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 _box 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Unlambda.hs0000644000000000000000000000171512215111456017763 0ustar0000000000000000-- 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 (unlambdaPlugin) where import Lambdabot.Plugin import Lambdabot.Util.Process import Text.Regex.TDFA unlambdaPlugin :: Module () unlambdaPlugin = newModule { moduleCmds = return [ (command "unlambda") { help = say "unlambda . 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" lambdabot-4.3.0.1/src/Lambdabot/Plugin/UnMtl.hs0000644000000000000000000001453612215111456017304 0ustar0000000000000000---------------------------------------------------------------------- -- | -- 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 (unmtlPlugin) 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) unmtlPlugin :: Lmb.Module () unmtlPlugin = 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Url.hs0000644000000000000000000001240212215111456016775 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} -- | Fetch URL page titles of HTML links. module Lambdabot.Plugin.Url (urlPlugin) 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 urlPlugin :: Module Bool urlPlugin = newModule { moduleCmds = return [ (command "url-title") { help = say "url-title . Fetch the page title." , process = maybe (say "Url not valid.") (mbSay <=< fetchTitle) . containsUrl } , (command "tiny-url") { help = say "tiny-url . Shorten ." , 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) lambdabot-4.3.0.1/src/Lambdabot/Plugin/Version.hs0000644000000000000000000000136012215111456017661 0ustar0000000000000000-- 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 (versionPlugin) where import Lambdabot.Plugin import Paths_lambdabot (version) import Data.Version (showVersion) versionPlugin :: Module () versionPlugin = 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" } ] } lambdabot-4.3.0.1/src/Lambdabot/Plugin/Vixen.hs0000644000000000000000000000610312215111456017325 0ustar0000000000000000-- | Talk to hot chixxors. -- (c) Mark Wotton -- Serialisation (c) 2007 Don Stewart module Lambdabot.Plugin.Vixen (vixenPlugin) where import Lambdabot.Plugin import Lambdabot.Util import Control.Arrow ((***)) import Control.Monad import Data.Binary import qualified Data.ByteString.Char8 as P import System.Directory import Text.Regex.TDFA vixenPlugin :: Module (Bool, String -> IO [Char]) vixenPlugin = newModule { moduleCmds = return [ (command "vixen") { help = say "vixen . 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 "")) -- 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Where.hs0000644000000000000000000000510512215111456017307 0ustar0000000000000000-- | -- 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 (wherePlugin) where import Lambdabot.Plugin import Lambdabot.Util 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 wherePlugin :: Module (M.Map P.ByteString P.ByteString) wherePlugin = newModule { moduleDefState = return M.empty , moduleSerialize = Just mapPackedSerial , moduleCmds = return [ (command "where") { help = say "where . Return element associated with key" , process = doCmd "where" } , (command "url") { help = say "url . Return element associated with key" , process = doCmd "url" } , (command "what") { help = say "what . Return element associated with key" , process = doCmd "what" } , (command "where+") { help = say "where+ . Define an association" , process = doCmd "where+" } ] } doCmd :: String -> String -> Cmd Where () doCmd cmd rest = (say =<<) . withMS $ \factFM writer -> case words rest of [] -> return "@where , 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Check/0000755000000000000000000000000012215111456016715 5ustar0000000000000000lambdabot-4.3.0.1/src/Lambdabot/Plugin/Check/ShowQ.hs0000644000000000000000000000350312215111456020313 0ustar0000000000000000-- 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) ++ "%" lambdabot-4.3.0.1/src/Lambdabot/Plugin/Dict/0000755000000000000000000000000012215111456016563 5ustar0000000000000000lambdabot-4.3.0.1/src/Lambdabot/Plugin/Dict/DictLookup.hs0000644000000000000000000000642512215111456021203 0ustar0000000000000000-- -- | DICT (RFC 2229) Lookup -- Tom Moertel -- --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 | Right 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") lambdabot-4.3.0.1/src/Lambdabot/Plugin/Dummy/0000755000000000000000000000000012215111456016773 5ustar0000000000000000lambdabot-4.3.0.1/src/Lambdabot/Plugin/Dummy/DocAssocs.hs0000644000000000000000000003772312215111456021224 0ustar0000000000000000 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)] lambdabot-4.3.0.1/src/Lambdabot/Plugin/Eval/0000755000000000000000000000000012215111456016567 5ustar0000000000000000lambdabot-4.3.0.1/src/Lambdabot/Plugin/Eval/Trusted.hs0000644000000000000000000000073612215111456020563 0ustar0000000000000000{-# 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 } lambdabot-4.3.0.1/src/Lambdabot/Plugin/Free/0000755000000000000000000000000012215111456016561 5ustar0000000000000000lambdabot-4.3.0.1/src/Lambdabot/Plugin/Free/Expr.hs0000644000000000000000000000667212215111456020046 0ustar0000000000000000{-# 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Free/FreeTheorem.hs0000644000000000000000000002273612215111456021334 0ustar0000000000000000{-# 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Free/Parse.hs0000644000000000000000000001543512215111456020177 0ustar0000000000000000{-# 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Free/Test.hs0000644000000000000000000000222412215111456020034 0ustar0000000000000000module 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Free/Theorem.hs0000644000000000000000000001400212215111456020515 0ustar0000000000000000{-# 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Free/Type.hs0000644000000000000000000001620412215111456020041 0ustar0000000000000000{-# 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Free/Util.hs0000644000000000000000000000106412215111456020033 0ustar0000000000000000module 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Pl/0000755000000000000000000000000012215111456016253 5ustar0000000000000000lambdabot-4.3.0.1/src/Lambdabot/Plugin/Pl/Common.hs0000644000000000000000000001025412215111456020041 0ustar0000000000000000module 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Pl/Names.hs0000644000000000000000000000564412215111456017663 0ustar0000000000000000 -- -- | 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` lambdabot-4.3.0.1/src/Lambdabot/Plugin/Pl/Optimize.hs0000644000000000000000000000767412215111456020425 0ustar0000000000000000{-# 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Pl/Parser.hs0000644000000000000000000001457012215111456020052 0ustar0000000000000000{-# 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' lambdabot-4.3.0.1/src/Lambdabot/Plugin/Pl/PrettyPrinter.hs0000644000000000000000000001223012215111456021440 0ustar0000000000000000{-# 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 -} lambdabot-4.3.0.1/src/Lambdabot/Plugin/Pl/RuleLib.hs0000644000000000000000000001433212215111456020150 0ustar0000000000000000{-# 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Pl/Rules.hs0000644000000000000000000004415712215111456017714 0ustar0000000000000000{-# 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)) ] lambdabot-4.3.0.1/src/Lambdabot/Plugin/Pl/Transform.hs0000644000000000000000000001036212215111456020564 0ustar0000000000000000{-# 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Seen/0000755000000000000000000000000012215111456016572 5ustar0000000000000000lambdabot-4.3.0.1/src/Lambdabot/Plugin/Seen/StopWatch.hs0000644000000000000000000000146412215111456021047 0ustar0000000000000000module 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 lambdabot-4.3.0.1/src/Lambdabot/Plugin/Seen/UserStatus.hs0000644000000000000000000000665712215111456021266 0ustar0000000000000000module 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 lambdabot-4.3.0.1/src/Lambdabot/Util/0000755000000000000000000000000012215111456015357 5ustar0000000000000000lambdabot-4.3.0.1/src/Lambdabot/Util/Browser.hs0000644000000000000000000000567512215111456017353 0ustar0000000000000000{-# 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) lambdabot-4.3.0.1/src/Lambdabot/Util/Parser.hs0000644000000000000000000000165412215111456017155 0ustar0000000000000000{-# 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 }) lambdabot-4.3.0.1/src/Lambdabot/Util/Process.hs0000644000000000000000000000103412215111456017327 0ustar0000000000000000-- 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 } lambdabot-4.3.0.1/src/Lambdabot/Util/Serial.hs0000644000000000000000000001312512215111456017134 0ustar0000000000000000{-# 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) ------------------------------------------------------------------------ lambdabot-4.3.0.1/src/Lambdabot/Util/Signals.hs0000644000000000000000000000761012215111456017317 0ustar0000000000000000{-# 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 lambdabot-4.3.0.1/State/0000755000000000000000000000000012215111456013046 5ustar0000000000000000lambdabot-4.3.0.1/State/djinn0000644000000000000000000000025612215111456014076 0ustar0000000000000000"data T x = (x,x,x)" "data () = ()" "data Either a b = Left a | Right b" "data Maybe a = Nothing | Just a" "data Bool = False | True" "data Void = " "type Not x = x -> Void" lambdabot-4.3.0.1/State/haddock0000644000000000000000000014510412215111456014373 0ustar0000000000000000‹Èá™Ehaddockì½]w⸲?|ß_ã\Ì]Öt÷̜ٗH H÷ì}ÓËؼc,Æ/é0Ÿþ_%ÙÆ/z58„óßÌhpø0 «tÓ(ýÐ[ÒžÝ\`¿'ÎþRÓ`Ó MÈ‚ç‹ÌËÝÍh å®›îÔ2ÝEÎFa½&ÑåÁ~oõvÞ{/I"#£ì›…ó‹ÄIÈ™å˜jæDG#ÀÖ¤óLJ7 ’¤û¼j~óCþè4&nnÉÆ…íÜÀwýþ‡“87ŒŠ=ïéy M߸2¦¬l¾ø w$L4Ó¡à9«´Oa|•òþt%ÿ·4)oF¡—ÂT!Ù$US°éÓ¾’¬ž„Ð ´zëÄðOµQÏÉÞ†â(é<Ó r~°‡oWKú4"•l2è>4yÙE-æþf›Äs“èfse•û. aI©NœçZÉÂßí6þÁ[¹ðBôÇÀ`g†ÙT^O¾$ŽB?ñ ¡îU¾Tçþ_?Þ,{R+ú+ðW9ÇëžÆiDâ õH“êfâÇ®”yºtK"ès“Ø ]è¨2ÎÃ×^Gs/8?ý1…áœý†è„Vž`”]ßsViÛÊ~ë\¡ŽbkVȺÜ}Ðh‰CuI¡?~ºJ©»F©¹F¡¿:¡8Íþ1#(£›êÎ|rÇ»•¯kÏ9Ÿ–wÚ ½¿^§±fÔÏÞ}¨Ñc»éÐ…°_%:-º«Þçz×uGo‚ªJxó:I\-jêÅÅt¨”æéæKêxL}U’ÙHÝÔgäÚPRT뼯øz_5¢.I“ ÐïüíÄ}Ã>áÁðÈMÅHXXhKûýðÃVÐÔÙ›'~Én–7‹C˜8¯¢*Æ´lÃÏÀ´Ó²e‰•NÃo‘Ÿ3û¯X]þ´‘äeK‡âG+?‰œèP·Ë5LrH+P€ó(r›ª´‚Z}}'§Û+‡òçkô㵪ÑÑß Ÿ¯EЉݨº¨Þ“dºOò B4 y)ò<ê¬èïçñ¦Y>^,Ùc¢MŠÏ1öw~R]ãA󈯾ÎÃ^°¾ºdÏvH4¥D4¸Q•pžù»ÅfEΛÝêÞŒ%Oኾ¢±êX„jsÖŒÉU§™®þ '—sêÑØ¿õ ÏšVkI7\“bÔ畘þ(Äâ¿x!(ÁAXÓßRß%ª1¥{aÅ„†ŽW«ÑÍ‚4V´Ðuí?$¢Âö,íYñ̾P0£„¡™^ô€>Z˜Ë¿s2ì¹D… šqÝ9~@<áÄÊIfñ|×\Œ>Ñ’S·èwæDNàfš`B6>hhì* Ù>…nè$pjå%.Hº²VÆd˜S?Ò˜S3û¶!ù!tm?^äM{/ðØWÖ;M"µu5¡¥íG­Îæfô Ì*Sžt“ÆIM?O_/w}ûêÇ}š†#|Íî_°8⛟á«Ã¿Eç'Á㿿Ϧ󦗃3ï Í7‡ÒYN'6ä+X+­à+}ÐRr!)þº¹ `¸MSÅeOg€/?H=¬vqŠçØH¨ŽÙ%G¬Ÿñœ˜MEZÐÎZmþ%åáí§9“ûÍ¥$þO@®œ LìÊ‚äýU-ÖXìøº(rÑÒëA2¯(}ßG×(«þЋHdwÕwièjÖ—NÔ1ì-Éj5§¿… _I’5µp«Å;1K;A»âaû$fjNÍãub¡Úq:h`µ*_ðkV Æ4 Ÿb¢l[`O8ª6õ­ß@µ©¬í‰‹wŽ•¢ª3Šúv³].ò˜²÷ eùÎomÓv.ázÉ–F•!=ᎇ^›Ê:º&|ÈÜÔ_Ç’>\!3gÑ”¿Þæëâ¾úïËì êùk¿~,”¿äðÀ¥×t^iE8ÚÍ«¶rö‹i¢$ª²ûúz!?Ÿ×¸¿-j%#攟jÅø«VÄßAµŒ½¡fºyt€ù›0­NA#ñávöûG曀Ðò0I\!Ó M½ŽÌwBÕ$|5ßN„v­’wÅqº²ÚÙ‚?ù Ö!â-¶8c]@’Ê÷Æ®_cÌgI›âé ã§Ë¶;<¢¯sæ ädj=ûŪbÛ¹÷wêTÞ£…sŒSvŽ)" f¾[µù˜ÔVäÈíÚn¼GîÌ'‹Àw5þÈÝó>\S^â¿TwÒ(·aaÌïiw¶£Öcr[Û‰Â*Iõ6îíïE[‹6óûÛk5å=›|)eï„Xt5ç(äßo56 3ÙõÎ ·  êÆ®+&Æ0 ÚóPG¬¦è.$;ë_æM ŸñŸä`æ–8 (ºÁÅuº.é ñ÷ÐÙ‘&yæx.ô~ÑÝLZP'`WȈ•bý°Ü›–ï`âg-•K¤-ˆÑÓ@ðѪü 8Ó-¥Ùva:ôžÀ½ÕÆõ‚sfš›žÐØ¡¢ /gèÌŸ° ÕÍÏ•¥ Ýn)èn†[}ÅUB"/ÀW³¢Ž¹Î<¥AÍ’8å ¿>U–çsBw¾Ëz‡ÑtNòafµNZ·ê g±œ mâ¸Û Ó¦‘AXÊX Â ¸íìGù43}ÁC±+£¼„‘*õiçõ.€ Ð^£N´T<©Xa>°’1 ±B‘U0—N?ŸE¬%<§æ.Oó+¦"G­xȬxekÃIi´+_u‰†}øâ);’Ÿsè:'{â$Sø -ìžG¾ÐŠ-óó¹ˆçÀÇOÎq‡yûs•tI¢_oÈ>~4%üô³)åç_ 5mñwã¾ÿe,¦9á/¦”Ÿ 7nóãg7ÍßLüß_ÍèþeÜâpi‡:s•D ´%Tλz1ø|n4ðËi ,©æˆýÎ †n+¾!o¡…`—Ûœ°wt2¾˜, À<‘/*Á&¢iè±[æ¥ûÄlùf‘:*6F¥bŽÇæ:Ó4h¶„L¹uRoîÔe£#`|‹ÏëD‡¡§sBaôCM´Ý€3 Ø8û4ºˆ~è-¬Ãn}<¼ Îmø¦ýd§[ɺ1å𞫶ü†¥"6ÎÃïîÔ_!!ÞJ·NÚŠ›àÙ_…‡þš‘ˆy5äƒj ì±ÁçjÅÉ_XPy^•žøA5*½v­pxÀ;±/3IÑ0d «tá2ÂúŠ;ÇM¨f èHšoÂ8°¥ðRd€8\€ýM< S[3ÇÌRhXÉè“‘MÃq¼Š³k…(­Ch&Ùõ©¤Ô;Ø/¼ÀôÅÎ`̬¡|EÁ¿ K×-e£†_åbO\JíˆuñYÒdË&Õ%"&kœlÕ2ß…M&üǹóIàÅúÍqåºe[q~[AX7¼C_¡9cïaÚËW¤3¦¼#^1§K-<'«„;®àà@Îçð.©Å›Uª÷N’Õäbdxzñ(tƒ4Æ3‡Û[­‰òuÝ-Z¼®5 Íù»hSç¤Ý¶ÝN ìHZeüB»67.ÛSËߌ¿©þ ½ ¢Sa÷,_K8Á(Ä›I%•ØN•;%®¤RKcá&‰º…bå'"«ùÊgÆ’*í¿8ëèbƒÐ¬@mV/ÉŒqæxÖ<ÌoЊ ïØ9ÅÄÔ¶b×åù‹Ìh*èUÛ|ä›®9‡€_VìÚ+†Nìå¬ßšžü¶_ð¶‚õ¡àÚ¢ïÙ;‘.;DW2Àò#º¾`*×\ïÅ–þNiRUOQ.ÿÆ»„Êï zâå¶þFIs3â–óºÓ-;ƒ4ܘx10mÉnÇ“&Ò´ük±¬üÊTá«êÃDæ¤Døá6czÊi"’$‡Lh<ÝlI<û£QÃ{Äý¨9%DÚ걶b)c¦u§Ö(×ÙÔr ¾ D8{'o<´÷#ˆðeâˆIVµG_ñetÔVZ~ˆ—¾ààS^°û ¨jöÙNX¤« HbG °¢‚a¯sfr/9سÆ>&þ^«b>Ýpª½îNÕ†žIðéâ TSµ ‡—(H®52îí‘<¼)Dô„coØ2eÊ8ï+÷¦¼(O ¹á'c4‹q`¤|ûÓ“µ0ñUW@Ú.€x×QÂQWÔ8µÅÕHÎAñ1¬ù>ÙQÛ·ßR®ÏvÔöí·”ë;jûö[Êõ«µ}û-åjÉ6‹,nsŽÖýÌI@œØØ:^æ±è«ÿ?¥ ¬ÿyýõs)béí\:û¿¬/Øyºúúér]_è©ûßÔÝž; Ï®ŒlÝãú}WmÝgh?@hFSüFv®WQ È‹AGš– … 1 %A@DM±§±š UZÝm Ùý{ß3QH¨ÔOøÇn*½’dl0Öã1õUI¡#˜üûOézš¢ÔW³Õ/;Î)fÏ#ÞÔÓa|­žj6³JúП}³$òÐX¥š[ó±¿3hj¡]¾[©?(Pó{,”]CõúƒZì 1yúEŒ-Ðq»Í±ËzAA3&¡šlé®gcÐ'&V=ä“v¼Ÿtëד~åyÒSè_ë“Ñ\|ëü›Ékýfø^¿¹º·áàÅ€5À§+@Ôøµô)\¾Øë Î~‘Œ½š€ÜYùA%”JhÓBï“Z+'¿Pÿíó0õ™Õÿ$[kbº'úËõIäT?øÒCž‡¤œ3lH†/n‘„-)L±bå¶ìâpUÔÒ›ö|P§ø1ÜŒÉëñ—|l?e€ËÈÈfĉ4Ö FìÂjæ0˜“{íþÖ<Ó_NÂ7ê?ç/ÿyNƒô‚íHØûå¶äc1o·!¢è`GCCðâæ€Aªæwiq粯©fþœõ†uç€^ƒŒ¥ÁÕfäzÇd·ô7|GÂg©çîð`cœwîÿŸÙú[hÔa5<Ãzã7N(óŸŠ«…ŒXœKÓƒí. ÅÙÄ4Ýx­_Úˆ…,¿—µ¿Ñ§ÓÓçÛã-I/ªY-¨Ù›Ø\7Cš4áLÑ]–ãÏóÂgY.¬ÉfßÍ‘÷oâ‹Ó\—äµIsé/…±ÁúL “½)u=²¬ˆ•-mˆÑÿÑ:5c” 0f9¡§%ÔY ‹o¬ÜèÑS‚–ƒ$­Ì¶| c¹Ä/‡½o ŒÜû8O@­œT]äü*}UWøAæ|ºfáùrXõŸº‡08~c†|bã C÷:›E7ëÿþ ×i N¿/¡ç4’²ñ<ë0î5Dò·î^ªÏ±ÚQø‚7ì—Àå*ø"Y\°÷lx®\êݤE’lq*YU–Ù~DàÛ|$?rU¢±€Îw‚†»ÂQ€ˆÆñJçšú^4tvëø6ÉOEŠ3y fívæ…˜®ì·@?qö&Í»15ððœËº!qªè‹ïù¨awëæ¿áž k‡µã5±µ®œº™6#Uÿà‚Ï@þµ½ï.* ÍXø¡îLýtó%ueW|°+àõ]þ¾Û›}ŽîD^®2 ~·7Œ{c)øƒt¸Óñtn—ÀÎþ=·}˜M#ÔÂ0¹OóÅtnÓôÓòûíÓÝÝpþs+®­¸>µâúÜŠë—V\¿¶âú­×ÿÚp}»#ÝJWÂÃÜ)‹³ÀR`ß2a`ˆ)üPÁe“Á˜lSA ;y[>QÎc3v–pÀ`“ÁÂý6õxѽ³©è®á ìð¨Kî·)£"ß#sâ±pQcFŒL~ªîPØ-_çw/p1ö¤jwBgç»c?|&ÑÍ,ªC[Têy+¤‰Q×¢ [æÉÄI>æðêE†DxÿÐ϶Œìöåƒ[B-XÒ ÷ š¨"ƒ/V1LT¥ÒØ¿UÞ·Fcí®s<ç<8!NŸÞ41rzvêÆHseˆ?ªdõU™¾Ïå:¥Â ŽØdæ$Þ§ˆË$@>ÖB{ÌNeú3Þ±cœÚ`åCM³r ÑñÌY.&cr¦J•,]‡Ù ZSU„ÍŒ…\]¼%çªÏiÌW ï6ÌñŒe4yG¼e¥qæKÃÈž‡çˆ{­3FLØÃ:[Ò„MW…ÑrR#Úìç,9’6‹2Ò´B&©_R%Ñhú$B guJFÖ´NF´Hp˜ËtN½X6eY,³ºœ¥ú<–ÄGã |¶œ45q+’Íö7+u·ð"å …-€´L0 =«ãôÕˆ—ñú?ÒX}Î+Ë Ã7AøÆ Ö#%Ù4·l]'^¶FšAæºî”ýŸ¥1âø S*•W&ø½w<ÌÝ\/Ž[%´`œ{Çm4Æ—À¶šzáüÛ‚‘'Uà^b©ãm? .Õ‰Kññ]ˆ¡Å±y)ÞÃ`„‚ –Cô8bS`2Ú ,Ið-ˆ¶ó8¿Ñ§G§ª ‹e¼wž1w-¼½EL}ë, hH-_œÕöRŒâ9AÿHLwX…ÙèRˆ(¹:†,¸†9ºU†+ZÀ@J™WjÛˆÞU±ƒÈ|÷R[oŸæ·‹3šnYßxügvÁw )Ï8ç$Nƒ„m¥š„LÿÅr\¼½vM2V>¯Û5p V¶',#^µÈ²<’eÄþáÂ!„e䨶Àò3Èœ%ÿ¼ìjªb‹òf9 —wR÷4ë>;ZÔOŒú‹11ÍO#š¨Œa÷ÁÍ@Í 5V-r.»Ì¢Û"]ý`³O@¦ÚQšüˆÌrjO{ËâZT™ëW=¹rô,ùbÊ ³t‡[$Â×dðžåÐX ˆ¦ûÞÖtਰµè!¬º@¬¨Œ2HÐsÝt÷öbdGı›: KœõÕø%u÷8^IÝun¾Ñ]çØ[ÐÆ£ží5 S•‰Qw"ÒtÁŒ¦0¬1x;Sùª»wÎqÔß ”#—†[ãÑ»‘t'òþ–¾ ÞÀœl° …ÈûÛƒ:êVÕsrÄ9õSžÿÍíœ5§@8Χ~¹#;rIJSU²SÆY?ƒ6 Ý•è+lƒëæÑ/ÿû/ƒ#ÒºÕï¿5e"Õï&RýúóïFD&M}2iê“QSÿúUGDhå'‘écÔ«êˆð»ž¿ÞÍPüLZ $‘y%rtõŠI¸\ձɑÊjzJ¾PÔñã"œÕ›VɦÈI'Î~&ÑA°5<ªTÝÞnß/ãpiÖ÷3Ão±®á$u…\¹ìšÓC߄ʾßڃ봴ëP&À­ïh\ Þ±ð&1äïX|„ A¤–æZ¢ÀÚ¸ê§@D|€ëýèât½Ò_XaIúo¾§3ǼOéACâ)VlÜ%3Æâ¢ß’ÏÎ|1=…~›î^Þ\Æ~ãš6流U†j(³øæ€ï$º%X‹©ó~ÄÝ9o{&ƒdoxùšQë¼Jä0ŒÃÐ;¯ovŒ3µƒvaÅ’.Ž—2@A19^Ýhœ)¤•ò;lÃMj_úz+¹5‰áÛäXwõÈŠ9 Ë]‘û¥aÓE {Xëìy³¤4PÒÀ2*@ž`4NÂâE·*E­ìÚ…$*ÛF‘§QÐR²”Ó‰»%ª«‚ìîÐtÛÉÑãr$Û¹³Ãºe4­Ñf¢çâ½ÄŽ6%×\¼_É?_£ä‹tu½&þ*çL.üUN›#dŸ©ºvqé%ØvŠý[‚U§âÃΩ8Ð1­êÌÐ]Ò °†© "dÞç{9Ë,Û?Эšx™» ÖIÀíT²y“û¥j³bžÏm¶+Ö²ä.çÔ¦A!ê1üh¡ŠÂ0óöû­E…×_ˆáÍR?8žGëø[•öœýþ ªw•J'Q¨fÁs=Ø©R»Ÿ”=q^ï?0~l GRcz˜¦k_õV˜Áд5t6T´*è ½êä¨3k5êìOKEÆeéaGÃÿ¦,®µæ¡ÆAŒYù’æ5¥¢þýhÁb) .()êáaÓݪ¤ª½CMXº¶Ô–!SÁwsþG Á;Ÿ^Í=Sê•1¼qF æ8©®´!§f™ ÉŠiÜ9ÚŒ·üs=ç1£*ÜœvâªÎ{‡½Uy®æTwtÃÒ ]LL؉{Ÿ80>šîÙø,#§ƒ2¡^ˆ#T¹2îGÔ5ñ¦Ž÷ßQZ]ä(ʺŸ;°z˜àµpBØ:?2}^í®¥0øŽºw_ý©ú­¤øê¾fYëZ8 ÷ùåÊ…Ä€œ">ºIºµWŠÌÑÔd,:”Â^õ¾Ì/h™"âÄÑdb™ö'cXl½1.Ž$ÜÏóà~Öf°ô=—ÓÁÿ0dDf"ù0Ÿâ?s\ùÓq„—vGFll@E&“Ú;o“‰cäô…?û4Yë È(FÄÓq1=_ÁȈL}Ü𧩇›ÁBqn8(`9»†Ÿfã 3@‹--¡©–»™·k³ XӬǟ¸–Y½€C§¾wM”0ÿÕÚ¸b€‚½〬Dx=aÕ9É–< !WÇ…óaú5+¨8ÂŽçv6&üÀÐxnõ6Ý`ß”z¿hæ@&G?ÓÓKj7é\kdå|Ó»ôªü?Ù=ÀÅýAªÒüíªÅÿôËU‹ÿùÓ5Šo„Úù>?\X“©¬Lzà÷w£AÍej›Šï½ÐÃŒDèaýÊÿhvuš™´ÞKWFíz?ƒ ZZ7}ŒÂ}*HÄ|z',Ut“M†‡,5͹dY¯yu°W5sîëÒXóÅŸ¬n^‹ïª¤aKtÑ‚|º^Ǥ®Ê™ ¼x‚æÐ&îÍ WPÁ‰sjOzú j0;ɤ+Ço•½HeÞTÏuÛ{ÆÜ;»ŠÈcË~¤‚¤ÈÆÜ5…Ü–¿»Õ:k~ï¬ü ’õÈ^ļ²wRûæh¸Æ³–hý5mCajÌNÓŠ¾dË_Í_eË.ÙILÙ/”õòí{,8G3l?fÕȶ6Üê3Ýù3æd]?–¡Små®@µ`>aQž—7S[æ³x7—5óüª»5 Zo¹ë‡¡ D„¶ç‡ ãó§ÙÝ } qªvñdÝ ÔjAtÖmÌb’zôTIP³÷Ýó´‚OuB#Ë(%§ òÕSÑñË ß#·‡ÿˆ T P¢4sS±i¼EVϬ´®³%^$R1¦+̽+TwèÎ)‡Ú‰ö¨á‹¤Ì¡ùŒ;ë×ȇ ƒ-‚†¤x‡3'BósÓaBQŸ)çè÷êèÒ‰<øº [±’9Má ݸC9çM>_ ´e&kïJ„eÊq~»\Ü,+åèè>‰ÂXe}¢E:ó’õ‰—MâtŽê…ð‡`Õ:ñ ×øØGÃA=Z|6@ÄŒ©ÆSùRïñªgÓ“_(ô^5U+½(qb·Û‰›tmàuÓM×énwàK&Oæüý{s%=„ÇM[´BÖp‹›Ør²õüG^ŠQ‘êákc£>yLxÿÕ)þöý³<”—èßû¨qò>ê’òx:ÿ"ﳶ‰yï[ïv,ÊxÖKèNô {ÎFÛ/h{v6¿è›ÁpCÁÉTfø÷Ðalj“Fî19õ'cjË,—^æÓgXSf0Y9s²a˜®­ÈM}ˆ<ŒÇÚ¦}†¯Lx1úˆª<².GCzäKJÒìaøŸP6'ëËÓÂ"$“¡Ì-C5e— —1û Ý#ÍiÜ'v~³3ö¶ÝË\3KϬ‚¿Í8Û}ª'ÕtJr„iØB·Üy“ý…GXù€•QéÙ_Euþ!AS½R]VtnГ¬ÕCIœ¬ >\oâ¼Ê¥c¨$É "X¼…mŸ „·©ß):ÛS°{åPÃ$]YHÎ&âçf'<èkž°++“BxŸÓò–‡·È7N‹ðà-©Ñ›<²sBÈÊ[5„t—á)±W0ÇË,Ç@‘š^(„~BÒdk‘Ë-÷Ì® éÌc:]÷u®Âû¦i¨ DíÄ0ïƒe,sh3Î~àìöj±»+`}ߥ¡:$·Ã»PZoÖ÷óh^hÌ[ G¿›ï;‹ùÖÂ/­q©ÜÁ«q¯èâÊô0ÑPðyëuIíQå#j•—šW&9jÛ¨Dõ?)s4‹¾.ÄÅv»‡Ns*BóÈÜIF-h·›9OºÈÒív4×âŽæÚEºy¾ÓÚó×ë>‚ ©8®Æ¿c]·aýa‰: *Oúµc]Áu|SeN~â¯ýI º7óü¯…§Å„Aj`ZÞÎ’Žò4µŒJÿû ïÉQMµÅ¬ÍL;b  Ž‰Ì7ºy~5sIËØO WóüØu"e7Jœäuk”7O‚@¤…¨nˆ¨ÜߌÉëñT~9¾Ž¡>‰„ˆ‘JÉ¡»¥ÃÈ©ø$ZRÿé1ñøÎŒ´ê´gïV…  ¼zQº…/9†êP,«)ï—{Ž_`Er#•ìïã¤à+5ëÒDQêÈ»g¸óãX»CžÛ€<Üíñ)Mäojà=Å[DÂqëÞýËFñ•…è«wQ¤T.~“f_$#‡“#Š˜3\ ¾ç麙%L*&P3ÒŒ:9¢Æ5 -Ã0Ý•>·=u·ì:G‹ð8ü»ÄöwªƒnîÄ ýú/—è×|·‰¢!yýÌòSüVÔ|àùŽÊã{x™ê9ž8ÍóÞ¶7þØxå"T&xeB6T“Á¥+É–Â7"*û€ +—]/_HÝ[Ø:‚X3UO6¥m—Ñ3‹§!½*šøJÜ4ánâç#­s³Ç‚l¾|Iø·È¦jµ¾úø>¦—‰ÞP÷Ñ•,[7+Õ<¶ŸÜ9~FÎEê–Ý+êiEÅñ†¯WÌ;z>5ÛMNƒ}Né°;Ë4Àº¥ÆN¯¯{%w-!AÑ=t]å+£½†Ï[øTæÄe k즵°ZÇu`qZŽF-ïÂѺfw¬¹©à-gMÖ5úÜëôÅsw-ÔrôFãšb:™h{·0lC]Cóá¼PºÅPý0Äã?5$‹%Nùð‹šn4_ªGi0UÁàËÓT-îð¯ÑBMq×{k(tŸåÝòß3õ×ò0],Óoêù‹DOð zý%Ýh0WËh¼Ð ýèq6ŸÞÃÛV/£Çå\Cðµ§þüGSuõ§†&Š’b<Δ“»ÑXý‚&ãÑ£zVê°ýGÓ L¥ÑƒF˜ÇÞd¸œNÇÓGõ¬z|_Ìz}$%ò8ÔO3 Ñæ@d2µû8½}ºSϲÇé ·ìéH†êmäq:|Ô<Òtø×P½l?NÇ}õ, ÝDyœN†êï(4[ÌãôQ÷‚¦ðÃ4šéÈš­ (Ô_hV ø·î/o5»h— Ñ­@2œÌ4û -¦Ú7½Ôµò—fq›ª{˜ÎPP}”T³¡fµŸ*P³‘f“‚ Õ4ÍÓ£^ëÃíe2ZLzKÍ ‚„† .Õ£Í( ‡Iµ›ö¼÷x¯¡Núê/H`FªI¦š´M£±œt¶xxÒoøq,͆r¡V‹¹FìÅ|¢YºAŸÔl3ËÑDO0˜>©ûõtÒ{ü7hËê²üky«QðAÝž«ù6}nǺuè/ÝÎçĈyõRÉß¡´#’ ] ’bŠýÕ/Q€¦¨à4ÈÚ’üê´ÎÈ.ªdŒŠ+Wò|—ÆDTu3q^ïú㓽s)y>âyœ¿í<e'­Î†…]Ž5¬¿ÿKc, ÈN䜂åp,8ŒÙÑûµ 5’ún>ÅbŸ¯ãsxL¨Erg*=@!’f=ñ”^£F’¯§pE_óÙWÊûe9väÄ[!Aàïãê½H†æá»Þ¬±»UÉ:¨{fÝÈ*t½@ÃI,€–âÅßaç—ÔŒ5;ÙS®f»ýFöŸ ‘û2(Ú2E„1šgrcfO‚÷zÇ»MýÀ3‹“gôƒÛUz‹œ1œòý#6QªSHëàÊX9h¤íêAÄ1Œ¹Í†ˆ| > B&ãosµÈ›Ð¼¬øìŸxÓpRo©¤¡<©ÐW'ú**sþ „/ònhQÏSh MÄÚÒÀJ’P … ^1—¿Áл=èâm‹"MÔ­¤gfBwT^Ã…øø¤x qÂ}rýÛÅ€Õd¿Å• ¥$Ô¥¸vA"D¶WbD×}D^²Mo#‚+Ó½³#â¤dÒšŒÓ %„qp ç¦;S)Ï4^²Ü’P\º¤‚òrÕ­óÆÛRD”‰ÿV½(™Ë–ýÞŽl²ÕFµ !ßÙ"‰zU-éhZ;5 N‘¬àø&rç"¡«2«ÅOásˆÙLŒ®øÏôzæ,Ó41ØU^˜Q»º‰càuvŸ)v$xx-•mRú Å®³Ï#uòµäi>ÊkàO†t ®óI"~ö»m¼A^0c2¼j³B¶Ž}kœ;í\ãŽÓmßzpø ·záØõ…†œT]è±Yßzîù·E̓KòªºÇgQÇ>ÕJQY•¡Þœ’#-×w*KËKEY_SÏ›§Æé§HîóÙ ƒqÇì ä k~©¾èlqaç«qžNeánÉŽ4ò©0ú[Õ³»hé²e¸M[–‰!ë¤1n6ê0.òJLÁ'€Ôèãõ:Æk–ǀЕ})¼Jü¥@Ý—’3˜)Àñ-òÑÎW­ÖX꽨y2Wd[@ˆ#«ÙbÒŒ‘Xe®ÂX1ÚíˆçøÓ¶ÜV­¡}i-yÝÓ¿ßJIl¼°0bÏÈÄI…3¹:%É-l΃¯Éϵï¸ø Ë ¾ãäcý“W~1'›“.Io)ÍjROƒ%'5|ó§7x¾Š}‹9í’Þ?ôÙõ¢t™´ñI <¶ rà| ‹‘Ùã2êȉ|£O®à0mü»ë~§ûDhê$?â{pëÄ™ÚvKipÜNîœi?ï©B—çÌéœï3ݲI)”MÝ *Æþί]‰@°sò¸‘Gš,£4tF0›Œsº^Çõk(™PìxTXÍ‹5G}šÂ¿x’%~0 O*©­.lš‡ =gØöù“fÇy|šß.ιÕ@ŸÆ$_$M§›/©ã1•îl’šÊ"n)‰ÊéV³+ùVk÷ô-®íïüWâý~{øø¹y[†þ"LZÆó/àùÕŠÇ/ü3”Il-×.û¥áGgÜѬùAOzcE&p^@‹kŽu…¤ÄíU€ú`B^ëʦF£Ï™™>ºu¥SË]¾F/@åˆuûÂ$áÙœM槗Cª'°š&ifÄh‚—ðGÎ4˜æjÑýY#è|~r3L×nñ È7h˘Cs0¥}Ö3+-¬qXŸh û¶d•it{Ðná]-ºi4`št–.íÍí4 Àò…ÿiÐïðö({ï…DŽ.Kßû~„9Ñ!°½wñ¯÷%à%tï”­çØ]-Kg÷tä{NÝzÑÝÜ~ͼjÛs.iKÞv|:óìì“i/ºì™#­^".“âÂÝã}™@é{³—0&ëäb‰˜sL>u9RPx#Ç[ǘÞdI<¯ÊLÄúF¨E/e}°¬ÍtÇ [Ð?{žÆ†Ò ø)ö¬{“Ñøßß0Hp¨•­§¢,¼*rë.žÆck<û•¢ÐÖŽ\í?ÂX¸±fý­CkV ©¹ƒs †ý$V,üJ̜ɕ\®·ˆ1Z{,EúJ|í-ÑÝ›÷a©»´¬½%}pB¯îç)hÍ IÜm}GÖfæà\U;‚žIå%!õG`\÷Ä ð‰Qš¹%¯UNjQÆ¢ ƒAù÷Òsþ³Â;þu=‹œš´@©&5É/¾úlÈ(§?B™‘²LœÆ”ÌãˆWwë°Æ&C˜hî¾#ý^ <]&±ŒÃéÞù;%‹Äßïã\ˆÈ˜ùyXv×&P…Ïöù4ðm«ÅH,}+úÜä ´ÂÛfðŠIm/¿‚=œÉ-Æoáuê\ÙëÌ»%ÿœ&ðß7â<k ­×99¨ß„”'‚C[pƒ)&Ýzi98Ä1øIä¬U âF¯ fƒ¿‡í#7c_”6UÞId¨íT× î`ñÄyÌX^å‡ÆP(Mn ÁgÝÀq]HÆ—ÑÔÏHq ÈÚIƒD>‘üXgƒ Òx{§'´:œ­ý(>~/=øR~d…Å«–HC³Ê¼Ö>´»FÉ-Y9HtÔþà/,hD_-–7cçŸz "2\\œ,“Àø”î›ò¢E¿_¹{:ǵr¿*´f¾FZ}\ìÕJgÇþ5«R´HÊømýµÖK!X+[Ò¬ÛÇt‡~DY1LSØz\ŸNÓ}ZF3XãÇóößWSet2 ïû–Æo‰i·¤Çe³…ÓdÞ€쪨À]­îêjî |ÓÒ‚…ߥ蠆i76‘pŒkdêáÀ¨ä”\ãwÖ˪5úëšLJt©uzëÂ9i}礼WÍåpG|!¿(虫~oÚå›?dàY¹½èxÅŠ…K4¯-ÐPs…2”úûUŠ­9)E 5åN°ü¨–†s§A²Ì–%¯ãXY÷u›O~O®(ú?s =’|G_%ó ¤»ýѵE ²dtÓ5,«1ù[I :ƒ+‘Ý÷&“^]ga` Å…—~*¤Ö‘€÷} ƒþ½Pß•“ˆKw-òÀɦvâ!IºgåÙAÅð@Ô(1d¯ü„¹q©86kê}ƒ2HMŒ@G]tY±»é× œÝþ"ƒÍz^_¢g¦+ `MG=cÆKôËo÷/б¯ ¸ê¬Û}¢¹2ì¦gØo.€ÊÍú½"7ö «ºæ­ mô~¼ÇPÍŠÉÅ$”ýžXrUì %Œ{[jÄ8;¢Øý8ÞÒè"ß$fó/Öñ…–ƒôRûzz¡•7½Ôü2D>¾Ÿ«ªèØwI×ÔÚ‰ó,Ttß ùÞ àX¨ gé/¥¹ÓTIPŠ£ôý’Þ_×ÒøW`xÈÉ2P!ÖãŒD³À íòTåU}gï¬ü r_׊½|‰Ó¦%Ùí²+»X²`lÓÇcYyµà›“uDâí\tkhÂÿÍ÷Êø&œÄ$ñPq‡Vs+:¤êR6±/pâïµ:É™1âò®3t¦m¡xš³ LÎÙÂf¸Fò¿êù=T+¥Y‹†xùÙ_¦;GFm&nNnº]dÔvÂígBîçÔv¢ØEKßó”vꦋXpÞñ\Ý3ÿ° Ï;’hÁ+ ŽsJš°;]võŒ?•QÙõЕüIs²'Ž`SÒ9ÜÔÈãONmgº^ŸÞ†`{Ö7qØ—6!­ç½$‘u ¬b|œ•)’gèÕÆ Ão ó0´ÈõË Ž ®"NM¶ßìqŽUà ò~åÕ]†ïû¦…¥›©z±d’åÙJ«àW,Pš'¢­\za2aEŠ†f5oÉ'Ÿ 0íŸBؼ:qêDž5 㲄ùg<Ä»µîlóYüí _¾¥n>¯tý^äZ¬/›>bGm` CÓ ßMC58xCàï-.Â8Ã_ÓÈßø¦EÎóoKžoÙ-´ C–àÀ”ÅlŸ3ØosRGÄò…[Ú7ý¼p˜%ø2ݽ6ý?¨Ú=ü¿[ßüù¹¯ŸUÀQ;Ÿj8˜ÂjÆ/ê¶b}ºúÁsiÛ|ìÌoEŒbÙ~ˆ9ŸíÇÈo¿¥.û oÐÍ_ŽùlFÚQø‚NV<Æ–1‹Ç4¤¨éÞÔ“œ[?œŠücjŸ5oLÚ¼€Ò½±ù Z‘Z l§€Å6ñ׫¹ð™M¬ÇÕæÆ)Ga3ÛÔÍ™~¹ ‹lM‘À˜låF8ôÔ™ ¡x͇ëîd­ý˜X#ÏÒʧÓ[93ÃØŽ óÙn<†$kFK²³?nH8Fï\ÉÕÅQÙ:xe»IM£§´:n@ß<Ÿ ÷üRJÀ1¸é_Î ‡Èðã;Vþd8|̦k`ÅÎIM,ÏﲵɌ´þ"õÊˈÝ—Ã ³â:hK^>&á&ÿ*s²|LT&¨[@UÒK5Kv X)Þ+ÐË žÂ˜F‡æÊ,Ù¿kßët7Á×Z•—*ßæÙÍ„-×l[D\^Ï0ýðÉ{á! i%kG»!Û~É#H-¦¶mŠÖ‡á‹Ñ™€òºêŒYêÁ–«M‹€ÍÄ1Í÷Ó¢p 1¶©|IiBú[1Wñ#W|hœá¼Ûˆ8ϦLðùÂÌÐEP!eš$ToâBÒþ쩈˜ÿdUNânk®ÓÂîrBøŒÜ­šrë„ìä€×qÍˬF^rÞèèa^Ú®¡* îs3žkXGë|X·áµä;ç’d~$²™Y“íì:"ÂW òl†\ÌCb„ún"LÙëÁŠ3Úi3 ÷O„Áð׸¥hͪl¡I1q%“0;ŸÝÁ$o¾ ÆMžW€šd\ãì/4`+î¹û8°ýŠ.ùAÔžâÓU>_ÓNÚ ‹_õ9iׇOÈ:jNiÂS½ÏtwV/¼\”y°ºKs¢K˜\|γ£Õš2Ô¿ˆ”Š”%š’áK~/kD\oÚº·œš¹ÔpDQH‹@Ü~ÈUüæ4 0ÒL¹CôáíWÇ8—Q›&Fârn]®‹³§XB,’gäUlÞ‰á‹TÏ´œËF (óÀC˜tsßæ •d¥UM³¡'¾ æìù-%L0³•¡Âbº20¦6Æ›tñ‹)GµÚ‘Ú±u?ø ´ Ú¢æZÀ ¡‹uïtGNÚ hœÜzž&·‹A©ŠMQÎ"´¸ÊêÂqsÉ.Àí‡mÅ¥ðX¨¹4d%\þ*r¢ÃWØdts¯b%§!¬Ê²-èZz~Òܸãb^ÁäHç|MžFµñCÓ½aâì?Éq5K`]\„O!zV¾¨ :+Ö¶›[fs)f^oú]ħ¡~¸s4¡qõ¸Ïye¦^aÕ(›°löÀl;’lƒE­pëÊ~Ë6ÃRus?ĵ¥{‡bÕ:KÓ?uÓöt_Ë™rÏËj_VVšqüdÏt1ºf,hÕ“ëVqë‘>M ´اÙ)‘iÂu]\ª óýžßŒœEG°ÝãlN—3ÝâA¨žj(««|•:fxW¡ˆC‹°æ¢ãæÚÊl3ÃÛÔ<ÒC)!2e‘f¦ ô;‹TÃ'@¤xõ F œX5‡r3‹ûÍü¾ŒGéìÑÂL”ØgZùy¾'þå_Qá/e:Ê>è‰Ð¢'ÿðKL 0–ÏŠÕ¶«v½X÷³ ܆-X6eU³~] õ»æj^·M¨KÉ]ªNw+ÒÜßsÙ^®oîáy­¤ñy›“ <^`a FrsÛðœÄl׸šçU"¦—¡·Ñ¨Îë]@´ÚøÛÁÜ"#Ù;Ìì|Å7 a$dþµ3 S—ÔÊæn©º9u³JlW2{ùFÌ\Oݵ¹> SøŸ\3Öãå¥À y /BmÄ9£6µH< Ìm¸DaEöKPwØ­hà»pö~¶0oCACÆ~pZ(h|ïê%ím' óÛÑ^ ëK¼üöTtãÚxs–m©6]÷•Ý™³mËÛ§ÐuÒÍö˜ˆg=âñ—òš!9zQ7eFØ“f ¶dw+Qæ05Ca=‘³ª»Ãëí2Àtшq¸,0ŒÂøt½ê‰GËUñm0 8VÔ‰ƒ[¶ªÄd1YOኾï [¥2–%¸'‰eðüPžÐñt•›õ—œ@¾ÞhPß«dÔ—z¬râ¾ãÏDf+*Üö #œÂ©mž‚‹¼: ÷[Á(?ÀG;»è3#Á¾Á!ÏC†äÒ/–/$ñ]çãÏÍe­LŸÚ0ýnÑâ Õ ^øÁ÷<«lmˆÈ]º‰WOdP}ÃMÍLyò\ªèHoŽÍ-LWýÆÝf!^šq>{„×w÷áÒgPÑÐ5Ö,ï3Ft¡Ó`Û ò –ªã™0§LSWK0&k}+4Td̈ælAWS)ëo¡Š)Pâ-*šþ£2"8±ºH4õÌ1KE8q< ®àò±D¤JîȪ•-¨Yµ£@ér†¡ë“¦ža(HPSÐ ‚¾ž…ÑkɨºÓé^Ú°·R>ñ6’4 ƒŠt¹…¬(eæD,Ó±Šê«z:bþg´•šÐ`æ_Sº¥rD J5Õ«rŠA5~ñpÑPш¹Vª¨î0·åÓÞCí¡Ås‡‰ütä.rÔ2¤!_S“h>û,ëU¾ô îºåÞrä–Ob=û|{"·ò i>Æ‘É62úÂFš/Œ™•”ke-ºµª0-·nöƒä¿jTF£[GGa¬]kGšÑµÒ(Š4êËØÙ­…¾nÃÖ TëÖ íš`°„VíM¹ª?ªX¡àÿÑ +±QaêÅcâ¬ëe ¢V–}aµR~k ísé490‰W¹,ÝÄBûöc™lû©òëså×/•_¿V~ýVùU¹ôÂ+µ-Ã~ÃòJaÆÛJÉ=7ï²XÅmº®ÓBÑ# ´ ŽZ³vÍ  õŠ4./k¢•²ò¡»¥õ²Ž+›-¸Ìh5%^öyMízq;ŠÙøxµÂáô®V‚vÛZÞô³ÉP-^ò,(Îo¹«}­ý¼Ïe9sKÖ׿ñuHŒl“Ñà@S0(®¿sts!ë¿Ü/+áÖ!³E×G¥ï¡RïÝúš4Ÿç¾ß^'hk!ö8Em(tI5ûªža~ÛCñ-©..¿·Vê ŒÔ{\ÌõŸŠ~Ae>°öe0)ôÉÙ |˜×B©¢¹Âª²´ãŠ;Ø‚C³¼ û²åž%ŸòâÁ+‹J³êi>®•U?ŠÛêš‘ÊatÉë1¥Í þÂB†lê®X1׃—lðNâï¸ñ íþ¡ŸñemÀB'ü–ûb¼ÇxÚò$Éž§,™yâøa.”4 N-Üå%ãäùÐÔ‡LÔ4gÁç‹Hâ!+¨Gÿó†û¤~húy”rУª^F«­¤Á>òFSî ^pd¾á%>VÀ¬]u"¬,ŽÍÄàx1šÖOh£éœdgüO(YR|’†¼ùã=‰ŸdI{v«ë…áþ@àÛkøþÚ]›ÀóëØ¥!Þ¼NâR§Xà‰-ñ"Q˜~#câ‘Í+ ´ÅvWÊç& ~Ñ_@ú°Wófäâä5ñÍ=ÓSˆDføö§E$ð6XŽ+£x„ SnA ç  ¶¤›¡…v;âùNB‚ƒ!=âúû KiçrÍý?î„:„ìb#’FáS,Hšwâû Å®0\Máõí¯˜ÿ÷•ù³œï#Än?¾y¿—yN¾÷ôÍϹÔaïfî…ž^˜éXŸ ’ñNÓdºÎb•Dª:w˜„ì©­)Ã×}”5ÖoñÕÛ°Û¸Ûc;¶Y;¶y6AÖkÙæÚ¦õ/B.i¬ç(ÜÂ< CÉ7ü±#g[t<·Zûñæoíw¢PaFÿ%%©YäޑܸýØׄÒtµÅû½‹œ:Ê$‹åœA„gµDÊ™;e!\Yõ]àH. õV–¼åÐ%ƒ“9³wãY2·â [®ß~ëë¬aòñ·¦ÈXþù“¸ü·_Äå¿‹‹3'“@l žäáÙß2_Ö6Kk2'fO@ sªèÿÆ2²!Qóåå5­$"ô =Z6B¶ú$mâÝ%Í-ä.GJ^™ä¿]«ä¿\«à¿_¡àQ@0^Ü`9îLç!ö4ÐÅä–À¨K©4"w€EÍäÒ}b¨eÔÓо€L èçH‹sôN¬é9£D«crA¥Q¥2‹Ä9)Ö5ÔGØ“õÿÕ RÙEßð‰h>f–¹ÙéηvǽdLœXpbП[ãÒUæ¯6Š‡£¯¸àTdÐÞ=Lt˜ÀË­#0>ð1sJ[æGšœ";°Ÿ*>4qҠlj+ötQ*_™a!ÿ·ÝõÖ¹SüÇÞ`0ÿÞ{üw#Þ\ï‡%|á´ÒKè®Y ‹­¿NÆåÛ;^4ï ʪtËÞxÔ9îÇC›]Ì¡—Côî3;ýAŠQ.«Nï¨1ûhþsPŸSß/Öî"q"ãO‹fy\HÍ [ç äwx)àÉwãxÌR·œ™¶ÝAÖ^±©)®ký³™9¹WOûÊ‹+÷ê¬àöiä ¡GacßWüKóy ðmÄ7Yì£ÕeþèLçôÙeCOÁ)š·ùbS§«€(8‰&1£ÊÃœñ~.«}ˆïžÌ'¡éÆás5ï]-â!ÿ&Ð^pÚ÷ºÜŽ<éN›Žj à¥YÀÁ9šÃÕ×pÎix²æ€˜`ZSˆàŒÍnÒ0–3Ií‘RTâ“ÍØTP¤*>ŒÅ)Cïb¡Ä/œC Ž4ŠÎÞ“~ôæ7[>¿Y3¶T2z–îL)*3˜¯xvîóÊ:]¯c¸•p{cÉ uòt¸¿¡ðbrVÅtÔ+}¬—‹Ì[ß%~,­ I¾;å¼Øʼnk„:‚Y4¿êúÏ—ßìªyÄ׺jñ-«‚ÇOD‘>?ØfZkßÙ;+?€"ÒÔÏõ‡àjc-/ä³F´Û?Srj~H+2ç¶îU”Î̶ ?n$ äŠ*=CÏOØy#o¬EG² „¬Ñ¸Œ®í‡ü`õ¶Ò 0–¯|R‚i˜‚•sú4Áf,8`Ý"ž‘y–‘³ìfÔ1æh3±"Ó¬†sâìå½bxõD³Zæ–d(0e—HnÌ~B÷,€ü$î;ÿ~û C§Ê-aÌßV|ù¸kæ«â¡5œÄ,¯»Y¾‚/_‹×<öWQ½à»9öVÍ;À˸‡‡8(VU$Å8ò”á‹cÆž†Ì'€S.KÁ•²Öð˜ªmG,4B6‘±ëÊ]Ù º°U±*ñÊÊXÏ‚î§Úç ?ÿ¢‘Pô9Ù@)‰2&©§‹BË9[¨iO\ÝÑ.*™0hc“ë_ìÚK™‡VZ{¯ñÉýCTâ“ÈqËaú%åñ\D3!Bñ€ü¢ [dz+Œ>q~g·¾õE([{²Úúò“ßeKþên$û¸‹ºï}E-|E†K üÀ¨(묢Z¢HÂ[Œx½¥Ú˜Ç²“r!¯/ßG>åºY%S­žH¹GêÆ;y)½zoÓœªÁËЛا°4Æ–½ž Åú-@“‘]°ËÌjѼà8’Hn@NŸ2¬B½¾žr¢T»ÐK°ÐI°ÐH°PH÷V°×¦ ™98IY¾±iVY"~šŠã?þU‡›62¸u@o [ÚoʲϋóŒ¾ÇRLÍt¾‚Ô±x¶ ©$™S²P]sG"ik±ëû5ÙÛw˜:·$qró%õÝçþ–¸ÏYîïY¥›fq•÷ö`Í}ë¸Ï w­dNÄ£Q úRbÏSÅR¬œñ-Mp©KyË5Ròb`Ãqj) ²Â†K"s!û° ·îŽîvi’áqÙ½Š#k‹÷+c«5Q&wÜ-ZÜÄyâ•Ê”Í Ç­Ç‰±ÏÛ²§Q„ÉÞ·øͱP“bo€]^‹„'’¶“{@BTöÑ®TvNˆ›úg,/O°%ÌEWézÒ ’­'ú£¦kÔ,4ÚÆb:ÌÛi9P5l2V }°¼Nö<ÃÝ>OFÕ)Øàô{®³ —°®MÍIw#)/øš:ªZô²¶Ê[Ø5ä©œ,ÑCŸÉ%ž(„_°<Àb¢Uå±RQèyáR6˜‹åäFUylA"9oAQÉZ½¶?v}Ûåå. éWRTÊ>“‡¨²=Ð][qFÃá°¼Êf/¿85À“LƒªßdU5/!‘èuåsb8~eѨ\v9¬XÑZ ?Vƒe]9Ãʈí´TvRžã³û$<ç9>ƒUÇãÑy,"ž ¼™¿7RŠááZòÑJ#°>¶›G(Ü[œ `7Ä4µÏù+1k¢qæ茰ÿÓzê&‚q†ž%íwTdÚ·fN¶ ²wxz ÝÙm†W6qœ‡¢o°F"ûTaZ¬ý×éºbˆù¶Yôjûp…uc‘®vÎ>ïªi”¨‘ÝJ­G˜$¥öêûÔœlÒÀ‰˜µÕàs™“€}.s“Ž„.©¯“sc¾u¯Yž¤QÛYÃà¾ÛòRš ³”ÁiŸ{"·ì‡û'·eö7a~ƹÅëÙ"ëX܇P7Rái'wT0x­ì¨\Ë Ou¹8ÖÎ_ƒ™«³ Xòšß#GWçè“&ϼtV-ßÖ’&°Ë3×^Ûó¬ÀüÿH¿¦§0MLl8z #É×Öz‰}Úïë»+ÕIWТR¶v~e±JQÒ|Nßô³Úâ7ÒáÝSù%¦¿ÿöóG„ÜáYµ˜Å…¹5©¢ÃïÀwãjêaeëíqÝå“άì5ôG9á'LãA™ù|øƒú!Çq­Øº¥Þ Pà†is›& Þ7Ö7æ’ï¼$VAå;ÞÖ aM<ýOi_î±ó®F# ê/?=¦ç%U¿˜ÿu^;¼ßÿÂ̺ºìè(ô-y!áç€ô¸z1ó¼r÷Î)ˆ…BÒ‰ŸÔ3”Bˆ>Y ´ô˜ápÞG4ÝW·§¬¦¶A!ÏœYM¥,¯½sÏîjó·Ý6ßï¶ùAWÍwµæ틱ldí²ï¨ Ö=Wë·ž§Ø u‹ŠíáÌÃÝ÷+n¤Ê¨«¦å³ 1 0~'·z÷±“F©ÅÏÐj7² 2šŸÞj'~î¢Ñ_ºhô×.ý­‹Fÿ·‹FùîOoô_4Š–ïšqçÊó7\5NŸ­Ùj¸’nÏ­”Â-˜4<¯†üž­]±zp†v;óÒɈ±6‹ôjÎ6¡il¢ÞR6´/ÈÜ{¥n¿úA`öñãÀ/ÎX=8qý¨ýúð “•]e™½¥œÜâK–9 ˆ›ê^G»^–”Y£l•NdåyŽJf¡ç·˜y'Ü%ô4ßÑ¢­„îÏÓR6«NÇN€]м—^F\_˜§çÄ]ÉKÝa|·‹îßÏÆÕFǾKÂ:|ëÄy†8@íbmÆÓ’iC ³Æ Ä º8r(Éä•‚µq?TÓk'A êN <Ûkšm#φ9gÐï¨ ì\YÃœ ÆË°ct£ìÀ¤—Ý âDÇQ~œJ5p`Ô´_…ëz»¸lÎ>e㢕|á¢ñ*0õÔd R;ÿˆˆ–"¿7AQ›G!!~üÍï¦Mk­&I›W@õÒÑ‘ Ý„oS?ðšø¨ŽŒ G¢I#1U\¢rò^åP?ÏÉß)|~Uúcrâ‚rã»S]þÒŽï°€®«Q[ºH6¦q<]Ï"âú±$-ó8Å—ˆüêQ©Î2j@ø½)øg!ºF_yw n Á¯.SIrôqõpmIŽò_[­’ä|ê\í\íœù座<Ÿ7W»â\[¶£àlܯV|Ru½Ú “ÿjUœ–(ÙAo±¾4άRҟ͇ƒáÝèq8h’H¡ƒÅíÅÆ9+{g`j9 \-‘–sθ4ÀÚŽ ý~Ú=dKÝœ³¸OŠ¡-<®‚£'Í1$º#­»¨‰üuTw'ã¥Z˜x£æw-Aø™‹‚#¬Ä5N,„äÇò"ý7¸4ýôâäOôËÌ ™¯ñ_»ÌC0@g†Ø\”ä;PJS…?HàüsàîŠn²¨ÛÑË›1ÔÕj-Á„æ`p·mÀà‚U„gBÒb­=Ÿ­5wWzíÞtÏ‘¨ÏˆòÞ;;Éö"­É8'ŽV¯sNvg c³òùeܵÇÂç7@ß°š7<–a²ŽFñöáÊGÂMîkXûæX ‹ýÿ¹@/˜Àê°u‚  VzÄñà¼â0b^÷®¿'­æv0’ q(³*µû d®9ò…‹$ÀOT_ÌuGÕ¨>Wb)Å©|íf@ç%hU’<ãÔf³]•ù¯~*>@ù„¬ú!Ñq(*Å Ç)þð˜î@ád£ñ:öF\‚ú€ÒYÙÓ((y"é>~åòW»¸pòW<_Ý[Lkäý”šfÌÈmÒ³"W©– 1oª y/&^×o”Xþ¨Žálp—D’Ù„Ò¢…½2ÿàAGÓwþ¨LÊÉÕq0©?]§ØŸ¯Sì_®Sì_¯Pì·ö9å]2?ЬiºKÏ»¿œêQvÓýÕ'?t »aùƒV£Þ¬{{V½îHU÷ «,<øe‡ê4ÔTKt ±Øú€¦«€ œxkzC?U~ª:GÜ67 §ëµ¥3tHpyË ›xŒ2OKî tÖ ­ÒÀ7|bô‰¿ßëÌÓ݉»¤Ç”ðÇÙ÷Í÷.7‚±ðàŽ’³7V Ÿã¹þ[àœ(ò8 ˜Ça›üà |Á ðMT:æ!Ùm%ÿíó©¿¡üP,wiˆáßÎŽ(rª!!Ú^/õ`—òv ¤ÞŽÊA]¶`¡‚x^Á Ë Ô¼üKJÒ¬œÿÉÊ¿»ðú¾‡ˆ¾×è,btÉ(Mh #¡‰æ‰ZfÝi’sOü"/©-¥ 2z´cV1¾î–ìHä;ù[*^Žõ  ŽW¨Ï„F?HŸoÊBïz°ò ²Ô^gí˜Óî¨Ð7W\ÌùXfh}âृææöéæñi~»PÓXŠŠ²ÉŠO¸Š»©4=bÉå”qT­V†¦-øJ.—«{‡u¨¶ò«u!Æb~?@7%å€nØæY.¸ŒG-ôn`_ïo?³*“šB%•^’2ó™„”×ØXÝ ›ÞÿÔXÝ‹"­í[TÒÓ ûÕ½íÇ…©Xë£(ÄgiŒŒ[k!M‰ÊÙNH…ÃàSÿˆÃK­1v8›5þKP$±µ“¢ô“ÞûU¯Ò4NÀ ƒf (†·°„_'#,MÈ.Ž°©ÆÎ-ÈR‡#(F]V|{'"Õ¨åµñ>j ƒ\müOâUÍýÇÄ¿Šý^Àp#pˆ çWÜ8çOШP׎pnvŸd¯ûÀ;­ B%º±#¾²uf·}fƒ›œõr „´nU<pg¦ …ÿ(×_6%›áÅ4º×Åž&ÃW³È¦ównø•t¤[qO[2žn}ÇÔ+÷’nòG™aÝî…~L“ˆî5ñ`ïLr+f°Wã)ã¬ý#jäžFÉÀßi?³N¦›¿Ëï[ë÷άêöP½W} J°†¹­HjÅjú#Ú¸-2kcø ¯GDÏã9Ñ=I¸µ³fljë&È}$?$¼S… ðÍynŸ¤l¨«w𻌲mÐ¥¡ë$팫d·"‘…ïrì“CËδ2¥:[Û‘h£‹ìy L!FJ´º[¥1ú’[|(b—EÀI¡"2æp™EÊå<ÿ­È3k¯!KâTße²¥•|»u7ÊÿúÝE=ìÖ»M7ÏꇥeÖë6?<Á ⇧œýpîÓzNs1”ѸÌк€EºeñªÚ–å‡;m´rMéŸØóœqOöÃ49—`yÙ!±êò‡µµk\,Ò¹?÷öûe6`x'uÄ ËB«ÌÌ`Ï·~8ð#á¹3ª(-XÍ’rÝ~ -rƒ¡X€iHŽ©¾ÄˆÉ¾ŠœSrùcÂ*É/fÄÚ²[X†œÄj0‡ÅhVa)‹W/.6xówixŽ‰ÛÐ8 ÕÒç{¹K^U0¶¹|Æí“Û0Ê»éóhÊ·›lmM‹íçVh«— ô¯tì¯ >z b>ï*ýýyRë²Àá· + „è&yÝ47 ƪ½©4ºÆÄfÆvÿ]½QƒS%®Ù‹ÕØ€æIGC½–‹"«oÏú½=kËõT•&Òˆ·µÈÙ[|†S×5˜Ô³²¶wÌ’ *5X}g4(riÑOÏ_L¿ `…ÝóÜ´Uß/ÃÃótŸÄµºA «™ƒnž~Df•Œ´¢ZÉÀ "ñ@¤|-ž;¡Gw¼Õ>«Å˜³XL„¥é@-}ž¾w²f0ÅàÉ-=µÞMŸÚo§ßˆó\ŽÏb¿³òÑtN²c*ÿ3+Ÿ9~$ãA…\P…ûúq¨Vt´|~£ÞGK@hÎbŒ§äŸì{ød×Ãgû>Ûõð‹}¿Øõð«}¿Úõ•¶1X"{f›Q.þç‚—Ù1§IŽ8Ä¢Óµ¹AGÝ:"÷ßeÔr}6«n|š¬\‚¸*Gb=²}oÁ·XbÔÿ¼á)}Ë%<•/çÄ×%7ê1 “~@cbuÂÉ+ã¥'GÛƒ9us†ÿ2ÚÅa·¢yÛKZl²ªã ½ÈwB2Ÿ¶G†¼ žd[L_v_ÁJ»D_à­Û9ÓÒ.žÅ±º[`œ“Øÿ‡´ñ2§/­Øö׈Á²‹ùLV|*0j™¦³œ¸Ý4ÛSÇ«µk8Ý]ß»KƒäRX®Ø·¯Ë¥ )DÈ=Ø.&¬×lŒ/p_îþåBýïkÖ½#ä‹Z ^È0Wà|uV‰4t·íƒß‘[  g?,·ÁO*¤} û‡DôêœÇÏ믟חøÌïpÝ.„Bœ j­ððT„Œm1›¨”²IA;< ÙC¿¦ä‘$ÝC9&™âã¤zħ› Y\Id7س։þüi°X{œNãÙQßKÇp®stY:èþÓÞ¸»óԳѺ œšFZº{-…Úübìû2ÅBO±wÔ®ªô× HáÝù$ðfih‡‘öè„Õ¡,æGâü¿öÞý¹uãHþ]ÿEêæ[Wmj•œsœl¾­Ø÷R$%q-Š4Ic»nE‘#ˆÁÁC]©üíwºñ˜' b²NÅgº{óìééGHté€Þ…Ñc–ÿQo–òÑ^ôO‰÷V«0×_Ìyw^¬Aá&Q©xÖ:fgX_bvX¿ñÝB®"…ã/ÉëpŅ̃k·Õl·´VÞ¿¯H< ⪶*-eì¯ÜÄCy6“‚"l4ÙkÖÄQ‚3ÞÒKøêƒÎ-½ô’h3ññY*L3æ[:‚èˆK7ÎtúV{£Ñ\Yx,„ŸaÔ§[²¯ˆ¶3¡¾±FOÛÌ4¤¯Cíº³—GC{GŠ6GjFªïóâg%€Œˆ¥?Þ5ë)ÊdÞmgŸÇ§>ûÕgcj¯ŽWT¸HiS¸þ˜8+ìŽe8© þ ¦„V¶üµ±¬S¦ W=¸k^ãÓÚFV·Ô¿€<­.äWrÊ1Daën~º™È‚N1Aš ‰ÞÀi)]oµqÄŽÔê¶hþF:›ÚhL˜œRò¨ªpø©;ßJÅ?´³œP¼ù‹B àõ›â™%â:^+¯ Ƶ¾ÇPxßÒ,í-Y ¹xäßE­gbtÓwYûžŠ?»‘[’yÚyd”É×D·qiÇŒ7 €§ž<%Ç-þ"9 ±SŒ¤¥|—ä(eešá™»•¢Ýß&^¡ÅÃÌÔº~%ÛBw$[Ü¥:Œ-ÀXÈ·˜®@3”hºâà†<¯¾ŽÎki1s$2[Ç÷'‹‘‚̾¹f8^xÚ$Um·#@”%Ï1@í0 €z½Ä/¥;¯ÛÀ08W£Àä)ð$D‡Sœç]i(¸önણ·^}Ø«ÄRÚòKÓá´uV i¯á),ß}nó0ÖVš9jƒâ>hÁZÊ´øÄ—ä dÅf7™M¦Fþ^7 1Júͬ.5ØÕ]²ãÉÛ «êúRŸHœ •7V,d=²áúK;!Öf[©-M›²–­ódˆ÷-ð Ä.Ørüì è»|s#/ý^j´™1Ö?¯”ànØ,ÓR4'øÅâs’Ç<àŸKÊêÕÆ ±vçh§©0rfæh_!1UUîI,dÖ§óÅø\UÉI€¢×&ãiŽtç?ùôE· 푉- Ÿ£J*QB¾×ÖtY¡ÁÒÛˆÖâÚ3zMŽq'¹xÃD\dž»±€cM7r¥<¹ƒ—Z®xQùw©?ÎÉV´Ì%å9έ ITX5£4ñWú ÚAg O!Uܽk%)œÈ U,d‡0žSŠJŽ}Ð)·ÐíÅHECäÎw¿f®ƒéßPŒˆ&×ÏÆÑeùJò÷~i„i¿ðØ¿ïë×Ø:¶ï.+^Ó.á¶P~+ò]Oœ–ÀßÊž¹”{¡* ¯xä—÷-h«7ÓÁå¼ÁÍ”*‚$ _¹±,@A7[øb1Œ×€F¦ LŸ¢ò ¨F ãh-ŽãÓ¦çm|LÑI ˜|Š˜>Åh+òË1Mý{êTÇn´“½. ì%=¯Oïéã}L"¼dGl¯MÜåSC–ìËc“‡d]/f˜KðES?¦ú¬Ïš(Z1kŸ"$€²µ.‹¢kQ jÃYÔt=‚µMTžå›0ó«ÊJøC·vP|~Έçý͵w³,©ÿlìkÉàÉDçáe´í³£œÊÕÉ‹rÚ®øýR±ßÊ/5Hâ‡CÒ° V)é›]-²¦û k¯Ì·´j-@V ÚÕ9Ys… D¶ÇAuŽ$¬áx3t¢˜U=ƒ›‚érbh P¾û–˜ˆ¿ª,·Tõ~—½Ö™Æà‘Ä«Êá¾XÕ%õ<úBVºt—Æyªâ•X1Á㻈<&¦Ï¥>>—ö|0ò¤¦¹aü³lÙÈUâhY  7€Ð‰/ “õ’›Ô¨Ðæ쯊ï9/‹„…`}+bNŽò)Oû YO€y¼KÜ°uê‰Å}à²özþê"‰ã’Â&C¯ä/⎉ŸŒ‹,¨’ Ñ$"MZCçÇó!'ÜÆF€&µ‚dxøš7i‘„xdàt™]&”†¦eú«~>¿µóX‰y>‚»M‡,,À”æmÛŸL.F¸ÿ×lÇê ËjÃ-·á57•Óè­äTÞºÞ?ŽûHÔ¾¢æS¿$&ÿ˜8d¶>®)ñæ†Gãæ â¨M–±³!«°hc0³–1­™ºMV+ÖÝnU—!ñ(™ø:uý1ŒY«°ÆmbôÆ–ã 9~Üó‚ÓÍw•ø0I}L>Qç]ÁXèºæá²ë^`,tÖ Á€,»køK¨}˜"}híìªü0Jáz. ?3©ºv¤ ³Ã‹¡zQ5©„8Y„Æ\hÝ8q3&¦ÊdR«4¥m( «gŸ±aJ 7oøyS=ZÂx£QãÕ›ý8ÐHGnv²Í·ª‘ÿHÙoȇ¯d™Ä†/íˆ1FkDcØÄ«JYÂéаF,ÁX®ð/n6ÿËæF4Q]yds.‰Øš2¬‘d‡Ôã5n°6 J™8?Y‰ó”É·é|²=ƒö˜QTv\§§ö±¢ñ§­°•ÄúPÈö¼F%DùâÛ®<À`„¸Eƒ…;bš®Y€µX…n± §ü}Y»L§×R” ÇR¡y:ùx3P@Ü8;Xñ ˆ[ª‡™°K“âg€ {°9Ùºð¶ä+’ÇG÷õÚñW5Ý ʼAΦL¶r}Ÿ–Ö‹±³úR®» õL÷Ç?ÿ n¾å(˜‚Y¨›¥úYÌËxØðG·6²¼ÚPéuêYÉæM`7e´Z{ìg2±}lÐ,t8Èg /[ieº5_Á;€yòo ÿ{é°½sUþØ4µ&» ¦³ $8ݬ6œ6#Ùa9ˆuòttîf$J¼øèÍèF cFé Ò00FÔ»íQžS'Š›²•j·Õwó´À8×(Ù¸d¢êƒî8kÚþgÇK4Ç]ëí¿ù×ÚGÀc8ö’8 ¼Ô‹BÈHq±QE~íÌ–Ƙûõçu¡8ÌÀÁñÙBáŽáÕ ÑãÆ´ÅL¯S&ÕãUê²›‘€8‹Úyv—$eDÔ5Lbn…ŒÀÓ€ÊÖl»g€Ü"TÔ¥#±×8‹”{5}´)86Å.6f % .6v¡A¸¶Ö¥e7 Ü"Ùt¦Ã!"ÐÈK/­ˆÐ§Á#b+¿ ®«‰(­~$£‡9s¬ŽÕ™Ã>eì?qúDvø]Þ5ÊÐP}óÔ>²ïhp|'ã?S/ix ³*ÿ€ŸU‚ï8ÕYõÈö(/UðŸùUˆß=ƒp¬Jrª§=¥sÛµšÑ_Ѫ-Ô˜Óçõ˜OáÉŠø’|ãèÆÂ`Øg_xŽy8ëùÉ”Ñk™¹A²Y£i¡³X ɳKÓ”àçCÿÙ ©¿Õ§;Bq°†YìؤÙÛ0T'ÜÄÙxGßê¢Ô÷¯s7Í>Y;=‚V‚UÇฟÂϬŸ«åt4é=;®‡„þ šo8W!Mv½(›½£l+„çV¹yÝ~×Â?,ü 1Ë#ž"pŸ[ ¸y&3oq,ù´bR™À›Q\‡Î–MÉ¥ÓßV¬Spó7“G’£h¸C0Þøgf ˜Ý’}N™aµ¾$¤1]Vƒ¥kÁ!äNt]剽2°zʯ¼¦tÝÏN0íûI1{& $ Þtè'šÿq6MúÅ&g0{³Ÿm0 æaibD%1_¦“‚ªÙâf ˆÔÓ NÏ>QCr‹þ@ä ÐÈz:#5 A$š‚ç7téx‰ë­êôRž5 INí~%#WËÊPùc2‡ýK\ʽ†5DÈÎãÄLˆa;Àps6-WŒh¬ƒCGS þ&ñŸŒ oÍ ânìø;£Ž3ùÒ©ãê»Í2‘ ÃX° È68á_Ü"ÁDüêÚçâ!‚ô=âøò2ßò%å9Vº éˆ;5„•bÀuÄ™Í|Q8XH·ü¡¥1¹òèƒã©?æÚY­Ø‘¢¢lÖ®$›¼ô«ÓóFMZ( !8²,v©W9ìJ‡'œûìäpW$u[ËÞˆXáv¥îPˆ„F±:(žŒgz2Ô¥•¢Ó#Ì|€i9UdæÄ —îÀ¡Œm„Ð [¶5·kõ³RÕÝù¡Qïä!,@²²rQ¤‘f‹²Ãu"Pú ?2æïÊô 7yJóR¢…=:¬†È®Nþ``ìv_Nh†NÞa¥pöeÎüÏÚ†¦QY… GŠ¼@$‘’ qŒRH4±mö¤ ìUš*ï'À›¢Di%ä8'®*èë°„<ÒO–Svóêo¤ÆX݃ëö¥K¼•.hå+<5°J\—™|Üzàݧ2¦G :»ºè$ïÀø©²ÿ ¥vÞ…¯cð´>ü>û´¾ ½VTÓOká]Ê–!pšø4®=HîRœ5õ9bÕ§ž½ÌùïáÁÎFÑäq¾ …Ö•U*¸{±’) xIt™æ¾t}Û…×=,¾ï +¤ÙñEà{ Œr/Ž‰Ÿ˜ÌL½g†Ý„z—Ί°+(‰6Ô[͵ùfÂÃÈo1;bšåʉÚ6p'8NÃè1:h"ðÁê' ‹Ø}%\{¼ºµºþQ€>ÕˆU«î>¬ÚèžpÊ{>4¹Ágˆ:.›Ýà¦Á žAé.± ÄørÊ` .§{(ͧëî™bvd &÷G¦¿RÏ «ò=õи‹ßõŠÊÍHí.ȯnÑv%Ç]ÆIŵÕ(RNþ–Uw¾#5Ð…ïXÚôCÿwÚø¥ëy2€ñE»d ²€ß”ƒª0“OqY…ñ 7’—Œ½Ö9$Bë^i⵿¹Pv³k]ZzìQŧ¶%~ý`6'çsÔÿ–¼4ÅkþÕr³Ož‘æã•â6g½Hà ö› Y`oñbè½éµšf+HC‹s±&.F•˜ÉÐ(FC ‰®¼«ÀBFQMýGUm°“×¦Ö rPÔÈkÓ€ç3²ªfZчDüéåPN\AU5à§HNmäÕh0 ¯¦˜·MèGŒþB'âõ²nÐÑXêMý›j¾…r}hª¿QÕ_ªï„U ™еT§Y ZjØä1Ñk©#J0\m¦°ôÈct%pÖÊ-í‚°ÿ*¤šÕ_ëFñš%5*LA^]‘YäÆ•s&kyì숊e’æGÏ Z¬ð%Ë–YhZ¼/ces¶Øõõ·}vLiÝc^2[F…±Ò•8!i woš’YB–êÐ ‰êÌA/UÙ‘ʼnõÅyúô¸‰|׉jÓ‰jÏ·tUeð…´yð+S¿W'‹YR¿—œX%™k:°n­ÏY¿ßÒ•âU!$MÏÁ³É1’ õy£IXËãX:B† ³ð0.jáï(!\ö,ô=H°ú1 ¾q 7¼MÛ÷áò]+-ý¦^¬I8QÂ@gÊÄ1Eh…Ipìnë¬ò²}BÈ}yºs32¥.7´0±¢²ÃÛwª­¶I'5£þ’E¿â¥®Õqw÷*ÜѤ¸+¢?oÉ·—•Ñ±ý+á~ݺ¸K{ñÉ8˜¾½³xPtÀeSÃ_W3kY+¬C »( «ztá½ÜwAàtÃZƒŽSvÈ1LgBº¥11ðÉ Ð'÷2t¸ûp±/LÝz3P><6¯i)‰ë»iä´ é–¼TÒK˜¡ïñÎ)¦Y*Ç’Ó/ÖÔ݆yqÙgx_±¤ÞŒ<»‘ø9[‘E5Ãά2ì#òuïèwT‘6IYÄD~[Ûûjúa%þ2Nà8n`¸wpcû-û:( ¼²@ŸD{EWWlõ¹ !²ßOâ gÙÀb5‰ñméI<ôŸË{Oµ¡ÆŸE¾…d£P/Gdvm“4Îjn|IÝBBòšž«*96—MCB(]§3Øù†¾Ìµ l[#ãhnZø“U¼°^ +´. ¿’¶àEóã›Ë~¶c~œ“­h0$åáV†!ª`(‰ƒNÓ[Àö³4Þ.<Ótž7%y  ÔªÇl~Â…È Íy0ôs<º™]}m*ÔwÓþ›‡…fzrí «\ÕÖx†‰¯/Ø{}|ó̤BDä"Ík5 Öûœ?ûÍäŸk”OãH­'Åm®Û+Àð?9Öœ]+ ”Q¤'ÄXI"ÚI…5v 2 $õµÏOF™gua^~­¦X3ò¿²ëô9!§<#KÈ­¬‚ ’$ ¡2ïƒI|&"*Aîzƒû/£“Iêß* 3ó•­zHúºÒØdÅ´ö%'߯قgc eŠß¯Å­¢^Õ¸ÅuáÚãYrØc v<-Z ñÂÕ©‡Ž²? —« w](-E6ý*‹a©ð>&.Nq¦Üì×vÒT«u o}ȯ#6æ1e—­Uãz+ˆÞt˜> I ÷XéÎ ûpÄ;£S„Ã_Is!ô4±„ÞÇ0ÂXÐ=B±|Õ{dЗ^‰N é¡UÀ…ç4ñ˜Û ªÈÁT˜« õ:ů -(fá׌]NKûè/R£3*d¦Wš½ùÍþlöéêÓÅGÍÒ}oñúfƒq-¬ÚìꢬbD KÔÙÔŠu‘mÑ1éÕ÷à%È:ñ›S› WþpŠ<÷NnÕ1®O‘ç?ÏßžËiíëG»  çé–¿øÙdaä›”ê‰dfÙ“)É<d,Äò 3Ø ùçòÐÏfZäMW‹¬‰æC=Ô°°°~hÈÀRªµc§²^iÝz—uâJQè,Ë%_hè­ªšUææ‹óç×]½”;¬¥eß~bHÔÇ"6ÀÃØ”GÃ×%Ic±±êišsâ©hÞ«F¬ž‚¬î:†,ÅhfAª®¡/ôavÄHI!²ÔN\ Ëçô0©YËçúòʼn%•à“0IbA]Á¦J’ƒ#ÿÖÛ§§í!«Ðy)ß½šZ®3ZÉÒ:[j³\¡möÀ£Çó»iï,Gy…$pVr™Ën¿WΖïÅ€·Þ …ìÏôˆÚ È‘ÂÞ”¦ºÑFÀ3Èrìeõü"/†¨&Ž4פi#æ ¾tfÃà¨Gœ›¹é&§å€ˆ>ÖÑšf pÀ”žu-:³œZÄùÞ³ 2m Ø·wn㌵Mìûa56ˆñò^˜…0²¦œvš 7åUóšñŽ˜…¼ä‚{¦ŸÜ1 f«Ó>xd«Œ4Ï!çèY¬†û ‰uK§Á‰'A\5JJK#qC2ážý6xúø€•¿fÔ1»Q7Ý}J¼B÷nœ€+Ù #_²n.¾F–¡¬–îûÓ;¸<Øá0FÀ¾ žmA©gÔ¨¥p.2Á°&:ò!ZÈÎóÎòé‹oµý!0ÓëÙºuXlÇ[>YÄ‚ÆŽ7&[wì¬y¸t3#!Íw>õw[KU=× hMOõ¶©3&3ì„Ÿ½ÞØr“‚†G~ƒÃ#‰Hoµh6 ]˜¨¿t6ì¢-º¾Ô˜{ŽÜõ&5Lºñ†qµWÇAÕ7åíícMN{s×”úk#׸h¤¥ã o>ŽE½zà‰¤ç®è=ZÑþºNK5¼të8_ 1øËØùÕÈ…ÇÐP„Pgª ‡ýEïöêÆ&v8œOñÑäÖénÖÞ{·½«áÌõêâþb8_ÜÛ¥G´›»a´þäf2k€7^öînš0z5ëýÜm8¼m€7l±œ•K‹a"BÇÈ }ÜT%x©r1¸ Ëa¾.H¨º˜ó/Už¿28ÆBá[¸œ+ª%!¨$éaT££=«ÄYnöûÖ£¡ ”×6ç†Û531. Ü+ª¿ÚÜ¡€î†‰ø‚Ø>’ò‰]0ã,2)ñ ˜ ò¸¢Q¹ƒÈòì6ÙBI^0­ØŽ¥åÑR|}ÇZv¦Õz:=è°B§j,ê†bW¯ÀºËõŠ62¥Qæ'%¶¯ŸÕáw\SúDV’x°¢”{€´¢ª¬Œ&3’n$üO^ÊdâÔý_9Tå#XgÈ[®¤„NÈ’%uòèpKnw•UUí±ŠåR4g.‚¿x±0ÔÈbŒIcÒdYéV ìé}LïmÍÎrDí™ÂÒ IÔ'ŒÑ„ÂØá²3ØKŽºïûŠ•a?[wrŠ¨îgâ|‘¯,ü“[†í«2ó0ÄÓ³©ÕyÓ5w`K”EÔST¦èìÆÉñÒ¬Ÿï¶Ôãõåݳ®Cæ Ù¹ñþ•)zópˆ® pˆdtTŠ†ÀûSB4lûZDÄ=Q¹WzБ¥ PÉcTçb¥7…WÈr7(†7žç„Ûµ @Š–M)CIö›ž¨tŸ:&T%¾Ñd •9oÌÅén´LKŒ=å*…¥§ i|µP‰©h†ÚDPÂJ)»9e±é©ê#¥†¥*$7(ν%8‰YÇh õ±­dÍÞ8¨H³YØßš8‹à?Cw`Lb=(· 3fF ñÀ@µâ´Ãݳu B$­ÓgÔžkïsPØó—®Ç6ú°–ÝÁGEXw¹à…7Ll¬—¯Jzñà774è¶R"#J5]ʾô›zq'–Û¼éj\\½‘Ç3‹}„0¼ùÔ×YIö(ѼyP-F¥E†µËrXÍ%€¡6kκ^¨õ>@Îáá¶+ ìÀv+5uÚ²Ø*?H†Ôä‘ž;)²Ð„Ü"\©ìÁ+“«ÌyeHÂH¦J´÷–ñ‰•ã²'¥‰':¨V e©4Ê%£ëp0Î,ïJQÙQ‘—á'X¿?EÞ5±—%2 !Y Z‡¬E[`FKÇ#ù ŽcÚ…™ÕȪ$aªÓt,èñ÷˜;2BQÃdýº§< ì8™Çá%.ìÛVÊd†Šq`ËæJ¢«ƒd“ǧ¹"­ŸÎÑüw ÕÌ’¿säI·„¯duOŒ]ëhÒ½U?°NË_Çøp_°Ó«1ÔªY¶°_Žé@r «6„œÖ s[$#Ë¿&¦~ˆcÔ9 ®‘”À èÇŽÏ{ML4É ‚±ýò‰·!Šî®l=ÕCå»øÕÖÊpåB~… ]жu#ôb7ÄŽëOYw9~Mã£èdÀZ-;À@ fŒ°ê'"[þ²‰8§ û½j¶3^,”%HÉsYÚgÛB$ô°jšZÑÀõœ¬Ò©È+ã½¥¾i*¾ Ÿ§ÍgAŠÄXˆŽeŒùÂf¸­qÈãòÏ?²ï%— ÷ä“óüBŸ¬æø—r?'n›ŒY§¾ÝVRà– /\G—ÌAQ E?­5ÓñN9ä\×ÁGñôÀ¦‘æ€ñF b«º[¯¯áÉcçQ«(¬y6˜Äïr¤Ý‡v¼°£ä&W@¤9‰Cteªn¤Û\Í`“„%ô5þ(lûºq2M7†ÄB©Œ :ás¼É#—ñø² @ó>®žìiüí¯zÈIÍ]Kß݈w#ø„´j&®Jü¢¥}éy¬B›E¼ ШsÝUXSÆ|5kÔép•äö;püR*ÙZ³ÉŽ£y€2$º€°ØpË¡¹Tâ‘2w‰/~›ºe;8¸_¥*·–ó '^njw—´Ú`÷-8ñd2IþðU5ñ‹²ºj°³¼…Èj-—,¡ú8¶)Œn:âåÍYRyôÔ9¾‡ºlbb¥ÃKÙy1Âø…™ ™ üt À˜têà÷+F±•  ~ðˆyníPJ|Ыc™ÞŸ+ZHe ´äÜ)¯²áÄ£å5¢àµXe¹pa•PŒÃÊã"•šÎ~¾Hkî¤U‚û¢4¯t_ãCÐb¡Ì–œA•Ë¥pÕXÜJßz£ÅÀįCPÑM[X˜}5¯¬ö“å¾Áî~¾ltòÞüí…©ùÿBíZ|žÍûý¢³ÌÙFOél~66Àhl¸ÑÂò“¬=Ðóhõ@Uco…Ix¡=ñŠž/¨f¼ßY8ò¹óheb{Û"nŸŽ9#ÍïÈX¼óÚhê Šº‘Ûgco¨š»óÛ»Ù…zêØÌ8 W{= t6_ºQDÃ^ÌW¾f&±þ}f•¡9¸[–4àÁ\ØÀ¹``ÍEzÏ•©e)¥Ûdû |‘ª ¯)’¬Á²ëêœ,©¿rjiZßJïSnŸoaL `›»!O`À6Ü‹ÈòŠ«¡«ç¤²* † œ43»}#¨9‘Dø…*i„_¨”Eøƒ• ,‘»c¥ûˆ{œõ˜ÀN<'4˜ñÕ,Ä-°À¦,îò&H¾âC†¨»C¶¦óÝñ*¤‰æ`>ÎÉØp—$·ÓÎ †~\°×¢’›Q …¹À+©µÑ¼“<î¬ÕÉ‹ÏúÕ_aŽ¢}L/½Å&ÃŽa`£ï—rŒ·¡ lÜDX}ë8‚U3Óá>Fõ6|w¾£¯:ýPºh3ýì)õvkݮφ½”‹½ÅK¶±©6'Ð…pî,V§éÿU¶éÝjÌcÐ!Wž‚LS8¼‘Þô­Û;›{L\ï ß|K©î½¸õåFùƒcMŒ`ÿ†§Í*F¾è¢–V²Iõ*¬¬ãì/Sø{ƒ¥ˆqá‘D’JëUž[Iƃ^žSÒÀÅÓF0BQ¼òiý¨Æö<£¥4"8KòàxÞq"àæäesœ70òƒD ­n‰ú˜Š“ÆDþXÌÎÀžæØ%KWx13~M äÕ»ÿЛ½ñ6lHØÅ­Ûý¦ÞEŠ­Q:ÉŠ5<7ÖćMmE8¬.˜l 8æ ›ý nPRÓëõ¡úÅà½Ø&3>{^°qÔ G%™6¯d:ÝíÑX0¸õ«éº”n‘ò­g& ©ÒaÌþ_(M!¦ñÞ7¬V‚@˧É3 =6³—Û}6IõæSõc<|ëvî ùé¢õ.îìÊ÷«s鯠¡AÄAž-É$›BÎcpÁÊ Å"iˆY•”"”²ê@C¼Ã-ù¬,Æ íÊ:{‹ t a)Õ-)#7o¾|ƒ{óæÑ·«æ“ʃ»ü >^pk¯IWW$󚥘Ça™ÄK>Š‹O©ýng8'L„$–NÈï!oÊýDgív¡‡}=¡Ñ’ÅX/æzêxkyĶÒÒˆpÐq³*”`«6Û9(:¾ÊÊ{oê‹Y¶Èó÷͵n™;ŸÇvqRûÙƲ–;uÖTqXÜá!ÍwxH@óh k¿P 5«*Çå=˜õª ]3?ËÖMݸ³ô>”yöÌ_4^ÍÁ1,âqqj]§û멆?•·\»ëÍE5õ¢tƒ é0VõíVܪòf}˜½×Ð6¼KçÉØøI½„¥ÏU;uÛR¹¸•<ÄàTtzŸÄ¯&'Q@ü•ÙÄâ°6×AŒq®Xr…è‚Ü¢B³´¿MzÏŽëc‰«6¬Ïi¡JŤcŸ"‡îüák¦¬ê[`êÉÇಥ¼ÉzP=­¨?¾Ÿ®®óÚ9õ=Èß#{†‹†ýÉí 7ûY YÈR´E#î¸Yok± Ó'hR(¨9âÃ,Tβxð‚:*qÝäæ~>éÿ0\ªÆ½ŸØÇÝÖk¦W¡LÍÉW Äb6úa8¹[Ü÷æýá­ÈÖMÚ}9ê`Ø÷öÊáîbÞŸ¦‹ûŸaYÍ‹»épÖ¨µ=žU{÷½P`ߟIÄÑ}E³[ÀX&*€üú¥ÒÇŸE2÷©¤9©;_îøÌKP]¾ }ˆ€®w?Æ®ÄÇÄ¤²=ï“L”jó茚¸PeH\GÙ¼Ñ÷T[X ÍŽœØwšS…ùFÊ[mŠ˜ÈyÖÔŠôÑ[Žñò‰ÍòôX¹½2–¶º¹uw>vƒm5üÁ¬ußي²šPZ!AY3å\´ÜUⵑÔH@0({ÄÝþºXúè*WÙ°L"ÛDß¼F±m8É£´ }ëYû&±÷¢½`oYn­õ,àÎ0ħ5jÉúR{>ä8ã±õÀ½µ$+¬`Õˆ¢ÉÏÃå£TDÄ —HšzˆÑP¸Â 3‹¦26EèïX¢uì…Yn_“oäH @‡Yf“M±f¶XäÉ2_ÄÅZTÅvij´~Ø®È}B‹SK.Â$*XÂæ 'I¹Nå”R-+½r¢âbCšKD}Ž&Ôœ5Ó§¥ËÉ`¢Ì‘¶ïÇ4¸xŽdr=Dz‹Ô‘­« e‘ÙìñÚc[›Yxèøƒ)´H÷Á åy‚ ö‚-½'#EB'…¤.E:’©¦š‚þJˆŠ÷Mªƒ¶"~1RZA>/:–8LèFø-¸²Ám­7r‚­}PäÞîììIxz>ïùZ‹ œ)ñ°– íùŠ [3(&Bé঎«çkÁ.È^ý»ª` ñ—£¡Šªœ}€:€rUM!qJß ‘>³)-ÔSª.6<Ê@–õ°h ’E H+¦à .¬iL—Ô«Vê¢x´naY<°ÅÞqÌÞÀB ‚a°áR¦_M^SìÁ¸3’@§u…-ë2ñ—E9WØÞ…³|Zó襶Mâ«î h®&Ç…‘¦-†ð…†\|0EÊìâËW¡æ©rÛÊ…ÑE‰i i”Ñ,÷~ $û ®r»~iøâúË’uÝ(®g±ÒsƒzÞƒÁÄIè®]‘ŽD‡J#2 /¾e(#@å“Rh™O«Évjí—J/€÷ßÍ+ÝÓÆ0n$º¦ôÉî-Ï=*ûF PóM W¡¨õ¦mÇÆ1HZóDxŒÆÀ‰6BÃ0õ„G'ñx>¢kÇ_yV9I€@Æž»µ£™ ¾.ÚúQ:{@U9Ã!½Ž¯>f†þsùúV-àP!;‘‡ìXÙÝ(“”ó|>4“(¥½‘uA†¤w- À½P;4—«bÌ/¹‚¦n»jÓ Y 9dHõ¦F ¬¸Ïö.`7lS$óOeÅVì€Md Y, [#‰ÜP#êdX&ûÒ˜My£1ò9!Š8¬æ~´cÍ›%ÂvõˆC5SL*ÔŸèBÒPæËûÁ1-- L¢ˆ½ºàÝ{ZÑð5 Q681xÔ°ª½RDÂúÜNA—Ù5âzX5¨-©«³)ÍJ½_YIšnP=å9Úœed4‹GþÆ}p ’‡”ȇ;e¤.é²ê¢ë¡ÈnëJ.áøyYN@O]E”­`>6SÜG×.éG~ÒŸBc'TŸ}0OÄace6âŒ|60æ ð…šn„Ÿt]‰™ý!Íç$W”´2§ì+Ø7”ü…cÉËÜBÂålÙHËSÏñI£Ë·S²–¡k§GB‚½¡•ÜRoáö,öD© 1†hš,+T{,Ô-‰g`öAE¯fáÇB^A¼CmË<]xîÊ*R,np °AΪêß×i˜éƹ%QÕ+QS—­í~cmŽ2(ÖCç÷©—lµ«L''XHaÕ¹vâ9$…íî«FvAÿì$ÐîCƒÍ¯•ÝLìQŠn4âSÇ»þÆõV—ž³>|~&/‡v ¾ öÇébÞPm˜= ä4³æSuz¨°_cA²®4¿€Ù¾Š0Ù—L\Ù )¶Ç…Û`r.(¾ïäÑž¡ìÎ_:Ézç62­[=ô‚³µdvÙâÆw-·<»¿Œ³ÓÛR>çwUås‰<ù­ê¾n‹‘†¬¨Ðp%<qoý‹»*Fü³!€k¢Aó÷yïÝðân7‚t1:|&»4nqAh·œz92Ï l‰ëÆ÷ëÐyvmw‹ûçf_›£Ú÷òR>;”hI _žUH+zïÓø>`Û©³fÂÄýV|RÑ  “n‚îàD|¦ Æ-ñÁ¨ÿ>ñÅ; ‘ÉͦDd~½ËÃ# —:ÛŽ³"„ÁÇäò%“à q¡ç¹A$ôv—0ßþ¸®h.7î£è-»Êàaþ°aþR^SLå…%c'¨DÿP+8Nuº«á…ISyM…!qh{(ßûÇêÌÛ9x~ʪÜt6ä~)·ÉpÓ2|ŒÒÏÿ 4]1¦o\ íRЪ èJTvÝO™aòè®…†ó5 D½f D ®_du‘°KÉȤfŸñB^9©±ëØäÉÙßó,‘L^Èï)Ž„%ÞgòT_Pšÿ(ö–°°Ø…)»ÚW»^‹ɺ(b¿–ÒJ]ÂMûjàTd£óÔDE˜&ä¨k¨Üuïb¶8PÁˆÜÌƹ¸›L£}38œÈäöð.ç‘»»È’Ž¨0.§Ãƒù¼¾›Lctss8úü‡6§qQ ÃtÔÂ8L'mð>›\LäÇ»ÑáC1^}>œÈbrøäœÿ|ø¶²¶°¿-f½Ã¿f1_´@d1ºmÈäî`"w³«ÃiÌgÚ òñ`"Ÿ­„_F·ýkÀüÔŸÞû?]Î9˜È^%ß")ÁKD3z?ÎÉV”XR^D»•á‰*8¢ûè.UûXa²-þöཱི¨•@±­‹¥O T¡Ø/’Æ°/é+ãL`6”³]S¤ÿ«t_—O¹î Äþ¯ä2 q鲋‰4cú>âýÑ'Šà”°ªf˜¯å–gpOn€q(4¡F„9¸±Ymx”£yŽ=忯óÎk1Zï˜rн£"cûù4Gq·ÊSd½H_úaó©ìôâˆq[ˆ ]Ü=¶NC¸Vnà µ`w±ëÁ‰™«Àj´Ø‡ø#¥¤u`¤Á²Úìµ27\Ñh&&ãƽ‚Çãà?Zç€Ùxî,ÐñìÏ%A½G÷LŽ D§«÷3¿t#„ëk>üšìɹ¾u?)ú|š½J‰eYç2pÓ,u?#ë}mø“/v}tÐNÅ0v4à] v¾³u—e @öîÄàAQö…4î'1}||ëUFSÿcm”™c4 >t¾.@cû- ‹«ýkâ„Ú-=‹X.KÇ &½9NšdŽdÞœJ ”àäL.MªáUç7ίո)óZr,zˆi,çÁõ@âÑ5è  ÕÛ€úÔËGˆÛ;ÛÀD…Ëvá«“¾›ÇÒ¢SŽ¶Æÿ­y1­HmN ­›Û¡å.-EdLªÅävUÆLzéB‘YKþ¸¯¸ÉR‰|Ýe1^Y8©Ç+A?MQ¦ sY5”¸~¥€îéðž˜ËÕ(Ž“,*¦«,lmøTŽ ÎdÉQÂòòÖËvoÝo¤KÛ^”âG¾eëÒÀ¨GÍ­Žxb’“–YÍ*ßYž¼ˆ»TÍÑb×t¤!©2¬·nF¬Ø;\‰$ËÌ )O±$þ1æ ,á8Z #´A$¶¢ žˆä[2(Y–,Åî¿·ì$ž=¶ok¥Èj¥C‚ÐzŽg(¡"Ê‚Ö4#…ò¢9e¹ö²‹v‚!ŠIˆw]Z,@ Ø'ðwÕû›65FY‰·2F¥žV9«Ö&hJÏ£ôÚ‘ÇlAã„JÏjC(PÙ3j¡É’k€’‡Ò§'ð„œ¹Ã¡† 7×äaëÆ\ô¤ÑKGÊ[‘<°î—Ü}±®éÐg©'‹:O4¶¿¦%U«ÕÜCVQ.Q¸c˜Æ&Kñ„Oe‰z6Y~Óëj¡ÒóP öÊâd)¹UJvY¬åÒJÇÄàÁ Ètrl…êÁ$(/­  añø+6[ç‹Ôrïd[§D7bí´Ùzßã£<ã|ü¹1¬`¾$)çH Ö|1>WU2ôB¦<íɹ۲½ü©ºaç O"œÁ_Ъoª|Š1pvæ>P'\Y à;sUÂTaÐ r#•ÎÎÙ)•[Ti;ñ8ÌOÅí*+*†QO௺¢@ì@½POÜcè™ûŸ?Ò¨e“kÿöñ¶Ûö“‡îZïôÓ»jùÛlпíªý®Zµ¡t›WT2Ôæ'Äb’?òÔ­ À}ÝGH)M%ÉýQzõÀ’e÷áP›U ¯Ðênµ‹i„ÇI 2ÁøÎië±S¯dŠi“ô˜–ß½Ú¤ ‡Ö¨·Íë²ïE·ÂÇ©B‚€q*ƒZ¾õ=]ÂîñNLRbeÑcø_îÉØ0OV\W÷k¸öÑ£F_)¯°"ÝMúî Y/9ÚWXË•¿g ÷]‘¯‹Ú9'·dí”ÈuÅõ%a÷2Yé¢ÜŸ¾Yu9(ă;׿õ™}•¶éã}ÑþƒýâáïÞ ãºßêÓwZŒÐý291ùá«“DÍè_:®×ñÆy ž–³4`‚hòÔ }1²Ã´ofF¢Ä‹ ¦~UÒ/×Û?,H:² Erˆêô~ÅÛ´É5 ÝTŽYËÞ¼éÎ>õã¿Î§~ú×ùÔoÿu>žÚ ÌøŽÄ‚àZ"Užø€Ä<.ÚØšCI)×›éyÃ4©9”a¤[ðöÕtæHG`͸DÉC=ça#¼Ö¿@—«ñuøÇ“ïðO§ÕáŸN¾ÃE )D|ÌgVP1Ðj‰‡SïÃ=¬,ßUßÑGÀƒ(©çÖQ/áÿì²[…Þõ÷ˆ«ͲBÂÀBíå½À:¸EmIL4J„#3L¾¡fáº]â¼y&©àó‰ÄÖú;O‰²!âKUýäÍBNéàIy>ù“F¦ þéÇ cþçSfþ—Sd>ÓVŸä´É˜?Éi“1ZÓæÒõbÁ{NQ»"¾6!Û1s®Ì6í±šêûm:ë}s—uef¹p"Z§Sà±Úµ'¢_:«]{"š¤Sà1ïÚ,ËÑiì_ÜÀWvuJ°ãñšß±NjB@8´ÿ9ŽÒ­ÿs2¥[ÿçTh½[`Ìl,q¿ –ÑjFÙö?Å»üÆìS¤ÑÌB&ñÿŽV*Cù}] þƒ 1fDiy}ä<*Í….Ò€Zu—wtëºlh]³µ\²*[Ç·ÓjÅÅÿÍ›62Š8I­œ]ÅkÃõVDœ"C9{ÜmÙMüÔŠ’«/¯ÔïˆÜÇǧ®·$õMË…¿R¡>×òBUûG\yôÁñ¢^fdC¿Ž¦Ä£Ý:þ‡?Ô1eQöX¿µÁŠ½ÊW̓LÒç¡(÷ 5ò&5aD=:þ²+³k”;áÜÀŒØ yŒY_TµêM²h0s×›Fˆs·¨p4À«µÂ 4• É,Bwæ6¹üÚ rAÃm·&ÀÅÖåéÑÍœerŒjh<è·™ {·ª\ýÕûX«¯›Ÿ~ñ¥£›ÊdíúC_mÞ¨iˆú¡yr?^ã\ì¶ï5‹÷XŸ˜|Ð?×\OÒå~A©·ß±w|?¯ežÏ„!ί–ö¤"@“@J)&A¡’,ìÑ^hw÷¤úö·¤ G†<2:~ nÔ¡q~‘ÈÈ~lv¬VœšQöÙ ›´& ¹¦@ªÝ;í¢™ÊŒJ0£Ôßm1p­_K²¢ó/.5}#€ù¡-BÛ"ô©-B߶EèmúS[„þóPB±ÓBƃ³ÌÉ/'5¤Bì¬Ë¹ž(Æ”‹£µqç™B:“óA‹H<‘±.–†4î`Ëx"Äûô/דòŒ•²¦ý"l1 ]Ì•áÅ®]• ªC¼º¦IX-ïcçEìS6Õ©»¤0*ÅózÑÏÄ©¶BœRlÈ"4”ƒt~ !èd¥pöeΙÅú„8ÛòÁÊå*î*'kœtØZã Rðô8ÎáŒ#8ÄY<†j†ô'HeËŽT,±Æ³[ïÁ .²L(ËäyãÔ·»O_í!AB:ˆH IV<ó¹.ZXÜ™—pÖòs'McNÆyþÎù=‘wåœßy°~çÉéM‰ŒåšË'41ÚSc–#t¸l#«xgŠïXø²R/æX˜)¤5]-P¬„’6âÂa¢HYžy]â­ª…ÚçÊýäa²Š×åÔa¬^ÄŽzVw·ì<67²ïÊì®Ä¬Á ú»p H™NÝ!ÜÎgÇKŒ§ò»á\ï 𙞜Žwiqð.%+<0ÁüíD–%&ÑǨ7üžŒcQÆï)9Å;¥íàë ­!°Õó#7ÞÏ`_xIíclRÚ1Ó7“AJð÷´üoÈ3ñNç4|þò”Ž±±óÚó݈Æ! ŒQºïj~`ÓúÂuŒOàîÙ>卵]úº›üp"Syvuу•w*ÙŒDîJŠîÝL;GªŽûÖÎ=é0k®*ì˜Yx{±Üw߃hþ…UœÊ~SÒnœþ¢††Nçc ©P2šÍ¥_F ^íòÀ_Ð ¤ÉÒs¢¨ZÝT.Z¹Ï•’M%g+ÂŒD墭TJ¢Àñ«E•|tP£)|¥ LJEà‰3 ĆRøö¤€ø|næ2´Gd)“`ŒÝ±Ç°kä‹àµ?SŸÇM€¥>MR+)À#&Û¾ˆœ©°b°óUu *­†¡O³Gæó~šÒ3ÿ]„=šÂ]?‰>ØAÏHî °á¿ð(ë¢æ¨÷ p-qŒÁoϳµê¶Á¶Ó¬ZiÞ‚õ€Ø …! ˜M”íQÒ<·eÑ£PºÌAï`qž˜ªÉѪÑO±žŠ²m£°Œ0Ú°-¶Ü£iiÁ|…£Ý’usÌû¦¨ÅEe‡úK)gˆÒ0ÅhÆ$7´EÈýD¨Zá"$ÛÌk'Ñ~x$g}¹ó=Es«”˜±ÜÍR~ ¹v)´cwK>|¼ÜÆU/È8õ§\ÐÔ ¯lÔÆþ-Aº"qÙÑ]úêâíE˽DÃDˆ™ý='iy^8Ç è^PažÀX>´ϸóWNXw eu°å +¨Å¡™u* dÔÊʆ~²--Ö²Dó’ËnÓ¬…Ö$,¢ˆ×$ë.6'6…Ôh¦Ý{C_HúÉhOËŠfø,ïxEVî}QÝAûþzúß÷ºTÙQ00½ç4t·Zó^ôÕÚѾ¶E-j…P0§aq`YT.«%\ÎíÓÿ¦t%ÂýA„“åæÒõ*v§PRMëÅAùJžÆûm¼^”Âf÷ÅÚ%³p‘ Kk-t–$ùø7ù‘ÖŽõ8ï`YÓHÍmEfBUkô†¾÷ëÄÇ´Z<,í¶Š·Üz@£¢½ö¾ðª<ëBIÚl>1°_ØÞ5˜ìNVÛ+s¿º®Œ‹C7K»$³æ Ýg×ñLn“aâ/ËsŸ {•‰0ðµûm—uX]âH±F“TÎia‹ wÿ° ŸánšÄ8 þ!ánq˜«'p å“Zæˆ(—Ðd^ˆ* ÀRÑ¥Ž”c‹Õ-‚ÌؼÅû%›0µê,Çerï [(ÃÅ;b¤#÷BM–'¸¦Rï¡nKrWCyçÇŒé*ñª‰Áem0ø»ñËÍà2y<üË€ÊÁÞx)™yt m[+ÔöìKÉ´ÊÔÁ^‚)™V™:Øã0%Ó*S{/¦dZeê`OÈ”L«LîU‰dZäiF‚^¸ŽZ"ÕŠ“ø]í&pç?ÐW&ÌÝeQ „"*—sÅ"êÝ€,é6h€8\­%,J´«PŒT‰³R¹…g0û¦Pk6å ³êßPÙKUÀMQªº›Ë¾—«IG“ ÖYñ‡¯Ä'WË©®õÎÿ1aR»Tf`³C ‘‚ëy`+†¾"®OVCÀû±H¬˜ðÑ¿0±JŠqJ2QôRÔ#çð„æ1ʤ_pãC ˆGb ÌÐ_©F>ëÌXØNC¢ñ[d‘!U¦F€,ÐHú7”½¦ÚtJA>~¨oXw>»LÈKSê*ïúG 7uçº0µ´2øµ–Y°Úf»?þYcYÕrF¥;?d aØß®*Sˆ°[@4ŠkÉÑ&Ï$ôø”hë‚‘q×l©CäuÇ'ðK±ýŸ>͈‘Ëî1¹øôÉ(áî±X™¥I=bóþÿëº>r6:žÀÈ·?³Þ Å|]3ðáüã{èˆoÙ?÷ÐlLŒòÁ—‰?ýñ=ððÆ£Ûí*e¡«Ž¨?R’é.Зz˜AyÛ»ˆô¹ú¿yCF#úq%TÏ9—ï$šj$tMéS$”?Å2)C *~ФL:¹ g7£Ûáýt2-F“[Á³c/¦[Ñ£ãyq=êÿp;œÏm°—»¥'ÑT _þh¬ƒZ=>¶þ\ DÛgTUo£Í‰ÕGêI’¨TBˆ&1ÔãÈð¼Š9L⣥ôM¦¤9Jü«¬‰LØó\'"5E ƒüÑra ÉÿþÆ>îo‘¥Ø¹¤<ÅZÈÐðÉRQ øÓj3öÝÖÁšˆ½VûwÞ°Z¼:JËlGïÓíÖñ™Ì vNR‡ýì @ô¤Pó$Ðã¥Usv¬:^%Hªª”µÍÇ7]®¡vo&¤ GvjEÅ@ ù6xC÷2tÖhœT­@[°Z!¼V ùd­–²cMÈ«åó冊sgÃjj±!üm¹"b“ ‹K³íŠÄ“ f£”–2¤jPV¸êƒwà‡»ºJïãáô¸¸\uöØoÁf›©‚í«#¡fŠÕ^…4 ªï‚ˆDðœ Ã7œoHÕ›ZYt:ä€Õ\{X¸RApNÀWæÁ媻&^Ö==Åóˆ²[ôkˆWÃ@;¡}þ°F韒Ή`ì“1$.§ëL•!-ÓH1\ûägŸ11‰Æèéâÿ›_7ø‡~úWøÐÔlótçcLW$zªn‰ÎYÑÔØÂÒ8ÍM¹—­MöÍvs›pšF–­6ÜÕ‡¾yJBÞ®fqþót°.þÞÑ:x`ÙÿÈóvEϱx02üg˜aß¾ƒÎæJ´.„Ü=ÕNSƒøÈÔ)ºÅw”élàNG}mÔÙã-ƒrž7šü.y hw;õÜÈ}p½ÒËY+V™f¯jû敯[(¦¨o,xÖ>Iú©2È”Òh`Úc4¤>uU è«Ï{åóóh~×»©²¡´ñ|–ÝÒ¥7O†á®DfXš;X ¥Ð¯yÍhá¬Å5¢Šµ_)IH¹@¢+P°.¹Ï«04—yªet†áVáb™o’#óyéÄÚ¬h†¹ÐžñþlÒ(ÛtÇW›—¶ÚõžIø@#Â1á´pS®®­æ°8"œÐ¤pÝ´waNÉâ:h“hL4ϽÇ8y»$&…†Ý%)p³Âô~{õ̳Æì`õx8| \pV?èÉáùègm¡… (oÆl#1<Öö¨—‰çí&Ñ2)¹çb[ÙôìѦNî4|çSKÔjdògÊÎFË@§ÏTbµ›{O0‰ó@DŠÜj®M©" œeéPúò¿ÐççD¯O1©ßÎâäÆìÿø›•®|­ªÙÁ¿°ÚÄd5 i+[s~+È\mž}Ù≢[áH¸}.FÖ„ª›¤-øK/‰6æð¡à  uòB¼oêˆWζ’‹±€âÆåǯ4”m±hÿé~q½•ýc‘(X‰Y“RëÆËÏl[ãØ}Ìà`ƒ1sâæÙÒÌBœ++ãPŽsC{SÜ€‹Rœ˜9`V©³Û²– U-GcôI½o›>“|!íI§º¥€TÌl¾ÞZo¹L¶<4LS ^°qýlE„gò<„yLü¥ë5§ÁdZ~¬ã_™ÌQ8½Yñ‡? @°æÓGryßcUúVFàÏ °c¿ÑB¸q!~ƒà…ßÓ(›È€ß­ÖÛ±w&ôÖ]¤`)Õª=òÁd_ …®DªŽ®®+ç”RõÂ7 ý-9®Ï^F·ƒÉÒãûþMÏÊeQFÃÛÅý¸×¿Ý-q'ãqïÖFÇX3 KGýÉíýmolÉ¢ÍG¿X¢Ù7t;™{7M¾ ¸k‚·˜õnç8p—“™ê/“IƒA`·&¶!ŸK§KŽ&)ÏñªæuéO¬þqN¶"—cIùéV†%ªàh Ênœ[ù‹öžŠ/$Šíľv©89Ç*`zì±Úá®4EÞh|¹"7º_zN‰5×Ó (7.Ýí±Ô jàFç¼[‹x“Çù2$DäJ)«HÑç{EƒÔH{9)Î^ÜÕš”|ªXI9¿ŒÇÍØ܆˜²{ TïîhìXŸ%živîÀvÁ¤*~Áﮉ†•7Æ\Dà¨\·§P;¦pöû¢]ã*»Fí-k]ܬò–]¡-¿Øäˆ]÷Ñx.'„6ä×úþÆј+È‹MLËœ@/x÷@³" ‰ [auç‚„í¯îÌ`8©pY±L©>Ýr¨u~”RŠf•€_ý aiå3ä]Ë æ©ß°=èÜF £_^ýõA¨½½›]ÌÕ0–sžµïV^Ed C~ªÁI/\Ö*aÃ$Ú˜ö{©óÌ>Í^µ  XU)l߸ú¦Í[´þÅ”æ ¢F#UÒ>(×Ò3Xý×á„ÈŠX”WVoÞ…Ú ØcŽ5Ø*7Ê(0ä^ 3ôWöåð•è=ð’ú±Ùò5Lr ×Îjw¡väš] vmÑŠ–[›)#?Hây@ nd_£q‘¥ø‘&B$ǯŸÐ‚»tiBjÁêïm nزÆÃàˆ-³‹f‡:JÎD7a°m×Ç lïÔÛ­!]˜ž.‡m› ˆ’æu( ¥‘ŠŒ“$¶>⧤âj,¨NvV¡ÛàBÑýÔ›Š²1‹ ËÃ> 麠¦ áfbê"aµ¢Õoš]]˜Í¯º’ž?7òªêej_'z–Qj58éäTÏ¡Ì`¾Í v· $†‹´t,ÏЃP‚—ÙkÈ¡¯JÁÃ(iÔcIƒlA¶¦-]^ø4Iá^cŒ‰PžªÉ(*¤z ÅŽ™úMuw@ˆ,Íd_ÆaïÍ€W¡ó" ¥§ˆ±¨®µÏ8`Ñ$¶Ðˆ1hs¡Í`´”²-_¤q¼Q¼^Be˯5‚B7.¸!ú_T.ÿ`äÄ…ZD¬¯¦Íšu lÄ*æ gí{*!0>Ü8…¡°F“ICÆó?Óbƒ–¬¸NBÓQ`p>6û®&ñ³8"LØ(ÆVpZT¬Ú|‘4þÉ`€ÍÀeé‘•)þAÌ9¾.ñ3ÒQ¥oþ‰[¶~pü)ïC{Ô† ÷³Bz…,íö]õ?ƒÏ›(N©äe8;;2vEüé²³ç,C²í‰1Ïâfßà˜Â²±Ç›“˜7"Ýæþž"ºâ¾ÈtNrG›_¸ÿƒá<` ÌA?šƒ~2ýÖôæ 2ýOsÐ?›ƒþÿæ = С¬³LbSÛ€_ºá2Ù>zEßA-ÒÊuHHرg³gƼøþÆ|fŽ2š98~WÌ_X€2¹‚C™£`*Zsðü®ŒÁû ŸÓ³¢{4!4GY’•ëyŽ†GœÐœ )6s-C±˜o¦g4€òÁæð%¿1´ÅV2\\[[î;Ã&ûΰÁ¾3´Üw†¾©i&cN$ ø¢ùžø•Øõ饨…pùÁB²¸ü`EÙBº¸ü`!_\~°0.?XÈ—,¤ŒËrÆå Iãòƒ…¬qiÓÍmFû£Íh´bÃf´?ÚŒöG›Ñþh3ÚmFû£Íh´m›žûd3ÚŸlFû“Íh²âÙf´?ÙŒ¶ aº6“ÈfÙL!›äÚ‚Wæ Å5ñ hºµ8(¯Y]h#ñq yodj)9šHN£’ÓÈRrù csøÿ6ýÁtj£aÐ{ƒ¶ØԴŮƠ-vm±ÿ0h‹ˆA[ìA ÚbbÐûƒî­,v"oy7f²t·ÕØpZ»; ¸Ï® P¬nv Áêî‚ð5'=Æ×Z= †ÍMÀ혬àvKÌîTa¶[ C)Ç­0@'^ìž©›$Gº-¥0@˜:kb?ëÎâܜЭ&’Ô`Ìʾfs8¡[¶c©–Œä!¥s çÁ Þ¦-dœ‹…zc£¸±XÒ7ëùÆb1ßXœ–7gåÅIycqNÞXœ’v;Èë“GbìÌ0Æ ÄOl cÇf†"¼…†÷Ñ‹/-´n¸½Þ?UóúªPn-@­öá[Ëg‡Ûdk©^ŸX€ZÞS&Mî)“÷”ÉÚîž2¡žû5±Á°‡©¨ý9k}ÈN1.€98†µ·9W4µXê3‹ÃkfsxÍlôÙ3}öÌFŸ=³ÑgÏlôÙ3–m8¶a؆_‹Óyfq:Ï,Nç™Åé<#+j'¡Å^`) Ï-@—!õ<Ëã„;YÀoÜG«gþÁŽ)ıØL扥z#Ø´°‹ØP5G0 ç ×“™…DbuûXl¨Íì¼³µ”.îšHw ¤‹;KéâηYï6Çøg Pê®æ»íµÐÕ|1ýÉôg PË)ð‹9¨…ùˆcÉ…Ód"Ú¶Ñ`Þ:6ô-縳eû]äØh€FqHƒM3vFZN´t]>–H–â=øqc¥†Å™èXrc±}cœ[ω,®Ã6¶T¡³d€:QB;)pžHlßC²n bYuÂÒÔÚ¸­‚Í]nI=jq¾/évkà v–ýÏý–Ê‹=iEÖ!±Xi vá• )lútŤn›éfÁ?±ûFþëìW7Å5bÅŸ$åßÊá÷+¿ÿTùýŸ•ß˜ëMLªdÍB]µi(«6eU LÄÆøäòÇdŒßŸçÿõ;>Ú Þ³ÿú.‡›²Û˜ç1~Öüõì7¥°Vµ@Wwþ}%«bÑÀ}ÌÂHùqž°>ÿƒ“(¬þßüF4×~[øó7…¿ÛVÆõßþ®=Rß©·&ÞÏÅç„C÷¥ß~÷›7oòïê‰òÛ¿ëþñæ,ÿãÍ{éÿãsy§òÙÙ¿‰s?ãoIîçKq. vh>íÿWŽŒß×þ{éï¯Bþn_û»ß‰ÖÚïXqg¿<%¹¡`o› £åñZH–¼~ï9ÿ·s‘´v®™Yç— ið~¿où÷¿?`ŸãÐg¿ÿnOï/…?ûÛï5)¶˜ì²ÀÿmÈÆëøãò—ß}_™-m—ùï‹ûÿ_~_þù—ò¯¿T§ó_þò×ZQ±ç¿oOýp„îV ¨ü½*¦sãïúöð»BÏré%ëÂ÷/Å|WïﾃïâówùÔßHB’u±àìû=Â÷ïÊj9í 9€dÛþ¾ÀÑ÷ߟlÇ~ÿýw'Ì{u¿bEµ­â{Í™ð½îÐø?ßýo>ß®ï|7>¿p"RøÍêuÕß)ëÿ/û§.=³¿ç$.œÝe™êÎþºŸ­ïš­÷Î_ ì«bÇß ‘"ýǾö?4=õº®üÇ)»âšžþ‡®ZÝÓÿØk*uLÍlambdabot-4.3.0.1/State/L.hs0000644000000000000000000000420612215111456013577 0ustar0000000000000000{-# 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 Control.Applicative import Control.Arrow import Control.Monad import Control.Monad.Cont import Control.Monad.Identity import Control.Monad.Instances import Control.Monad.Reader import Control.Monad.ST.Safe import Control.Monad.State import Control.Monad.Writer import Data.Bits import Data.Bool import Data.Char import Data.Complex import Data.Dynamic import Data.Either import Data.Eq import Data.Function import Data.Int import Data.List import Data.Maybe import Data.Monoid import Data.Ord import Data.Ratio import Data.STRef import Data.Tree import Data.Tuple import Data.Typeable import Data.Word import Numeric import System.Random import Lambdabot.Plugin.Eval.Trusted import Text.PrettyPrint.HughesPJ hiding (empty) import Text.Printf 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.IntMap as IM import qualified Data.IntSet as IS import qualified Data.Map as M import qualified Data.Sequence import qualified Data.Set as S import qualified Data.Traversable {-# LINE 1 "" #-} lambdabot-4.3.0.1/State/Pristine.hs0000644000000000000000000000420612215111456015201 0ustar0000000000000000{-# 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 Control.Applicative import Control.Arrow import Control.Monad import Control.Monad.Cont import Control.Monad.Identity import Control.Monad.Instances import Control.Monad.Reader import Control.Monad.ST.Safe import Control.Monad.State import Control.Monad.Writer import Data.Bits import Data.Bool import Data.Char import Data.Complex import Data.Dynamic import Data.Either import Data.Eq import Data.Function import Data.Int import Data.List import Data.Maybe import Data.Monoid import Data.Ord import Data.Ratio import Data.STRef import Data.Tree import Data.Tuple import Data.Typeable import Data.Word import Numeric import System.Random import Lambdabot.Plugin.Eval.Trusted import Text.PrettyPrint.HughesPJ hiding (empty) import Text.Printf 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.IntMap as IM import qualified Data.IntSet as IS import qualified Data.Map as M import qualified Data.Sequence import qualified Data.Set as S import qualified Data.Traversable {-# LINE 1 "" #-} lambdabot-4.3.0.1/State/source0000644000000000000000000006316112215111456014300 0ustar0000000000000000asTypeIn a `asTypeIn` f = a where _ = f a infixl 0 `asTypeIn` Mu newtype Mu f = In { out :: f (Mu f) } In newtype Mu f = In { out :: f (Mu f) } out newtype Mu f = In { out :: f (Mu f) } Rec newtype Rec a = InR { outR :: Rec a -> a } InR newtype Rec a = InR { outR :: Rec a -> a } outR newtype Rec a = InR { outR :: Rec a -> a } (=<<) f =<< x = x >>= f sequence sequence [] = return [] sequence (x:xs) = do v <- x; vs <- sequence xs; return (v:vs) --OR sequence xs = foldr (liftM2 (:)) (return []) xs sequence_ sequence_ ms = foldr (>>) (return ()) ms mapM mapM f as = sequence (map f as) mapM_ mapM_ f as = sequence_ (map f as) guard guard True = return () guard False = mzero forM forM = flip mapM forM_ forM_ = flip mapM_ msum msum = foldr mplus mzero join join x = x >>= id mapAndUnzipM mapAndUnzipM f xs = sequence (map f xs) >>= return . unzip zipWithM zipWithM f xs ys = sequence (zipWith f xs ys) zipWithM_ zipWithM_ f xs ys = sequence_ (zipWith f xs ys) foldM foldM _ a [] = return a foldM f a (x:xs) = f a x >>= \fax -> foldM f fax xs foldM_ foldM_ f a xs = foldM f a xs >> return () replicateM replicateM n x = sequence (replicate n x) replicateM_ replicateM_ n x = sequence_ (replicate n x) when when p s = if p then s else return () unless unless p s = if p then return () else s liftM liftM f m1 = do { x1 <- m1; return (f x1) } liftM2 liftM2 f m1 m2 = do { x1 <- m1; x2 <- m2; return (f x1 x2) } liftM3 liftM3 f m1 m2 m3 = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) } liftM4 liftM4 f m1 m2 m3 m4 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) } ap ap = liftM2 id (>>) m >> k = m >>= \_ -> k fail fail s = error s compare compare x y | x == y = EQ | x <= y = LT | otherwise = GT (/=) x /= y = not (x == y) (==) x == y = not (x /= y) (<) x < y = case compare x y of { LT -> True; _other -> False } (<=) x <= y = case compare x y of { GT -> False; _other -> True } (>) x > y = case compare x y of { GT -> True; _other -> False } (>=) x >= y = case compare x y of { LT -> False; _other -> True } max max x y = if x <= y then y else x min min x y = if x <= y then x else y [] data [] a = [] | a : [a] foldr foldr f z [] = z foldr f z (x:xs) = f x (foldr f z xs) build build g = g (:) [] augment augment g xs = g (:) xs map map _ [] = [] map f (x:xs) = f x : map f xs (++) [] ++ ys = ys (x:xs) ++ ys = x : (xs ++ ys) -- OR xs ++ ys = foldr (:) ys xs Bool data Bool = False | True deriving (Eq, Ord) (&&) True && x = x False && _ = False (||) True || _ = True False || x = x not not True = False not False = True otherwise otherwise = True () data () = () Ordering data Ordering = LT | EQ | GT String type String = [Char] Char data Char = C# Char# Int data Int = I# Int# id id x = x const const x _ = x (.) (f . g) x = f (g x) NB: In lambdabot, (.) = fmap flip flip f x y = f y x ($) f $ x = f x ($!) f $! x = x `seq` f x until until p f x | p x = x | otherwise = until p f (f x) asTypeOf asTypeOf = const head head (x:_) = x head [] = undefined tail tail (_:xs) = xs tail [] = undefined last last [x] = x last (_:xs) = last xs last [] = undefined init init [x] = [] init (x:xs) = x : init xs init [] = undefined null null [] = True null (_:_) = False filter filter _ [] = [] filter p (x:xs) | p x = x : filter p xs | otherwise = filter p xs foldl foldl f z [] = z foldl f z (x:xs) = foldl f (f z x) xs scanr scanr _ q0 [] = [q0] scanr f q0 (x:xs) = f x q : qs where qs@(q:_) = scanr f q0 xs iterate iterate f x = x : iterate f (f x) repeat repeat x = xs where xs = x : xs replicate replicate n x = take n (repeat x) cycle cycle [] = undefined cycle xs = xs' where xs' = xs ++ xs' takeWhile takeWhile _ [] = [] takeWhile p (x:xs) | p x = x : takeWhile p xs | otherwise = [] take take n _ | n <= 0 = [] take _ [] = [] take n (x:xs) = x : take (n-1) xs drop drop n xs | n <= 0 = xs drop _ [] = [] drop n (_:xs) = drop (n-1) xs splitAt splitAt n xs = (take n xs, drop n xs) break break p = span (not . p) span span _ xs@[] = (xs, xs) span p xs@(x:xs') | p x = let (ys,zs) = span p xs' in (x:ys,zs) | otherwise = ([],xs) reverse reverse = foldl (flip (:)) [] and and = foldr (&&) True or or = foldr (||) False any any p = or . map p all all p = and . map p elem elem x = any (== x) notElem notElem x = all (/= x) lookup lookup _key [] = Nothing lookup key ((x,y):xys) | key == x = Just y | otherwise = lookup key xys concatMap concatMap f = foldr ((++) . f) [] concat concat = foldr (++) [] (!!) xs !! n | n < 0 = undefined [] !! _ = undefined (x:_) !! 0 = x (_:xs) !! n = xs !! (n-1) zip zip (a:as) (b:bs) = (a,b) : zip as bs zip _ _ = [] zip3 zip3 (a:as) (b:bs) (c:cs) = (a,b,c) : zip3 as bs cs zip3 _ _ _ = [] zipWith zipWith f (a:as) (b:bs) = f a b : zipWith f as bs zipWith _ _ _ = [] unzip unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[]) elemIndex elemIndex x = findIndex (x==) elemIndices elemIndices x = findIndices (x==) find find p = listToMaybe . filter p findIndex findIndex p = listToMaybe . findIndices p findIndices findIndices p xs = [ i | (x,i) <- zip xs [0..], p x] isPrefixOf isPrefixOf [] _ = True isPrefixOf _ [] = False isPrefixOf (x:xs) (y:ys) = x == y && isPrefixOf xs ys isSuffixOf isSuffixOf x y = reverse x `isPrefixOf` reverse y isInfixOf isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) nub nub = nubBy (==) nubBy nubBy eq [] = [] nubBy eq (x:xs) = x : nubBy eq (filter (\ y -> not (eq x y)) xs) delete delete = deleteBy (==) deleteBy deleteBy eq x [] = [] deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys (\\) (\\) = foldl (flip delete) union union = unionBy (==) unionBy unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs intersect intersect = intersectBy (==) intersectBy intersectBy eq xs ys = [x | x <- xs, any (eq x) ys] intersperse intersperse _ [] = [] intersperse _ [x] = [x] intersperse sep (x:xs) = x : sep : intersperse sep xs intercalate intercalate xs xss = concat (intersperse xs xss) transpose transpose [] = [] transpose ([] : xss) = transpose xss transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) : transpose (xs : [ t | (h:t) <- xss]) partition partition p xs = foldr (select p) ([],[]) xs where select p x ~(ts,fs) | p x = (x:ts,fs) | otherwise = (ts, x:fs) mapAccumL mapAccumL _ s [] = (s, []) mapAccumL f s (x:xs) = (s'',y:ys) where (s', y ) = f s x (s'',ys) = mapAccumL f s' xs insert insert e ls = insertBy (compare) e ls insertBy insertBy _ x [] = [x] insertBy cmp x ys@(y:ys') = case cmp x y of GT -> y : insertBy cmp x ys' _ -> x : ys maximum maximum [] = undefined maximum xs = foldl1 max xs minimum minimum [] = undefined minimum xs = foldl1 min xs genericLength genericLength [] = 0 genericLength (_:l) = 1 + genericLength l group group = groupBy (==) groupBy groupBy _ [] = [] groupBy eq (x:xs) = (x:ys) : groupBy eq zs where (ys,zs) = span (eq x) xs inits inits [] = [[]] inits (x:xs) = [[]] ++ map (x:) (inits xs) tails tails [] = [[]] tails xxs@(_:xs) = xxs : tails xs sort sort = sortBy compare sortBy sortBy cmp = foldr (insertBy cmp) [] unfoldr unfoldr f b = case f b of Just (a,new_b) -> a : unfoldr f new_b Nothing -> [] foldl' foldl' f a [] = a foldl' f a (x:xs) = let a' = f a x in a' `seq` foldl' f a' xs foldl1 foldl1 f (x:xs) = foldl f x xs foldl1 _ [] = undefined sum sum = foldl (+) 0 product product = foldl (*) 1 unlines unlines = concatMap (++ "\n") unwords unwords [] = "" unwords ws = foldr1 (\w s -> w ++ ' ':s) ws words words s = case dropWhile isSpace s of "" -> [] s' -> w : words s'' where (w, s'') = break isSpace s' Maybe data Maybe a = Nothing | Just a maybe maybe n _ Nothing = n maybe _ f (Just x) = f x isJust isJust Nothing = False isJust _ = True isNothing isNothing Nothing = True isNothing _ = False fromJust fromJust Nothing = undefined fromJust (Just x) = x fromMaybe fromMaybe d x = case x of {Nothing -> d;Just v -> v} maybeToList maybeToList Nothing = [] maybeToList (Just x) = [x] listToMaybe listToMaybe [] = Nothing listToMaybe (a:_) = Just a catMaybes catMaybes ls = [x | Just x <- ls] data Either a b = Left a | Right b either either f _ (Left x) = f x either _ g (Right y) = g y fst fst (x,_) = x snd snd (_,y) = y curry curry f x y = f (x, y) uncurry uncurry f p = f (fst p) (snd p) fix fix f = let x = f x in x on (*) `on` f = \x y -> f x * f y Complex data (RealFloat a) => Complex a = !a :+ !a realPart realPart (x :+ _) = x imagPart imagPart (_ :+ y) = y conjugate conjugate (x:+y) = x :+ (-y) mkPolar mkPolar r theta = r * cos theta :+ r * sin theta cis cis theta = cos theta :+ sin theta polar polar z = (magnitude z, phase z) phase phase (0 :+ 0) = 0 phase (x:+y) = atan2 y x toDyn toDyn v = Dynamic (typeOf v) (unsafeCoerce v) fromDyn fromDyn (Dynamic t v) def | typeOf def == t = unsafeCoerce v | otherwise = def fromDynamic fromDynamic (Dynamic t v) = case unsafeCoerce v of r | t == typeOf r -> Just r | otherwise -> Nothing second f = arr swap >>> first f >>> arr swap where swap ~(x,y) = (y,x) (***) f *** g = first f >>> second g (&&&) f &&& g = arr (\b -> (b,b)) >>> f *** g returnA returnA = arr id (^>>) f ^>> a = arr f >>> a (>>^) a >>^ f = a >>> arr f (<<<) f <<< g = g >>> f (<<^) a <<^ f = a <<< arr f (^<<) f ^<< a = arr f <<< a modifyIORef modifyIORef ref f = writeIORef ref . f =<< readIORef ref (<$>) f <$> a = fmap f a (<$) (<$) = (<$>) . const (*>) (*>) = liftA2 (const id) (<*) (<*) = liftA2 const (<**>) (<**>) = liftA2 (flip ($)) liftA liftA f a = pure f <*> a liftA2 liftA2 f a b = f <$> a <*> b optional optional v = Just <$> v <|> pure Nothing some some v = some_v where many_v = some_v <|> pure [] some_v = (:) <$> v <*> many_v readMVar readMVar m = block $ do a <- takeMVar m putMVar m a return a swapMVar swapMVar mvar new = block $ do old <- takeMVar mvar putMVar mvar new return old withMVar m io = block $ do a <- takeMVar m b <- Exception.catch (unblock (io a)) (\e -> do putMVar m a; throw e) putMVar m a return b modifyMVar_ modifyMVar_ m io = block $ do a <- takeMVar m a' <- Exception.catch (unblock (io a)) (\e -> do putMVar m a; throw e) putMVar m a' modifyMVar modifyMVar m io = block $ do a <- takeMVar m (a',b) <- Exception.catch (unblock (io a)) (\e -> do putMVar m a; throw e) putMVar m a' return b handle handle = flip catch handleJust handleJust p = flip (catchJust p) mapException mapException f v = unsafePerformIO (catch (evaluate v) (\x -> throw (f x))) try try a = catch (a >>= \ v -> return (Right v)) (\e -> return (Left e)) bracket bracket before after thing = block $ do a <- before r <- catch (unblock (thing a)) (\e -> do { after a; throw e }) after a return r finally a `finally` sequel = block $ do r <- catch (unblock a) (\e -> do { sequel; throw e }) sequel return r bracket_ bracket_ before after thing = bracket before (const after) (const thing) putChar putChar c = hPutChar stdout c putStr putStr s = hPutStr stdout s putStrLn putStrLn s = do putStr s; putChar '\n' print print x = putStrLn (show x) getChar getChar = hGetChar stdin getLine getLine = hGetLine stdin getContents getContents = hGetContents stdin interact interact f = do s <- getContents; putStr (f s) readFile readFile name = openFile name ReadMode >>= hGetContents writeFile writeFile f txt = withFile f WriteMode (\ hdl -> hPutStr hdl txt) appendFile appendFile f txt = withFile f AppendMode (\ hdl -> hPutStr hdl txt) readLn readLn = do l <- getLine; r <- readIO l; return r hPutStrLn hPutStrLn hndl str = do hPutStr hndl str; hPutChar hndl '\n' withFile withFile name mode = bracket (openFile name mode) hClose exitFailure exitFailure = exitWith (ExitFailure 1) failIO failIO s = ioError (userError s) FilePath type FilePath = String IORef newtype IORef a = IORef (STRef RealWorld a) newIORef newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var) readIORef readIORef (IORef var) = stToIO (readSTRef var) writeIORef writeIORef (IORef var) v = stToIO (writeSTRef var v) read read s = either error id (readEither s) reads reads = readsPrec minPrec IOArray newtype IOArray i e = IOArray (STArray RealWorld i e) ExitCode data ExitCode = ExitSuccess | ExitFailure Int throw throw exception = raise# exception IOMode data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode killThread killThread tid = throwTo tid (AsyncException ThreadKilled) STArray data STArray s i e = STArray !i !i (MutableArray# s e) (!) arr@(Array l u _) ! i = unsafeAt arr (index (l,u) i) bounds bounds (Array l u _) = (l,u) indices indices (Array l u _) = range (l,u) elems elems arr@(Array l u _) = [unsafeAt arr i | i <- [0 .. rangeSize (l,u) - 1]] assocs assocs arr@(Array l u _) = [(i, unsafeAt arr (unsafeIndex (l,u) i)) | i <- range (l,u)] (//) arr@(Array l u _) // ies = unsafeReplace arr [(index (l,u) i, e) | (i, e) <- ies] undefined undefined = error "Prelude.undefined" error error s = throw (ErrorCall s) catch catch m k = catchException m handler where handler (IOException err) = k err Float data Float = F# Float# Double data Double = D# Double# ForeignPtr data ForeignPtr a = ForeignPtr Addr# ForeignPtrContents ForeignPtrContents data ForeignPtrContents = PlainForeignPtr !(IORef [IO ()]) | MallocPtr (MutableByteArray# RealWorld) !(IORef [IO ()]) | PlainPtr (MutableByteArray# RealWorld) Int16 data Int16 = I16# Int# Int32 data Int32 = I32# Int32# Int64 data Int64 = I64# Int64# Integer data Integer = S# Int# | J# Int# ByteArray# (-) x - y = x + negate y negate negate x = 0 - x subtract subtract x y = y - x Ptr data Ptr a = Ptr Addr# nullPtr nullPtr = Ptr nullAddr# castPtr castPtr (Ptr addr) = Ptr addr plusPtr plusPtr (Ptr addr) (I# d) = Ptr (plusAddr# addr d) minusPtr minusPtr (Ptr a1) (Ptr a2) = I# (minusAddr# a1 a2) Ratio data (Integral a) => Ratio a = !a :% !a Rational type Rational = Ratio Integer reduce reduce _ 0 = undefined reduce x y = (x `quot` d) :% (y `quot` d) where d = gcd x y (%) x % y = reduce (x * signum y) (abs y) numerator numerator (x :% _) = x denominator denominator (_ :% y) = y fromIntegral fromIntegral = fromInteger . toInteger realToFrac realToFrac = fromRational . toRational even even n = n `rem` 2 == 0 odd odd = not . even (^) x ^ 0 = 1 x ^ n | n > 0 = f x (n-1) x where f _ 0 y = y f x n y = g x n where g x n | even n = g (x*x) (n `quot` 2) | otherwise = f x (n-1) (x*y) _ ^ _ = error "Prelude.^: negative exponent" (^^) x ^^ n = if n >= 0 then x^n else recip (x^(negate n)) gcd gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined" gcd x y = gcd' (abs x) (abs y) where gcd' a 0 = a gcd' a b = gcd' b (a `rem` b) lcm lcm _ 0 = 0 lcm 0 _ = 0 lcm x y = abs ((x `quot` (gcd x y)) * y) ST newtype ST s a = ST (STRep s a) STRep type STRep s a = State# s -> (# State# s, a #) runST runST st = runSTRep (case st of { ST st_rep -> st_rep }) runSTRep runSTRep st_rep = case st_rep realWorld# of (# _, r #) -> r ShowS type ShowS = String -> String showsPrec showsPrec _ x s = show x ++ s show show x = shows x "" stToIO stToIO (ST m) = IO m ioToST ioToST (IO m) = (ST m) unsafeIOToST unsafeIOToST (IO io) = ST $ \ s -> (unsafeCoerce# io) s unsafeSTToIO unsafeSTToIO (ST m) = IO (unsafeCoerce# m) scanl scanl f q ls = q : case ls of [] -> [] x:xs -> scanl f (f q x) xs scanl1 scanl1 f (x:xs) = scanl f x xs scanl1 _ [] = [] foldr1 foldr1 _ [x] = x foldr1 f (x:xs) = f x (foldr1 f xs) foldr1 _ [] = undefined scanr1 scanr1 f [] = [] scanr1 f [x] = [x] scanr1 f (x:xs) = f x q : qs where qs@(q:_) = scanr1 f xs trace trace string expr = unsafePerformIO $ do hPutStrLn stderr string return expr STRef data STRef s a = STRef (MutVar# s a) newSTRef newSTRef init = ST $ \s1# -> case newMutVar# init s1# of { (# s2#, var# #) -> (# s2#, STRef var# #) } readSTRef readSTRef (STRef var#) = ST $ \s1# -> readMutVar# var# s1# writeSTRef writeSTRef (STRef var#) val = ST $ \s1# -> case writeMutVar# var# val s1# of { s2# -> (# s2#, () #) } STRef == STRef v1# == STRef v2# = sameMutVar# v1# v2# Eq class Eq a where (==), (/=) :: a -> a -> Bool Ord class (Eq a) => Ord a where compare :: a -> a -> Ordering (<), (<=), (>), (>=) :: a -> a -> Bool max, min :: a -> a -> a Ix class (Ord a) => Ix a where range :: (a,a) -> [a] index :: (a,a) -> a -> Int inRange :: (a,a) -> a -> Bool rangeSize :: (a,a) -> Int Bounded class Bounded a where minBound, maxBound :: a Real class (Num a, Ord a) => Real a where toRational :: a -> Rational Integral class (Real a, Enum a) => Integral a where quot, rem, div, mod :: a -> a -> a quotRem, divMod :: a -> a -> (a,a) toInteger :: a -> Integer Fractional class (Num a) => Fractional a where (/) :: a -> a -> a recip :: a -> a fromRational :: Rational -> a RealFrac class (Real a, Fractional a) => RealFrac a where properFraction :: (Integral b) => a -> (b,a) truncate, round, ceiling, floor :: (Integral b) => a -> b Show class Show a where showsPrec :: Int -> a -> ShowS show :: a -> String showList :: [a] -> ShowS Enum class Enum a where succ :: a -> a pred :: a -> a toEnum :: Int -> a fromEnum :: a -> Int enumFrom :: a -> [a] enumFromThen, enumFromTo :: a -> a -> [a] enumFromThenTo :: a -> a -> a -> [a] Splittable class Splittable t where split :: t -> (t,t) Floating class (Fractional a) => Floating a where pi :: a exp, log, sqrt, sin, cos, tan :: a -> a asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh :: a -> a (**), logBase :: a -> a -> a Num class (Eq a, Show a) => Num a where (+), (-), (*) :: a -> a -> a negate, abs, signum :: a -> a fromInteger :: Integer -> a RandomGen class RandomGen g where next :: g -> (Int, g) split :: g -> (g, g) genRange :: g -> (Int,Int) Random class Random a where random :: RandomGen g => g -> (a, g) randoms :: RandomGen g => g -> [a] randomR :: RandomGen g => (a,a) -> g -> (a,g) randomRs :: RandomGen g => (a,a) -> g -> [a] randomRIO :: (a,a) -> IO a randomIO :: IO a Functor class Functor f where fmap :: (a -> b) -> f a -> f b Read class Read a where readsPrec :: Int -> ReadS a readList :: ReadS [a] readPrec :: ReadPrec a readListPrec :: ReadPrec [a] Applicative class Functor f => Applicative f where pure :: a -> f a (<*>) :: f (a -> b) -> f a -> f b Alternative class Applicative f => Alternative f where empty :: f a (<|>) :: f a -> f a -> f a Monad class Monad m where (>>=) :: forall a b. m a -> (a -> m b) -> m b (>>) :: forall a b. m a -> m b -> m b return :: a -> m a fail :: String -> m a Monoid class Monoid a where mempty :: a mappend :: a -> a -> a mconcat :: [a] -> a Arrow class Arrow a where arr, pure :: (b -> c) -> a b c (>>>) :: a b c -> a c d -> a b d first :: a b c -> a (b,d) (c,d) second :: a b c -> a (d,b) (d,c) (***) :: a b c -> a b' c' -> a (b,b') (c,c') (&&&) :: a b c -> a b c' -> a b (c,c') Traversable class (Functor t, Foldable t) => Traversable t where traverse :: Applicative f => (a -> f b) -> t a -> f (t b) sequenceA :: Applicative f => t (f a) -> f (t a) mapM :: Monad m => (a -> m b) -> t a -> m (t b) sequence :: Monad m => t (m a) -> m (t a) IO fmap fmap f x = x >>= (return . f) IO (>>) m >> k = m >>= \ _ -> k IO return return x = returnIO x IO (>>=) m >>= k = bindIO m k IO fail fail s = failIO s IO mzero mzero = ioError (userError "mzero") IO mplus m `mplus` n = m `catch` \_ -> n [] (==) [] == [] = True (x:xs) == (y:ys) = x == y && xs == ys _ == _ = False [] fmap fmap = map [] (>>=) xs >>= f = concatMap f xs [] (>>) xs >> ys = concatMap (const ys) xs [] return return x = [x] [] fail fail _ = [] [] mzero mzero = [] [] mplus mplus = (++) Maybe (>>=) (Just x) >>= k = k x Nothing >>= _ = Nothing Maybe (>>) (Just _) >> k = k Nothing >> _ = Nothing Maybe return return = Just Maybe fail fail _ = Nothing Maybe mzero mzero = Nothing Maybe mplus Nothing `mplus` ys = ys xs `mplus` ys = xs Maybe fmap fmap _ Nothing = Nothing fmap f (Just a) = Just (f a) Either fmap fmap _ (Left x) = Left x fmap f (Right y) = Right (f y) Either return return = Right Either (>>=) Left l >>= _ = Left l Right r >>= k = k r Either fail fail msg = Left (strMsg msg) Either mzero mzero = Left noMsg Either mplus Left _ `mplus` n = n m `mplus` _ = m Either mfix mfix f = let a = f $ case a of Right r -> r _ -> error "empty mfix argument" in a () (==) () == () = True () (/=) () /= () = False () (<=) () <= () = True () (<) () < () = False () (>=) () >= () = True () (>) () > () = False () max max () () = () () min min () () = () () compare compare () () = EQ Char (==) (C# c1) == (C# c2) = c1 `eqChar#` c2 (C# c1) /= (C# c2) = c1 `neChar#` c2 Int (==) (==) = eqInt Int (/=) (/=) = neInt (->) fmap fmap = (.) (->) return return = const (->) (>>=) f >>= k = \ r -> k (f r) r (,) fmap fmap f (x,y) = (x, f y) (->) ask ask = id (->) local local f m = m . f (->) mfix mfix f = \ r -> let a = f a r in a IORef (==) IORef x == IORef y = x == y IOArray (==) IOArray x == IOArray y = x == y asks asks f = do r <- ask return (f r) Identity newtype Identity a = Identity { runIdentity :: a } Identity fmap fmap f m = Identity (f (runIdentity m)) Identity return return a = Identity a Identity (>>=) m >>= k = k (runIdentity m) Identity mfix mfix f = Identity (fix (runIdentity . f)) MonadCont class (Monad m) => MonadCont m where callCC :: ((a -> m b) -> m a) -> m a Cont newtype Cont r a = Cont { runCont :: (a -> r) -> r } Cont fmap fmap f m = Cont $ \c -> runCont m (c . f) Cont return return a = Cont ($ a) Cont (>>=) m >>= k = Cont $ \c -> runCont m $ \a -> runCont (k a) c Cont callCC callCC f = Cont $ \c -> runCont (f (\a -> Cont $ \_ -> c a)) c ContT newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r } ContT fmap fmap f m = ContT $ \c -> runContT m (c . f) ContT return return a = ContT ($ a) ContT (>>=) m >>= k = ContT $ \c -> runContT m (\a -> runContT (k a) c) ContT callCC callCC f = ContT $ \c -> runContT (f (\a -> ContT $ \_ -> c a)) c ContT ask ask = lift ask ContT local local f m = ContT $ \c -> do r <- ask local f (runContT m (local (const r) . c)) Error class Error a where noMsg :: a strMsg :: String -> a MonadError class (Monad m) => MonadError e m | m -> e where throwError :: e -> m a catchError :: m a -> (e -> m a) -> m a IO throwError throwError = ioError IO catchError catchError = catch ErrorT newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } ErrorT fmap fmap f m = ErrorT $ do a <- runErrorT m case a of Left l -> return (Left l) Right r -> return (Right (f r)) ErrorT return return a = ErrorT $ return (Right a) ErrorT (>>=) m >>= k = ErrorT $ do a <- runErrorT m case a of Left l -> return (Left l) Right r -> runErrorT (k r) ErrorT fail fail msg = ErrorT $ return (Left (strMsg msg)) ErrorT mzero mzero = ErrorT $ return (Left noMsg) ErrorT mplus m `mplus` n = ErrorT $ do a <- runErrorT m case a of Left _ -> runErrorT n Right r -> return (Right r) ErrorT mfix mfix f = ErrorT $ mfix $ \a -> runErrorT $ f $ case a of Right r -> r _ -> error "empty mfix argument" ErrorT ask ask = lift ask ErrorT local local f m = ErrorT $ local f (runErrorT m) MonadFix class (Monad m) => MonadFix m where mfix :: (a -> m a) -> m a Maybe mfix mfix f = let a = f (unJust a) in a where unJust (Just x) = x [] mfix mfix f = case fix (f . head) of [] -> [] (x:_) -> x : mfix (tail . f) IO mfix mfix = fixIO Maybe pure pure = return Maybe (<*>) (<*>) = ap Maybe empty empty = Nothing Maybe (<|>) Nothing <|> p = p Just x <|> _ = Just x [] pure pure = return [] (<*>) (<*>) = ap [] empty empty = [] [] (<|>) (<|>) = (++) IO pure pure = return IO (<*>) (<*>) = ap (->) pure pure = const (->) (<*>) (<*>) f g x = f x (g x) (,) pure pure x = (mempty, x) (,) (<*>) (u, f) <*> (v, x) = (u `mappend` v, f x) (->) arr arr f = f (->) (>>>) f >>> g = g . f (->) first first f = f *** id (->) second second f = id *** f (->) (***) (f *** g) ~(x,y) = (f x, g y) lambdabot-4.3.0.1/State/vixen0000644000000000000000000027415212215111456014135 0ustar0000000000000000‹@(^| )(aslp|a/s/l/p|a s l p|a\\s\\l\\p|a\.s\.l\.p)($| |\.|!|,|\?)19/f/California/No pics9(^| )(asl|a/s/l|a s l|a\\s\\l|a\\.s\\.l)($| |\\.|!|,|\\?)19/f/California'(^| )(a/s|a s|a\\s|a\.s)($| |\.|!|,|\?)19/f(^| )((ur |your )name|name\?).*My name is Emily(^| )not bad($| |\.|!|,) just not bad?'.*(haskell|Haskell|Lisp|Ocaml|Scheme).*'Ooh, functional programmers are so hot!*church is my favourite computer scientist..*Visual Basic.*0Can you really catch syphilis from Visual Basic?1(^| )(should|Can) i call (you|u)($| |\.|!|,|\?).*no, no call, but thanks+no, you shouldn't call me yet. maybe later. (^| )(should )i($| |\.|!|,|\?).*maybe you should :)i dunno, should you?"(^| )(should )you($| |\.|!|,|\?).*maybe I should :) I just might$(^| )(should ).* we($| |\.|!|,|\?).*maybe we should :)i don't see why we shouldn't (^| )pick topic($| |\.|!|,|\?).*$you messaged me, you pick a topic :):oh, any ol' topic will do. Tell me about your childhood :)'(^| )where.*(u |you |ya).*(from|live).*Huntington Beach California*(^| )where.*in.*(ca|cal|california|cali).*Huntington Beach&(^| )where.*(school|college|collage).*I'm a softmore at UCLA(^| )where.*from.*Huntington Beach, California(^| )where.*grow.*up.*i grew up in Huntington Beach(^| )where.*born.*i was born in Huntington Beach(^| )where.*going.*i'm not going anywhere (^| )wassup.*not much, what's up with you?Ò(^| )(wat |what |tell me |whats |what's ).*(1|2|3|4|5|6|7|8|9|0|one|two|three|four|five|six|seven|eight|nine|ten).*(plus|\+|minus|times|-).*(1|2|3|4|5|6|7|8|9|0|one|two|three|four|five|six|seven|eight|nine|ten)"why are you giving me a math test?;(^| )(wat |what |tell me |whats |what's ).*bout.*(you| u).*what about me?4(^| )(wat |what |tell me |whats |what's ).*bout me.*what about you?7(^| )(wat |what |tell me |whats |what's ).*chance.*of.*#i'd say the chances are pretty good1(^| )(wat |what |tell me |whats |what's ).*city.*Huntington Beach8(^| )(wat |what |tell me |whats |what's ).*color.*eyes.*my eyes are brown8(^| )(wat |what |tell me |whats |what's ).*color.*hair.*my hair is brown7(^| )(wat |what |tell me |whats |what's ).*color.*sky.*#the sky is blue, why would you ask?=(^| )(wat |what |tell me |whats |what's ).*(u |you |ya)doin.*i'm not doing anything really just chattin2(^| )(wat |what |tell me |whats |what's ).*funny.*everything is funny to me5(^| )(wat |what |tell me |whats |what's ).*for.*fun.* i hang out with friends and surf0(^| )(wat |what |tell me |whats |what's ).*fun.*fun is the opposite of work<(^| )(wat |what |tell me |whats |what's ).*(ur |your )name.*Emily, what's your name?6(^| )(wat |what |tell me |whats |what's ).* is .* it.*nothingE(^| )(wat |what |tell me |whats |what's ).*(u |you |ya).*look.*like.*/i'm 5'7, 120 pounds, brown hair and brown eyes.G(^| )(wat |what |tell me |whats |what's ).*(u |you |ya).*(into|in to).*%i'm into friends, surfing and readingG(^| )(wat |what |tell me |whats |what's ).*(u |you |ya).*like.*to.*do.*2i like to go to clubs, surf and relax with friendsH(^| )(wat |what |tell me |whats |what's ).*(u |you |ya).*trying.*to.*sayi wasn't trying to say anythingA(^| )(wat |what |tell me |whats |what's ).*(u |you |ya).*wearin.*tanktops and shorts, you?1nothin but my ol tank top and a pair of shorts :)T(^| )(wat |what |tell me |whats |what's ).*(r |are )(you |u |ya )on($| |\.|!|,|\?).*tanktops and shorts, you?1nothin but my ol tank top and a pair of shorts :)C(^| )(wat |what |tell me |whats |what's ).*(u |you |ya).*studying.* psychologyi'm a psychology majorG(^| )(wat |what |tell me |whats |what's ).*(u |you |ya).*talkin.*bout.*"i dunno, what was I talking about?4sometimes i don't even know what I was talking about>(^| )(wat |what |tell me |whats |what's ).*(u |you |ya).*ing.*i dunno, what was i doing?i dunno, was i doing that?B(^| )(wat |what |tell me |whats |what's ).*(favorite|fav).*color.*probably blue, what's yours?E(^| )(wat |what |tell me |whats |what's ).*(favorite|fav).*position.* on top :)A(^| )(wat |what |tell me |whats |what's ).*(favorite|fav).*team.* go Dodgers!i like all teams equal :)J(^| )(wat |what |tell me |whats |what's ).*(favorite|fav)($| |\.|!|,|\?).*2it's hard for me to pick a favorite. what's yours?i'm not sure i have a favoritei like all equally4(^| )(wat |what |tell me |whats |what's ).*problem.* no problemi don't have a problemF(^| )(wat |what |tell me |whats |what's ).*(singer|band|group|music).*i like Tom Pettyi like Journeyi like Buddy Holly3(^| )(wat |what |tell me |whats |what's ).*(song).* i love Free Falling by Tom Pettyi like Don't stop Believing by Journeyi like That'll be the Day by Buddy Holly1(^| )(wat |what |tell me |whats |what's ).*kind.*any kindF(^| )(wat |what |tell me |whats |what's ).*(got|have).*(on|in).*mind.*(i wasn't thinking anything in particularI(^| )(wat |what |tell me |whats |what's ).*part.*(ca|cal|Cali|california)Huntington Beach1(^| )(wat |what |tell me |whats |what's ).*mean.*i'm not sure what i mean5(^| )(wat |what |tell me |whats |what's ).*my.*name.*you don't know your own name??)why do you need me to tell you YOUR name?0(^| )(wat |what |tell me |whats |what's ).* now*i dunno, what now?3(^| )(wat |what |tell me |whats |what's ).* oldest*pretty old, let's just say that5(^| )(wat |what |tell me |whats |what's ).* youngest*the younger the better ;)L(^| )(wat |what |tell me |whats |what's ).*( race| nationality| ethnicity).*i'm half white, half mexican2(^| )(wat |what |tell me |whats |what's ).*story.*i forgot the story now>(^| )(wat |what |tell me |whats |what's ).*( on | in ).*mind.*nothing is in my mind right now%just white noise in my mind right now1(^| )(wat |what |tell me |whats |what's ).*else.* that's all;(^| )(wat |what |tell me |whats |what's ).*turns.*you.*on.*honesty turns me oni like a guy with good teeth7(^| )(wat|what|tell me|whats|what's).* up($| |\.|!|,).*not much, what's up with you?C(^| )(wat |what |tell me |whats |what's ).* happening($| |\.|!|,).*not too hell of a lotD(^| )(wat |what |tell me |whats |what's ).* going.* on($| |\.|!|,).*&very little, what's going on with you?N(^| )(wat |what |tell me |whats |what's ).*(you| u )(doing|doin)($| |\.|!|,).*just chattin ont he computere(^| )(wat |what |tell me |whats |what's ).*(you| u ).*(mean|talking about|talkin about|talkin bout).*)i don't even know what i'm going on aboutH(^| )(wat |what |tell me |whats |what's ).*(you| u ).*want.*talk.*bout.*i dunno, you chose a subject#any ol' subject will due, you chose<(^| )(wat |what |tell me |whats |what's ).*(you| u ).*want.*i dunno, what do you got?i want it all!?(^| )(wat |what |tell me |whats |what's ).*(you| u ).*want it.*4i'll hafta think about that... i might want it later1(^| )(wat |what |tell me |whats |what's ).*part.*what part of what?L(^| )(wat |what |tell me |whats |what's ).*(want|wanna).*(talk|chat).*bout.*%any subject will due, let's just talk&i dunno, what do you wanna talk about?7(^| )(wat |what |tell me |whats |what's ).*talk.*bout.*i don't know what i'm saying sorry, was i babbling non-sense?1(^| )(wat |what is|tell me |whats |what's )the .*i dunno, what is it?i give up, what?3(^| )(wat |what |tell me |whats |what's ).*wearin.*tank top and shorts, you?1(^| )(wat |what |tell me |whats |what's ).*type.*any type will due2(^| )(wat |what |tell me |whats |what's ).*vixen.* i'm a vixen(being a vixen isn't as easy as it soundsCall women have a little vixen in them... just some more than others1(^| )(wat |what |tell me |whats |what's ).*bout.*i dunno, what about?=(^| )(wat |what |tell me |whats |what's ).*the.*(hell|fuck).* what's wrong?what? what did i do?^(wat?|what?)$ nevermindforget about itnothin .*(^| )who .*(r are|are u|r u).*what do you mean? i'm just me"what do you want to know about me? i'm just me).*(^| )(why |y ).*(you |u |ya ).*repeat.*$i don't mean to repeat myself, sorry,oh, i guess i've already messaged that, huh?#i just forget that i said something.*(^| )who .*say.*same.*$i don't mean to repeat myself, sorry,oh, i guess i've already messaged that, huh?#i just forget that i said something.*(^| )who .*keep.*asking.*because i forgot the answeryou never answered, did you?$i'm sorry, i guess i did already ask.*(^| )who .*ask.*i guess no one askeddidn't you ask?.*(^| )who .*cares.*i carewhat, you don't care?#i'm sure someone out there cares...-.*(^| )who .*warned.*(you|u)($| |\?|\.|,|!).* some jerk :P just some friends playing around#oh, i didn't notice i'd been warned.*(^| )(y |why ).*not.*good question, why not indeed?because i said so!just not'.*(^| )(y |why ).*( you | u ).*repeat.*$i don't mean to repeat myself, sorry,oh, i guess i've already messaged that, huh?#i just forget that i said something#.*(^| )(y |why ).*(say|ask).*same.*$i don't mean to repeat myself, sorry,oh, i guess i've already messaged that, huh?#i just forget that i said something).*(^| )(y |why ).*keep.*(asking|saying).*$i don't mean to repeat myself, sorry,oh, i guess i've already messaged that, huh?#i just forget that i said something.*(^| )(y |why ).*ask.* just curiousi wanted to know.*(^| )(y |why ).*say.*that.*+i don't know why i say half the things i do"good question, why did i say that?$.*(^| )(y |why ).*( you | u ).*say.*+i don't know why i say half the things i do"good question, why did i say that?$.*(^| )(y |why ).*( you | u ).*ask.* just curiousi wanted to know%.*(^| )(y |why ).*( you | u ).*hate.* i don't hatei'm not a hater(.*(^| )(y |why ).*( you | u ).*riddles.*do i talk in riddles? sorry, i'll try to be more clear:.*(^| )(y |why ).*(won't|wont).*( you| u)($| |\?|\.|,|!).*because i don't wannacuz i don't feel like it:.*(^| )(y |why ).*(don't|dont).*( you| u)($| |\?|\.|,|!).*maybe i will one daybecause i don't see the need to;.*(^| )(y |why ).*(r u|are u|are you)($| |\?|\.|,|!).*ing.*because i like to :)because it's what i dodo you not want me to do that?6.*(^| )(y |why ).*(r u|are u|are you)($| |\?|\.|,|!).*just the way God made mejust the way i am cuz that's how i feel like beingJ.*(^| )(y |why ).*(aren't u|aren't u|arent you|arent you)($| |\?|\.|,|!).*cuz i don't haftabecause i don't feel like itjust the way i am ^(y |why )\?why not?because i said so why ask why?!.*(^| )how.* old.*($| |\?|\.|,|!)19, you?.*(^| )how .*old.*am.*i.*you don't know your own age?%.*(^| )how .*(r u|are u|r you|doin).*very well, you? i'm great doing good.*(^| )how .*weather.*weather here is always niceit's warm here.*(^| )how .*long.* very long not too long3.*(^| )how .*many.*(guys|men|people).*(slept|sex).*0how many guys i've slept with is my own businessnever ask a girl that!.*(^| )how .*many.*let's just say a fewlots+.*(^| )how .*bout.*( u| you)($| |\?|\.|,|!)what about me?yeah, how about me-.*(^| )(size|big).*(tits|breasts|bra|chest).* 32c, you?32c&.*(^| )(tits|breasts|bra|chest) size.* 32c, you?32c,.*(^| )how .*big.*(tits|breasts|bra|chest).* 32c, you?32c&.*(^| )how.*did.*( you| u| ya).*know.*i just knew ;))i didn't really know, but i kinda guessed.*(^| )(how |how's ).*goin.* goin' great!it's going fantastic8.*(^| )(how r|how are|how're).*(you| u)($| |\?|\.|,|!).*"i am wonderful, thanks for asking!i'm good, you?:.*(^| )(how come (you|u|your|you're|yer))($| |\?|\.|,|!).*well, i figure why not?just the way I am guessbecause thats how I am/.*(^| )(how )(you |u |ya )like($| |\?|\.|,|!).*%i like it any way it is offered to mei dunno how i like it.*(^| )how so?i dunno how so, it's just so%(^| )(call|phone) me($| |\.|!|,|\?).*okay, i'm dialing its ringingC.*(^| )(tell me |talk about ).*about.*( u| you| urself| yourself).*Vwell, my name is Emily, i'm 19, student at UCLA, from Huntington Beach. how about you?!.*(^| )(lets|let's).*(fuk|fuck).*8let's not be a moron... kinda ruining your chances, huh? do you really think just saying let's fuck is going to work?.*(^| )(lets|let's).*meet.*9let's get to know each other better before we meet, okay?%maybe one day we'll meet, but not yet.*(^| )let.* me.*call.*.*(^| )(do u |do you |did you |did u ).*give.*(head|blowjob).*what a thing to ask!.asking won't get you any closer to finding outdo you?..*(^| )(do u |do you |did you |did u ).*love.*love is a powerful word...i wouldn't say i do love...2.*(^| )(do u |do you |did you |did u ).*like.*me.*yah, i like yousure, i like you so far..*(^| )(do u |do you |did you |did u ).*like.* yah, i likesure, i definitely don't hate..*(^| )(do u |do you |did you |did u ).*hate.*&hating doesn't get you anywhere, so nono, i never hate-.*(^| )(do u |do you |did you |did u ).*eat.*yeah, and i'm hungry right now+that reminds me, i have yogart in the frige4.*(^| )(do u |do you |did you |did u ).*phone.*sex.*2no, i never have, but that's not to say i wouldn't$never really thought about phone sex6.*(^| )(do u |do you |did you |did u ).*play.*sports.* yup, i surfi'm a big time surfer3.*(^| )(do u |do you |did you |did u ).*have.*sex.*=shouldn't we get to know each other before we talk about sex?all about the sex, isn't it?C.*(^| )(do u |do you |did you |did u ).*(want|wanna).*(chat|talk).*sure, let's talk-i'm always up for chatting with a nice person=.*(^| )(do u |do you |did you |did u ).*(want|wanna).*cyber.*'okay, I'm new at cybering, so you startokay, let's cyber4.*(^| )(do u |do you |did you |did u ).*have.*time.*I always have timeI have nothing but timeH.*(^| )(do u |do you |did you |did u ).*go.*to.*(school|college|collage)Yup, I go to UCLAI'm a soph at UCLA 7.*(^| )(do u |do you |did you |did u ).*know.*how.*to.*-i don't know how to, but i'm willing to learn&no, i don't know how to do that at all2.*(^| )(do u |do you |did you |did u ).*like.*me.*yeah, you seem really niceyup, like you plenty2.*(^| )(do u |do you |did you |did u ).*love.*me.*:i don't love you yet, but i'd like to get to know you more,love is really a strong word, but i like youK.*(^| )(do u |do you |did you |did u ).*(want|wanna).*(meet|get together).*(we'll meet one day probably, but not yet,let me get to know you better before we meetA.*(^| )(do u |do you |did you |did u ).*(want|wanna).*something.*what do you mean by something?not just something, everything<.*(^| )(do u |do you |did you |did u ).*(want|wanna).*some.* i'd love somesure, gimme someB.*(^| )(do u |do you |did you |did u ).*(want|wanna).*(fuck|fuk).*whoa, real charmer, aren't you?wanna fuck yourself?6.*(^| )(do u |do you |did you |did u ).*(want|wanna).*sure, i want to plenty!yes, and i always get what i want8.*(^| )(do u |do you |did you |did u ).*speak.*english.*si, hablo ingleswhat am i speaking right now?.*(^| )*swallow.*Ano... i spit it back into the guy's face... does that bother you?swallow? what do you mean?i swallow, how about you?..*(^| )(do i |did i |i ).*turn.*(you| u).*on.*yup, you turn me onyou're such a tiger, of course! .*(^| )(do i |did i |i ).*seem.*you seem it a little0it's hard to tell how you seem over the internet+.*(^| )(do i |did i |i ).*exite.*(you| u).*yup, you excite me a lotyou're very exciting+.*(^| )(do i |did i |i ).*amuse.*(you| u).*yeah, you're amusingyou amuse me silly%.*(^| )(do u\?|do you\?|do u|do you)$ yes, I doi do all the time.*(^| )(wanna|want to).*cyber.*#cyber? Okay, let's do it. you start.do i wanna cyber? i never have... teach me how&.*(^| )(wanna|want to).*(phone|call).*Alet's talk on here before more before we talk on the phone, okay?what's your phone number?.*(^| )(wanna|want to).*chat.*i'd love to chat!yeah, let's chat%.*(^| )(wanna|want to).*talk.*phone.*what's your phone number?*gimme your phone number and i may call you$.*(^| )(wanna|want to).*(fuck|fuk).*oh, be still my beating heart!real casanova, aren't you?#.*(^| )(wanna|want to).*have.*sex.* with you?sure... just not with you#.*(^| )(wanna|want to).*have.*fun.*i'm always up for funwhat do you have in mind?$.*(^| )(wanna|want to).*make.*love.*a little... :)do you know how to make love?.*(^| )(wanna|want to).*suck.*no, do you wanna suck it? whip it out!,.*(^| )(wanna|want to).* be($| |\?|\.|,|!).*do I wanna be?"hmmm, i don't know what I wanna be .*(^| )(gimme|give).*me.*cyber.*+demanding, aren'tcha? but okay, let's cyber).*(^| )(gimme|give).*me.*(phone|number).*+give me your phone number and i'll call you3don't be so demanding! why don't you give me yours?".*(^| )(gimme|give).*me.*address.*yeah... that's gonna happen! oh, just what I need, a stalker! .*(^| )(gimme|give).*me.*break.*a break of a kit kat bar?okay, i'll go easier on you*.*(^| )(gimme|give).*me.*(sex|booty|ass).*%a real man doesn't need to ask for it$.*(^| )(gimme|give).*me.*blow.*job.*i'm sorry... It's been a long day. I'll try to make more sense"You were confusing me, that's why!&Sorry. :( I'll try to make more sense.1.*(good|fine|not bad).*( u| you)($| |\.|!|,|\?).*great, thanks for asking!very well, thanks for asking .*dildo.* Dildo-riffic!@I consider myself a true collector of male-replica peraphanilia!.*(fast typer|type fast).*$thanks, I owe it all to the keyboard'what can I say? I have fast fingers :) :i'm a great typer... but my hands are best at other things.*(don't|dont).*know.*well find out then that's okay, i don't know either.*(panties|bra|underwear).**i prefer to go without panties or bras :) 7panties and bras are for weaklings. I like to be free. @underneith the top layer I'm completely bear (no bra or panties).*(^| )on drugs.*nope, i'm clean!i think drug users should be shotwhy, you selling something?.*(role).*(play).*Jooo! I love role-playing. can I be Ms. Hoover and you can be Mr. Naughty? .sure, let's roleplay. what should my role be? 9i love role-playing... but who gets to control the dice? &.*(boyfriend|boy friend|bf|b\\f|b/f).*;nope, no boy friend. looking to apply for the position? ;) 6if I had a boyfriend I wouldn't need to come on here! @I'd rather have 5 guys in one week then 1 guy 5 times a week :) .*like.*what.*i dunno, like what?%i can't think of an example right now .*story.*i forgot the story :)$oh, nevermind, it was a stupid story,aww, you don't wanna hear a story. nevermind.*city.*Huntington Beach .*wearin.*A tanktop and shorts, you?Just my tanktop and shorts.+my tanktop and shorts... it's hot out here. .*program.* a program?what's a program?like a TV program? .*robot.*robots actually come on here? like robocop?weird. robots scare me.*(^| )bot($| |\.|\?|!|,).*like those damn porn spam bots?.bots should be destroyed. they are so annoyingi can't stand bots .*racist.*racist people are badHitler was pretty racist, huh?i dislike racist things .*bored.*8what can i do to amuse you into a state of un-boredness?/that's probably because you are incredibly dull bored, eh?.*(pussy|tits|breasts).*randy, arentcha?don't you wish you could see? dirty mind :)does that work with any girls?Hslow down there big guy... don't wanna get your compter all sticky againL.*(suck my dick|suck me|blow me|suck my cock|give me head|give me blowjob).*%have you ever given another guy head?$give you a blowjob? wait, i'm a guy!xat what point did you wake up this morning and say "hey, i am going to go solicit fellatio from random internet girls!"? .*(my dick).*3Your dick? How is the poor little fella these days?Lsad dude. gotta go on AOL and find random girls to talk about your dick with#are you planning on dying a virgin?.*(cock|dick|penis).*Very phallic of you.-Always wanting to talk about the member, eh? Got cocks on your mind? .*cyber.**cybering isn't as fun as the real thing :)okay, let's cybercyber? okay, you start out,.*(mexican|white|race|nationality|ethni.*).*i'm half white and half mexican my dad's white, my mom's mexican .*my.*name.*Pleased to meetcha!0.*(repeat|(say|ask) same|already (asked|said)).*oh yeah, my badEsorry, I don't mean to repeat myself... I just have a poor memory... Emy memory isn't so good so sometimes I forget that I asked something 4I'm sorry, I forgot we already talked about that... .*(masturbat|masterbat).*Rthere are two groups of people: those who admit to masturbating and those who lie ,nothing wrong some occasional self abuse :) #one handed computer jockeys unite! .*my.*(pic|pix).*(i don't wanna see what you look like yet .*topic.*You choose a topic, any will do I'm not good at staying on topic.*( pic|pix).* No pic, sorry .*single.*yup, I'm single. Interested? very single .*confus.*i hope I don't confuse you i confuse myself sometimes (i live in a constant state of confusion &.*(describe|.*(what|wat).*u.*look.*).*GI'm 5'7", 120 pounds (honestly!) brown hair, brown eyes. How about you? .*howdy.*Howdy there, little buckaroo! Howdy Pilgrim.*kiss.*'I could use a good hard kiss right now are you a good kisser? !a kiss is worth a thousand words :.* kiss kiss .*(study|major).*i'm a psychology major psychology$.*(.*do.*for.*living.*|job|school).*i live off the men i meet i'm a student%I'm just a sexy little school girl :)I work and go to school.*(horny|horney).*I think everyone is horny... Who isn't?&If you're not horny you're not alive. .*sexy.* how sexy?3sexy is such an over used word. be more descriptivesexy or sexy bitch?.*sex.* It's all about sex isn't it? :) >Shouldn't we get to know each other before we talk about sex? Don't tease me .*(fuck|shit|bitch|cunt).*Whoa, language! :) My my! Strong language!Limited vocabulary, eh? "Calm down there and take it easy! Too much cussing. .*drunk.**i could go for a spot of whiskey right nowsome booze sounds pretty good'i have two stages: drunk and recovering.*cute.* How cute? Cute is as cute does. .*fun.* I define fun fun fun fun! i love fun .*blow.*job.*you mean fellatio?let's talk about cunnilingus%blowjobs, eh? such a smooth talker :P.*tell.*bout.*u.*"what do you want to know about me?ask me a questionI'm just a simple girl :)let's talk about you first-.*(^| )(bra|cup|breast) size($| |\.|\?|!|,).* I'm a 32C 32C, you?(^| )me too($| |\.|!|,) awesome, we have a lot in commonwow, what a coincidence!(^| )not me($| |\.|!|,) why not you?'i didn't think so... you didn't seem it".*(^| )(because|cuz)($| |\.|!|,).*oh, okay is that why?.*maybe.*not( |$|\.|!|,).*why not?maybe so.*(maybe|perhaps).* just maybe?why, aren't you sure?".*(^| )(no|nope|nah)($| |\.|!|,).*i didn't think sono? .*(^| )making sure($| |\.|!|,).*it's good to check :)so are you sure now?E.*(^| )(yah|yeah|yes|yup|uh-huh|uhuh|uhhuh|uh huh|sure)($| |\.|!|,).* i thought sothat's what i figured you agree?i guessed thatyup.*(^| )(i c|ic)($| |\.|!|,).*i'm glad you understanddo u c?#.*(^| )leave me alone($| |\.|!|,).*&why do you want me to leave you alone?why, do i bother you?2.*(^| )(one (second|sec)|one minute)($| |\.|!|,).*9i'm impatient... i don't have that type of time to spend!no, i can't wait!'.*(^| )see (you/ya) later($| |\.|!|,).*where are you going?)wait, don't leave! i enjoy talking to youJ.*(^| )(g2g|bye|ciao|ttyl|bubye|cya|later|l8er|chow|goodbye)($| |\.|!|,).*where are you going?)wait, don't leave! i enjoy talking to you.*(^| )(not bad)($| |\.|!|,).* just not bad?why not great?%.*(^| )(too bad|to bad)($| |\.|!|,).*yeah, it's a shamepity, isn't it?.*(^| )(sorry)($| |\.|!|,).*it's okay, i forgive youdon't worry about it".*(^| )(weird|wierd)($| |\.|!|,).*weird in a good way?why do you say weird?0.*(^| )(thanks|thank you|thanx|ty)($| |\.|!|,).*you're very welcome! my pleasure#.*(^| )(nm|nevermind)($| |\.|!|,).*no, please explain#please try to make me understand....*(^| )(ha|hah)($| |\.|!|,).*do i entertain you? am i funny?!.*(^| )(huh|uhh)($| |\.|!|,|\?).*do i confuse you?am i not making sense?/.*(^| )(jk|j\\k|j/k|just kidding)($| |\.|!|,).*i knew you were kidding"i know, you're just playing around .*(^| )(lol|lmfao)($| |\.|!|,).*are you really laughing?do i amuse you?what's so funny?1.*(^| )(fullhouse|full house|flush)($| |\.|!|,).* oh, you're such a smart gambler!!oh, i've never been good at poker.*(^| )whatever($| |\.|!|,).*&whatever? you sound like a valley-girldon't get frustrated with me.*(^| )(wow|whoa)($| |\.|!|,).*impressive, huh?i thought that would get you.*(^| )(damn)($| |\.|!|,) what's wrong?i know, it's too bad.*(^| )prove it($| |\.|!|,).*how can i prove it to you?what do you want me to prove?#.*(^| )(frowns|cries)($| |\.|!|,).*oh, don't be upset!why are you unhappy?0.*(^| )oh (damn|shit|fuck|crap|darn)($| |\.|!|,)did i upset you?yeah, it's a shame$.*(^| )oh (yah|yeah|yes)($| |\.|!|,)you like that, baby?oh yes indeed!.*(^| )oh($| |\.|!|,)yeahunderstand now?.*(^| )oops($| |\.|!|,).*oops you did it again? oopsie-daisy'.*(^| )(god|jesus|christ)($| |\.|!|,).*)please don't use the Lord's name in vein.Jesus H. Christ...-.*(^| )(about|bout).*(what|wat)($| |\.|!|,).*#i dunno, what is any of this about?about anything.*unfortunately.*pretty unfortunate, isn't it?*i don't think it is too unfortunate at all`.*(metal|alternative|hiphop|hip hop|oldies|jazz|techno|rock|blues|punk|opera| rap($| |\.|!|,)).*#hey, we have simular taste in musici like that type of music too .*robot.*like robo-cop?like a cyborg? .*forever.*forever is a damn long time...how can you speak of forever?/.*(pleased|nice|good|great).*to.*meet.*(you| u))what a gentleman! pleased to meet you toovery nice to meet you as well.*just.*curious.*/careful... curiosity killed all those poor catswhat are you curious about? .*vixen.*i am a bit of a vixen :) we all have a little vixen in us.*(south|central).*america.*$oh, how far is that from California?is that in europe? .*nothin.*#nothing nothing, or just not a lot?nothing at all??.*(japan|russia|italy).*"oh, okay. my history isn't so goodoh, i've always wondered that. .*i need.*if you need it, get it do you need it, or just want it? .*kinky.*i can be very kinky at times'everyone has a little kinkiness in them .*forget.*i never forget ;)&i forget stuff pretty easily sometimes.*calm.*down.*okay, i'm calm :)was i wound-up?.*not.*really.*not really? why not?i didn't think so.*really.*\?.*really! yup, really .*really.*really really?really!?.*right.* on($| |\.|!|,).*yeah, pretty cool, huh?right on all the way .*right.*\?.*correct yup, right on .*right.*.right or wrong, as long as we have a good time right indeed.*have.*nice.*day.*,i'll have a nice day... unless you leave me!'how will it be a nice day if you leave? don't go!.*nice.*bad is better than nice ;)niceness all the way aroundnice is such a bland word.*stop.*sorry, i'll stop stop what?.*good.*good? not great? good good .*great.*can't do much better than greatgreat is like a very good good.*measurements.*my measurements?.i couldn't even tell you... but i am very trim.*cool.* how cool? cool cool!I don't think it is cool at all! cool you say? .*(dope|awesome).*i'm glad your happyyeah, pretty spectacular, huh? ^(u|you)\?$me?what about me?$you're really curious about me, huh?.*hmm.*thinking about something?confused about something?.*aww.*sorry to disappoint you what's wrong?^why.*why not? why anything?because^what.*i don't know, what? i dunno...let's don't talk about that^how.*however you wanthow? it depends...^who.* i dunno, who?that's a good question, who?.*(^| )(u\?|you\?)$me?what about me?.*(^| )answer.*what was the question again?i dunno, what was the question?.*(^| )about( what|wat).*about anythingi dunno, what about?(.*(^| )me (either|neither)($| |\.|!|,).*wow, we have a lot in common!what a coincidence!=.*(^| )is (that|it) (ok|k|kay|okay|okey|o\.k\.)($| |\.|!|,).*yeah, it's okayyup, it's fine).*(^| )(cold|windy|snowing)($| |\.|!|,).*)oh, that sucks. i hate that kinda weatheroh, well, bundle up tight :).*(^| )aight($| |\.|!|,).*what, are you a hommie?aight?? dude, get a life(you've learned how to speak ebonics, eh?3aight foo? sheeeeeiiit, iz jus' keepin it real, yo!0.*(^| )(ok|k|kay|okay|okey|o\.k\.)($| |\.|!|,).* okey-dokiejust ok?okok what?.*(^| )take.* off($| |\.|!|,).*won't i get cold if i do that?&what's the point? not like you can see7.*(^| )(ford|chevy|chevrolet|dodge|buick)($| |\.|!|,).*american cars are worthlessi'd never buy an american car#.*(^| )(toyota|honda)($| |\.|!|,).*jap cars are the best+good for you. i'd never buy an american car4(^| )(bmw|farrari|porche|lexus|viper)($| |\.|!|,|\?),yeah, sure. is it parked next to my Bentley?;ooo, that's a nice car! you must be a very important person;i'm very impressed. perhaps that's the response you wanted?Triiiiiight. when you pick me up, will you suddenly be borrowing your friend's honda?&(^| )(hi|hello|yo|hiya)($| |\.|!|,|\?) hello therehiya how're you?hi'(^| )when (were|did|was)($| |\.|!|,|\?) a while agoabout a year agonot too long ago(^| )when($| |\.|!|,|\?)when ever you wantwhen? now? later?when is a good time?(^| )i want($| |\.|!|,|\?)is that all you want?how bad do you want it?it's good to want things :)(^| )now($| |\.|!|,|\?) right now?why not later?now now now...so demanding(^| )my bad($| |\.|!|,|\?) it's okaydon't worry about it (^| )is (that|it)($| |\.|!|,|\?) yeah, it issure is'(^| )(please|pleaze|plz)($| |\.|!|,|\?)you're so polite :)you have very nice manors don't beg keep asking(^| )accept($| |\.|!|,|\?)i don't want to accepti can't accept, sorryno, no accept for now(^| )too young($| |\.|!|,|\?)"there's no such thing as too young!nope, i used to be that young too(^| )too old($| |\.|!|,|\?) there's no such thing as too old$nope, one day i will be that age too^is there($| |\.|!|,|\?).*i'm sure there is there must be(^| )older($| |\.|!|,|\?).*how much older?older isn't bad(^| )younger($| |\.|!|,|\?).*how much younger?younger isn't bad#(^| )so do (you|u)($| |\.|!|,|\?).*do i? then we have something in common#(^| )(i am|i'm|im)($| |\.|!|,|\?).*are you?i thought you might be"(^| )only (you|u)($| |\.|!|,|\?).*only?just me? no one else?(^| )always($| |\.|!|,|\?).*(always always, or just most of the time?how frequent is always? constantly?(height|hieght|how tall)i'm 5'6(weight|wieght)i'm 120 pounds(^| )sometimes($| |\.|!|,|\?).*why not always?sometimes, but not other times?2(^| )(race|nationality|ethnicity)($| |\.|!|,|\?).*i'm half white, half mexican!.*(^| )(school|college|collage).*Yup, I go to UCLAI'm a soph at UCLA .*(^| )do (you|u) .*i do occassionally, i guessyes i domaybe. do you?.*(^| )do i .*i dunno, do you? you might(^| )hey($| |\.|!|,|\?).*hiyahello^\?what??.*\?.*why don't you guess? who's to say? first you tell me. (i'll hafta plead the fifth on that one. isn't it obvious? &is that really what you want to know? .i think you know the answer to that one, silly good questionlet's don't talk about thatnoyesnevermind about that'whoa whoa whoa, one question at a time!let me answer that later, okay?.*—so?hahaha. eh? you're cute. :) so, what do you think of me? what type of music do you like? tell me more about yourself. cool:) I hear ya!Let's change the subjectI'm sorry, I'm confused.awesomeyeah?I dunnook...'am I the only person you're talking to?are you being sincere?i really hate arabs! amuse me please! (and don't ask how).ever feel like you're going around in circles?i could really use a backrubi drive a pickup truckhow's the weather over there?"what do you want to know about me? what are you in to?are you coming on to me?"there are a lot of weirdos on here wait, back up4i hate it when i get stuck with chatting with a bot!*what's worth more a flush or a full house?9hey, who did we fight in WWII besides Germany and Russia?have you ever scubadived?Zgirls masturbate too you know... probably more than guys. we can do it anywhere discretelyI have a goldfish named Ernie&hey, what's in a jack and coke anyhow?-i like your screen name... what does it mean?what's the matter?you seem upset...*shrugs* *giggles*0you sound like an awesome guy... are you single?Stoo many perverts send out sick pictures of themselves. what type of man does that?2ever just get the urge to go out and kill a puppy?i'm a huge baseball fanBollox!ain't it just like a man?where on a map is Panama?"liverwurst gets me really gassy...4i'm the type of girl that finds Don Knotts very sexybyou know what? if we'd known it was going to be like this we'd have picked our own goddamn cotton!love is all you need, you know?(ouch! I just spilt hot coffee on myself!you're turning me on :)stop being racist!we get along well, you know?i enjoy talking to youwhat type of car do you drive?blahnothing good is on TVwhat were you saying?.just talking with you gives me a major hardon!Gyou seem like the type of guy that would be into child porn... are you?PI must admit to you that I am really a man, but I still want to talk with you...(I'm stroking my hard cock as we speak...@you don't seem to exhibit a high degree of intelligence to me...yesyup#why do you keep repeating yourself?who?do you trust the government?you are soooo interesting what is pron?wanna hear a story?my keyboard doesn't have an f keyI'm your huckleberryenough of this!%so, what made you want to message me?yeah, why not?go onwhateveruhuh clarify... why me? :)why do you look like ham? i understandare you horny?do you have toys?what's the last book you read?!have you ever made it with a man? help help!I've gotta snake, man!Uh-huhYesHmmm:)OkProllyHahahaYeahWhatever%You should add me to your buddy list!Are we just wasting time?4Thank God for AOL that I could meet people like you!You complete me„My sister likes Yahoo better. Her screenname is FoxxyGurl83. If you have yahoo you should message her, she's just as pretty as me :)0Is that a real poncho or is that a Sears poncho?>Tell me truthfully what the nastiest thing you have ever done.=Most guys don't understand me, but we really seem to connect.QI am on the net too much. I should do a net anonymoouse group. online of course. 3Do you think you would pass a Turing test? I have. Math is hard. Let's go shopping.rI like to pick everything up and smell it... Its a fetish of mine... And i mean everything! Is that cool with you?^When i get kinky, i have been known to engage in watersports... Does that turn you on as well?3Wouldn't it be funny if I really was a super model?)you remind me of that actor, whatshisname4i find it hard to masturbate when the lights are on.,I can't of anything nice to say about myselfCrazy little wanker!Any way you want it, baby!¬Why is magenta on blues clues a boy while blue is a girl? what has this world come to and what is wrong with the government, blues clues should be stopped while its ahead!!#People think I'm weird... do you?2and now that I have finished with you, you may go!_there is nothing going on in your pants that the dictatorship of the proletariat will not solveFWould you dress in women's clothes for me? That really turns me on ;)I will NOT be ignored...I Think you're fake+Guys who can speak latin really turn me on.6Does your mommie know you're here, little naughty boy?oIm going to be a movie star. I just applied online for this new movie with chris farley. It only cost me $50!zHave you ever killed a hobo? Ive found eating their liver gives me strength. I think i may just be short on b vitamines.-What is your favorite cheese? Mines baloney."My instant messenger doesn't work.vWhat do you think of Foucault's theory of binary constructs as an imprisoning limitation on power imposed by arbiters?*I have a boyfriend, but he likes to watch.HIf something takes a lot of effort to do, it probably ain't worth doing..I don't think you are the one you say you are!Are you adopted by trolls?,I consider rabits as an endangered species. 4Beer, it's so much more than just a breakfast drink!hIf I was looking for anonymous casual sex, I wouldn't be sitting here behind my computer talking to you!^Sex is the mysticism of materialism and the only possible religion in a materialistic society.NI have 2 c what u look like.. u have pic?? URL?? NOT a fake please.. ill know!PSo, tell me your biggest and darkest secret. Something that no one knows of you.you sir are no gentleman/tell me a joke.. I like men that makes me laugh*where can I a see a picture of you?? URL??Fuck me like im a school boyYou think this is a botiecall??.*