lambdabot-utils (empty) → 4.1
raw patch · 15 files changed
+2128/−0 lines, 15 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, containers, haskell-src, mtl, network, old-time, process, random, regex-compat, regex-posix, tagsoup, unix, utf8-string, zlib
Files
- LICENSE +22/−0
- Lambdabot/AltTime.hs +95/−0
- Lambdabot/Error.hs +80/−0
- Lambdabot/FixPrecedence.hs +343/−0
- Lambdabot/MiniHTTP.hs +110/−0
- Lambdabot/Parser.hs +87/−0
- Lambdabot/Pointful.hs +173/−0
- Lambdabot/Process.hs +79/−0
- Lambdabot/Regex.hs +64/−0
- Lambdabot/Serial.hs +179/−0
- Lambdabot/Signals.hs +132/−0
- Lambdabot/Url.hs +168/−0
- Lambdabot/Util.hs +559/−0
- Setup.hs +3/−0
- lambdabot-utils.cabal +34/−0
+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (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/AltTime.hs view
@@ -0,0 +1,95 @@+-- | Time compatibility layer+module Lambdabot.AltTime (+ ClockTime,+ getClockTime, diffClockTimes, addToClockTime, timeDiffPretty,+ module System.Time+ ) where++import Control.Arrow (first)++import Data.Binary++import Data.List+import System.Time (TimeDiff(..), noTimeDiff)+import qualified System.Time as T++-- | Wrapping ClockTime (which doesn't provide a Read instance!) seems+-- easier than talking care of the serialization of UserStatus+-- ourselves.+--+newtype ClockTime = ClockTime (T.ClockTime)++instance Eq ClockTime where+ ClockTime (T.TOD x1 y1) == ClockTime (T.TOD x2 y2) =+ x1 == x2 && y1 == y2++instance Show ClockTime where+ showsPrec p (ClockTime (T.TOD x y)) = showsPrec p (x,y)++instance Read ClockTime where+ readsPrec p = map (first $ ClockTime . uncurry T.TOD) . readsPrec p++-- | Retrieve the current clocktime+getClockTime :: IO ClockTime+getClockTime = ClockTime `fmap` T.getClockTime++-- | Difference of two clock times+diffClockTimes :: ClockTime -> ClockTime -> TimeDiff+diffClockTimes (ClockTime ct1) (ClockTime ct2) =+-- This is an ugly hack (we don't care about picoseconds...) to avoid the+-- "Time.toClockTime: picoseconds out of range"+-- error. I think time arithmetic is broken in GHC.+ (T.diffClockTimes ct1 ct2) { tdPicosec = 0 }++-- | @'addToClockTime' d t@ adds a time difference @d@ and a -- clock+-- time @t@ to yield a new clock time.+addToClockTime :: TimeDiff -> ClockTime -> ClockTime+addToClockTime td (ClockTime ct) = ClockTime $ T.addToClockTime 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 years "y",+ prettyP (months `mod` 12) "m",+ prettyP (days `mod` 28) "d",+ prettyP (hours `mod` 24) "h",+ prettyP (mins `mod` 60) "m",+ prettyP (secs `mod` 60) "s"]+ where+ prettyP 0 _ = []+ prettyP i s = show i ++ s++ secs = abs $ tdSec td -- This is a hack, but there wasn't an sane output+ -- for negative TimeDiffs anyway.+ mins = secs `div` 60+ hours = mins `div` 60+ days = hours `div` 24+ months = days `div` 28+ years = months `div` 12++------------------------------------------------------------------------++instance Binary ClockTime where+ put (ClockTime (T.TOD i j)) = put i >> put j+ get = do i <- get+ j <- get+ return (ClockTime (T.TOD i j))++instance Binary TimeDiff where+ put (TimeDiff ye mo da ho mi se ps) = do+ put ye; put mo; put da; put ho; put mi; put se; put ps+ get = do+ ye <- get+ mo <- get+ da <- get+ ho <- get+ mi <- get+ se <- get+ ps <- get+ return (TimeDiff ye mo da ho mi se ps)++
+ Lambdabot/Error.hs view
@@ -0,0 +1,80 @@+-- | Error utilities+module Lambdabot.Error where++import Control.Monad (liftM)+import Control.Monad.Error (MonadError (..))++-- | 'catchErrorJust' is an error catcher for the Maybe type. As input is given+-- a deciding function, a monad and a handler. When an error is caught, the+-- decider is executed to decide if the error should be handled or not.+-- Then the handler is eventually called to handle the error.+catchErrorJust :: MonadError e m => (e -> Maybe b) -- ^ Decider function+ -> m a -- ^ Monad+ -> (b -> m a) -- ^ Handler function+ -> m a -- ^ Result: A monadic operation on type a+catchErrorJust decide m handler+ = catchError m (\e -> case decide e of+ Just b -> handler b+ Nothing -> throwError e)++-- | 'handleError' is the flipped version of 'catchError'.+handleError :: MonadError e m => (e -> m a) -- ^ Error handler+ -> m a -- ^ Monad+ -> m a -- ^ Resulting monad+handleError = flip catchError++-- | 'handleErrorJust' is the flipped version of 'catchErrorJust'.+handleErrorJust :: MonadError e m => (e -> Maybe b) -- ^ Decider+ -> (b -> m a) -- ^ Handler+ -> m a -- ^ Monad+ -> m a -- ^ Resulting Monad+handleErrorJust = flip . catchErrorJust++-- | 'tryError' uses Either to explicitly define the outcome of a+-- monadic operation. An error is caught and placed into Right,+-- whereas successful operation is placed into Left.+tryError :: MonadError e m => m a -- ^ Monad to operate on+ -> m (Either e a) -- ^ Returns: Explicit Either type+tryError m = catchError (liftM Right m) (return . Left)++-- | 'tryErrorJust' is the 'catchErrorJust' version of 'tryError'+-- given is a decider guarding whether or not the error should be+-- handled. The handler will always Right and no errors are Left'ed+-- through. If the decider returns Nothing, the error will be thrown+-- further up.+tryErrorJust :: MonadError e m => (e -> Maybe b) -- ^ Decider+ -> m a -- ^ Monad+ -> m (Either b a) -- ^ Returns: Explicit Either type+tryErrorJust decide m = catchErrorJust decide (liftM Right m) (return . Left)++-- | 'finallyError' is a monadic version of the classic UNWIND-PROTECT of+-- lisp fame. Given parameters m and after (both monads) we proceed to+-- work on m. If an error is caught, we execute the out-guard, after,+-- before rethrowing the error. If m does not fail, after is executed+-- and the value of m is returned.+finallyError :: MonadError e m => m a -- ^ Monadic operation+ -> m b -- ^ Guard+ -> m a -- ^ Returns: A new monad.+finallyError m after = do a <- catchError m (\e -> after >> throwError e)+ after+ return a++-- | 'bracketError' is the monadic version of DYNAMIC-WIND from Scheme+-- fame. Parameters are: before, after and m. before is the in-guard+-- being executed before m. after is the out-guard and protects fails+-- of the m.+-- In the Haskell world, this scheme is called a bracket and is often+-- seen employed to manage resources.+bracketError :: MonadError e m => m a -- ^ Before (in-guard) monad+ -> (a -> m b) -- ^ After (out-guard) operation. Fed output of before+ -> (a -> m c) -- ^ Monad to work on. Fed with output of before+ -> m c -- ^ Resulting monad.+bracketError before after m = do v <- before; finallyError (m v) (after v)++-- | 'bracketError_' is the non-bound version of 'bracketError'. The+-- naming scheme follows usual Haskell convention.+bracketError_ :: MonadError e m => m a -- ^ Before (in-guard)+ -> m b -- ^ After (out-guard)+ -> m c -- ^ Monad to work on+ -> m c -- ^ Resulting monad+bracketError_ before after m = bracketError before (\_ -> after) (\_ -> m)
+ Lambdabot/FixPrecedence.hs view
@@ -0,0 +1,343 @@+module Lambdabot.FixPrecedence (withPrecExp, withPrecDecl, precTable, FixPrecedence(..) ) where++import qualified Data.Map as M+import Language.Haskell.Syntax+import Data.List++{-+ PrecedenceData++ This is a data type to hold precedence information. It simply records,+ for each operator, its precedence level (a number), and associativity+ (one of HsAssocNone, HsAssocLeft, or HsAssocRight).+-}+type PrecedenceData = M.Map HsQName (HsAssoc, Int)++{-+ findPrec++ Looks up precedence information for a goven operator. If the operator+ is not in the precedence data, the Haskell report specifies that it+ should be treated as infixl 9.+-}+findPrec :: PrecedenceData -> HsQName -> (HsAssoc, Int)+findPrec = flip (M.findWithDefault defaultPrec)+ where defaultPrec = (HsAssocLeft, 9)++{-+ precWrong++ This returns True iff the first operator should be a parent of the+ second in the expression tree, when they occur consecutively left to+ right in the input. This is called "wrong" because the parser in+ Language.Haskell.Parser treats everything as left associative at the+ same precedence, so the right-most operator will be the parent in the+ expression tree in the original input.++ XXX: Currently, this function treats operators with no associativity+ as if they were left associative. It also looks only at the+ associativity of the left-most operator. This should work for+ correct code, but it does not report errors for incorrect code.+-}+precWrong :: PrecedenceData -> HsQName -> HsQName -> Bool+precWrong pd a b = let (assoc, prec) = findPrec pd a+ (_, prec') = findPrec pd b+ in (prec < prec')+ || (prec == prec' && assoc == HsAssocRight)++{-+ nameFromQOp++ Extracts the HsQName from an HsQOp.+-}+nameFromQOp :: HsQOp -> HsQName+nameFromQOp (HsQVarOp s) = s+nameFromQOp (HsQConOp s) = s++nameFromOp :: HsOp -> HsQName+nameFromOp (HsVarOp n) = UnQual n+nameFromOp (HsConOp n) = UnQual n++{-+ withPrecExp++ This routine fixes up an expression by applying precedence data.+-}+withPrecExp :: PrecedenceData -> HsExp -> HsExp++{-+ This is the heart of the whole thing. It applies an algorithm+ described by LaLonde and Rivieres in ACM Transactions on Programming+ Languages and Systems, January 1981. The idea is to take a parse+ tree with a consistent left-associative organization, and rearrange it+ to match a precedence table.++ A few changes have been made. LaLonde and Rivieres remove parentheses+ from their parse tree, which isn't necessary here; and they work with+ an inherently right-associative grammar, while Language.Haskell.Parser+ produces a left-associative grammar.+-}+withPrecExp pd (HsInfixApp k@(HsInfixApp e qop' f) qop g) =+ let g' = withPrecExp pd g+ op = nameFromQOp qop+ op' = nameFromQOp qop'+ in if precWrong pd op' op+ then let e' = withPrecExp pd e+ f' = withPrecExp pd f+ in withPrecExp pd (HsInfixApp e' qop' (HsInfixApp f' qop g'))+ else HsInfixApp (withPrecExp pd k) qop g'++withPrecExp pd (HsInfixApp e op f) =+ HsInfixApp (withPrecExp pd e) op (withPrecExp pd f)++{-+ The remaining cases simply propogate the correction throughout other+ elements of the grammar.+-}+withPrecExp _ (HsVar v) = HsVar v+withPrecExp _ (HsCon c) = HsCon c+withPrecExp _ (HsLit l) = HsLit l+withPrecExp pd (HsApp e f) =+ HsApp (withPrecExp pd e) (withPrecExp pd f)+withPrecExp pd (HsNegApp e) =+ HsNegApp (withPrecExp pd e)+withPrecExp pd (HsLambda loc pats e) =+ let pats' = map (withPrecPat pd) pats+ in HsLambda loc pats' (withPrecExp pd e)+withPrecExp pd (HsLet decls e) =+ let (pd', decls') = mapAccumL withPrecDecl pd decls+ in HsLet decls' (withPrecExp pd' e)+withPrecExp pd (HsIf e f g) =+ HsIf (withPrecExp pd e) (withPrecExp pd f) (withPrecExp pd g)+withPrecExp pd (HsCase e alts) =+ let alts' = map (withPrecAlt pd) alts+ in HsCase (withPrecExp pd e) alts'+withPrecExp pd (HsDo stmts) =+ let (_, stmts') = mapAccumL withPrecStmt pd stmts+ in HsDo stmts'+withPrecExp pd (HsTuple exps) =+ let exps' = map (withPrecExp pd) exps+ in HsTuple exps'+withPrecExp pd (HsList exps) =+ let exps' = map (withPrecExp pd) exps+ in HsList exps'+withPrecExp pd (HsParen e) =+ HsParen (withPrecExp pd e)+withPrecExp pd (HsLeftSection e op) =+ HsLeftSection (withPrecExp pd e) op+withPrecExp pd (HsRightSection op e) =+ HsRightSection op (withPrecExp pd e)+withPrecExp pd (HsRecConstr n upd) =+ let upd' = map (withPrecUpd pd) upd+ in HsRecConstr n upd'+withPrecExp pd (HsRecUpdate e upd) =+ let upd' = map (withPrecUpd pd) upd+ in HsRecUpdate (withPrecExp pd e) upd'+withPrecExp pd (HsEnumFrom e) =+ HsEnumFrom (withPrecExp pd e)+withPrecExp pd (HsEnumFromThen e f) =+ HsEnumFromThen (withPrecExp pd e) (withPrecExp pd f)+withPrecExp pd (HsEnumFromTo e f) =+ HsEnumFromTo (withPrecExp pd e) (withPrecExp pd f)+withPrecExp pd (HsEnumFromThenTo e f g) =+ HsEnumFromThenTo (withPrecExp pd e) (withPrecExp pd f) (withPrecExp pd g)+withPrecExp pd (HsListComp e stmts) =+ let (_, stmts') = mapAccumL withPrecStmt pd stmts+ in HsListComp (withPrecExp pd e) stmts'+withPrecExp pd (HsExpTypeSig l e t) =+ HsExpTypeSig l (withPrecExp pd e) t+withPrecExp pd (HsAsPat n e) =+ HsAsPat n (withPrecExp pd e)+withPrecExp _ (HsWildCard) =+ HsWildCard+withPrecExp pd (HsIrrPat e) =+ HsIrrPat (withPrecExp pd e)++{-+ This function is analogous to withPrec, but operates on patterns instead+ of expressions.+-}+withPrecPat :: PrecedenceData -> HsPat -> HsPat++{-+ This is the same algorithm based on Lalonde and Rivieres, but designed+ to work with infix data constructors in pattern matching.+-}+withPrecPat pd (HsPInfixApp k@(HsPInfixApp e op' f) op g) =+ let g' = withPrecPat pd g+ in if precWrong pd op' op+ then let e' = withPrecPat pd e+ f' = withPrecPat pd f+ in withPrecPat pd (HsPInfixApp e' op' (HsPInfixApp f' op g'))+ else HsPInfixApp (withPrecPat pd k) op g'++withPrecPat pd (HsPInfixApp e op f) =+ HsPInfixApp (withPrecPat pd e) op (withPrecPat pd f)++withPrecPat _ (HsPVar n) = HsPVar n+withPrecPat _ (HsPLit l) = HsPLit l+withPrecPat pd (HsPNeg p) = HsPNeg (withPrecPat pd p)+withPrecPat pd (HsPApp n ps) = let ps' = map (withPrecPat pd) ps+ in HsPApp n ps'+withPrecPat pd (HsPTuple ps) = let ps' = map (withPrecPat pd) ps+ in HsPTuple ps'+withPrecPat pd (HsPList ps) = let ps' = map (withPrecPat pd) ps+ in HsPList ps'+withPrecPat pd (HsPParen p) = HsPParen (withPrecPat pd p)+withPrecPat pd (HsPRec n pfs) = let pfs' = map (withPrecPatField pd) pfs+ in HsPRec n pfs'+withPrecPat pd (HsPAsPat n p) = HsPAsPat n (withPrecPat pd p)+withPrecPat _ (HsPWildCard) = HsPWildCard+withPrecPat pd (HsPIrrPat p) = HsPIrrPat (withPrecPat pd p)++{-+ Propogates precedence fixing through a pattern "field"+-}+withPrecPatField :: PrecedenceData -> HsPatField -> HsPatField+withPrecPatField pd (HsPFieldPat n p) = HsPFieldPat n (withPrecPat pd p)++{-+ Propogates precedence fixing through declaration sections. This+ gets interesting, because declarations can actually change the+ existing precedence, so withPrecDecl returns both the transformed+ tree and an augmented precedence relation.+-}+withPrecDecl :: PrecedenceData -> HsDecl -> (PrecedenceData, HsDecl)+withPrecDecl pd d@(HsInfixDecl _ assoc p ops) =+ let nms = map nameFromOp ops+ prec = (assoc, p)+ pd' = M.union pd $ M.fromList $ map (flip (,) prec) nms+ in (pd', d)+withPrecDecl pd (HsClassDecl l ctx n ns decls) =+ let (pd', decls') = mapAccumL withPrecDecl pd decls+ in (pd', HsClassDecl l ctx n ns decls')+withPrecDecl pd (HsInstDecl l ctx n ts decls) =+ -- The question of what to do with fixity declarations here is+ -- interesting. The report says they aren't allowed (4.3.2), but+ -- GHC accepts them as of version 6.6 and apparently ignores them.+ -- The best thing is probably to match GHC's behavior.+ let decls' = map snd $ map (withPrecDecl pd) decls+ in (pd, HsInstDecl l ctx n ts decls')+withPrecDecl pd (HsFunBind ms) =+ let ms' = map (withPrecMatch pd) ms+ in (pd, HsFunBind ms')+withPrecDecl pd (HsPatBind l p rhs decls) =+ let p' = withPrecPat pd p+ (pd',decls') = mapAccumL withPrecDecl pd decls+ rhs' = withPrecRhs pd' rhs+ in (pd, HsPatBind l p' rhs' decls')+withPrecDecl pd d = (pd, d)++{-+ Propogates precedence fixing through HsMatch+-}+withPrecMatch :: PrecedenceData -> HsMatch -> HsMatch+withPrecMatch pd (HsMatch l n ps rhs decls) =+ let ps' = map (withPrecPat pd) ps+ (pd', decls') = mapAccumL withPrecDecl pd decls+ rhs' = withPrecRhs pd' rhs+ in HsMatch l n ps' rhs' decls'++{-+ Propogates precedence fixing through HsRhs+-}+withPrecRhs :: PrecedenceData -> HsRhs -> HsRhs+withPrecRhs pd (HsUnGuardedRhs e) = HsUnGuardedRhs (withPrecExp pd e)+withPrecRhs pd (HsGuardedRhss grs) = let grs' = map (withPrecGRhs pd) grs+ in HsGuardedRhss grs'++withPrecGRhs :: PrecedenceData -> HsGuardedRhs -> HsGuardedRhs+withPrecGRhs pd (HsGuardedRhs l e f) =+ HsGuardedRhs l (withPrecExp pd e) (withPrecExp pd f)++{-+ Propogates precedence fixing through case statement alternatives.+-}+withPrecAlt :: PrecedenceData -> HsAlt -> HsAlt+withPrecAlt pd (HsAlt l p alts ds) =+ let (pd', ds') = mapAccumL withPrecDecl pd ds+ in HsAlt l (withPrecPat pd p) (withPrecGAlts pd' alts) ds'++withPrecGAlts :: PrecedenceData -> HsGuardedAlts -> HsGuardedAlts+withPrecGAlts pd (HsUnGuardedAlt e) = HsUnGuardedAlt (withPrecExp pd e)+withPrecGAlts pd (HsGuardedAlts alts) = let alts' = map (withPrecGAlt pd) alts+ in HsGuardedAlts alts'++withPrecGAlt :: PrecedenceData -> HsGuardedAlt -> HsGuardedAlt+withPrecGAlt pd (HsGuardedAlt l e f) =+ HsGuardedAlt l (withPrecExp pd e) (withPrecExp pd f)++{-+ Propogates precedence fixing through do blocks. Because let statements+ can change precedence, the result is both the transformed tree and an+ augmented precedence relation, much like in withPrecDecl.+-}+withPrecStmt :: PrecedenceData -> HsStmt -> (PrecedenceData, HsStmt)+withPrecStmt pd (HsGenerator l p e) =+ (pd, HsGenerator l (withPrecPat pd p) (withPrecExp pd e))+withPrecStmt pd (HsQualifier e) = (pd, HsQualifier (withPrecExp pd e))+withPrecStmt pd (HsLetStmt ds) = let (pd', ds') = mapAccumL withPrecDecl pd ds+ in (pd', HsLetStmt ds')++{-+ Propogates precedence fixing through record field updates.+-}+withPrecUpd :: PrecedenceData -> HsFieldUpdate -> HsFieldUpdate+withPrecUpd pd (HsFieldUpdate n e) = HsFieldUpdate n (withPrecExp pd e)++{-+ This is the default precedence table used for parsing expressions.+ It is taken from the precedences of the main operators in the Haskell+ Prelude.++ XXX: It might be a good idea to search the standard library docs for+ other operators. These are the ones listed in the Haskell Report+ section 4. For example, one that is not included here is+ Data.Ratio.%+-}+precTable :: PrecedenceData+precTable = M.fromList+ [+ (UnQual (HsSymbol "!!"), (HsAssocLeft, 9)),+ (UnQual (HsSymbol "."), (HsAssocRight, 9)),+ (UnQual (HsSymbol "^"), (HsAssocRight, 8)),+ (UnQual (HsSymbol "^^"), (HsAssocRight, 8)),+ (UnQual (HsSymbol "**"), (HsAssocLeft, 8)),+ (UnQual (HsSymbol "*"), (HsAssocLeft, 7)),+ (UnQual (HsSymbol "/"), (HsAssocLeft, 7)),+ (UnQual (HsIdent "div"), (HsAssocLeft, 7)),+ (UnQual (HsIdent "mod"), (HsAssocLeft, 7)),+ (UnQual (HsIdent "rem"), (HsAssocLeft, 7)),+ (UnQual (HsIdent "quot"), (HsAssocLeft, 7)),+ (UnQual (HsSymbol "+"), (HsAssocLeft, 6)),+ (UnQual (HsSymbol "-"), (HsAssocLeft, 6)),+ (UnQual (HsSymbol ":"), (HsAssocRight, 5)),+ (Special HsCons, (HsAssocRight, 5)),+ (UnQual (HsSymbol "++"), (HsAssocRight, 5)),+ (UnQual (HsSymbol "=="), (HsAssocNone, 4)),+ (UnQual (HsSymbol "/="), (HsAssocNone, 4)),+ (UnQual (HsSymbol "<"), (HsAssocNone, 4)),+ (UnQual (HsSymbol "<="), (HsAssocNone, 4)),+ (UnQual (HsSymbol ">"), (HsAssocNone, 4)),+ (UnQual (HsSymbol ">="), (HsAssocNone, 4)),+ (UnQual (HsIdent "elem"), (HsAssocNone, 4)),+ (UnQual (HsIdent "notElem"), (HsAssocNone, 4)),+ (UnQual (HsSymbol "&&"), (HsAssocRight, 3)),+ (UnQual (HsSymbol "||"), (HsAssocRight, 2)),+ (UnQual (HsSymbol ">>"), (HsAssocLeft, 1)),+ (UnQual (HsSymbol ">>="), (HsAssocLeft, 1)),+ (UnQual (HsSymbol "$"), (HsAssocRight, 0)),+ (UnQual (HsSymbol "$!"), (HsAssocRight, 0)),+ (UnQual (HsIdent "seq"), (HsAssocRight, 0))+ ]+++class FixPrecedence a where+ fixPrecedence :: a -> a++instance FixPrecedence HsExp where+ fixPrecedence = withPrecExp precTable++instance FixPrecedence HsDecl where+ fixPrecedence = snd . withPrecDecl precTable+
+ Lambdabot/MiniHTTP.hs view
@@ -0,0 +1,110 @@+-- | HTTP protocol binding.+-- <http://homepages.paradise.net.nz/warrickg/haskell/http/>+-- <http://www.dtek.chalmers.se/~d00bring/haskell-xml-rpc/http.html>++module Lambdabot.MiniHTTP (+ Proxy,+ mkPost,+ readPage,+ readNBytes,+ urlEncode,+ urlDecode,+ module Network.URI+ ) where++import Control.Monad (liftM2)+import Data.Bits ((.&.))+import Data.Char (ord, chr, digitToInt, intToDigit)+import Data.Maybe (fromMaybe)+import Network+import Network.URI hiding (authority)+import System.IO++authority :: URI -> String+authority = uriRegName . maybe (error "authority") id . uriAuthority++type Proxy = Maybe (String, Integer)++-- HTTP specific stuff+mkPost :: URI -> String -> [String]+mkPost uri body = ["POST " ++ url ++ " HTTP/1.0",+ "Host: " ++ host,+ "Accept: */*",+ "Content-Type: application/x-www-form-urlencoded",+ "Content-Length: " ++ (show $ length body),+ ""]+ where+ url = show uri+ host = authority uri++hGetLines :: Handle -> IO [String]+hGetLines h = do+ eof <- hIsEOF h+ if eof then return []+ else+ liftM2 (:) (hGetLine h) (hGetLines h)++readPage :: Proxy -> URI -> [String] -> String -> IO [String]+readPage proxy uri headers body = withSocketsDo $ do+ h <- connectTo host (PortNumber (fromInteger port))+ mapM_ (\s -> hPutStr h (s ++ "\r\n")) headers+ hPutStr h body+ hFlush h+ contents <- hGetLines h+ hClose h+ return contents+ where+ (host, port) = fromMaybe (authority uri, 80) proxy++--+-- read lines, up to limit of n bytes. Useful to ensure people don't+-- abuse the url plugin+--+readNBytes :: Int -> Proxy -> URI -> [String] -> String -> IO [String]+readNBytes n proxy uri headers body = withSocketsDo $ do+ h <- connectTo host (PortNumber (fromInteger port))+ mapM_ (\s -> hPutStr h (s ++ "\r\n")) headers+ hPutStr h body+ hFlush h+ contents <- lines `fmap` hGetN n h+ hClose h+ return contents+ where+ (host, port) = fromMaybe (authority uri, 80) proxy++ hGetN :: Int -> Handle -> IO String+ hGetN i h | i `seq` h `seq` False = undefined -- strictify+ hGetN 0 _ = return []+ hGetN i h = do eof <- hIsEOF h+ if eof then return []+ else liftM2 (:) (hGetChar h) (hGetN (i-1) h)++-- from HTTP.hs+urlEncode, urlDecode :: String -> String++urlDecode ('%':a:b:rest) = chr (16 * digitToInt a + digitToInt b)+ : urlDecode rest+urlDecode (h:t) = h : urlDecode t+urlDecode [] = []++urlEncode (h:t) =+ let str = if isReservedChar(ord h) then escape h else [h]+ in str ++ urlEncode t+ where+ isReservedChar x+ | x >= ord 'a' && x <= ord 'z' = False+ | x >= ord 'A' && x <= ord 'Z' = False+ | x >= ord '0' && x <= ord '9' = False+ | x <= 0x20 || x >= 0x7F = True+ | otherwise = x `elem` map ord [';','/','?',':','@','&'+ ,'=','+',',','$','{','}'+ ,'|','\\','^','[',']','`'+ ,'<','>','#','%','"']+ -- wouldn't it be nice if the compiler+ -- optimised the above for us?++ escape x =+ let y = ord x+ in [ '%', intToDigit ((y `div` 16) .&. 0xf), intToDigit (y .&. 0xf) ]++urlEncode [] = []
+ Lambdabot/Parser.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE Rank2Types #-}++-- Haskell expression parser. Big hack, but only uses documented APIs so it+-- should be more robust than the previous hack.+module Lambdabot.Parser (parseExpr, parseDecl, withParsed, prettyPrintInLine) where++import Control.Monad.Error () -- Monad Either instance+import Data.Char+import Data.Generics+import Language.Haskell.Parser+import Language.Haskell.Pretty+import Language.Haskell.Syntax++import Lambdabot.FixPrecedence++parseExpr :: String -> Either String HsExp+parseExpr s+ | not (balanced 0 ' ' s) = Left "Unbalanced parentheses"+ | otherwise = case parseModule wrapped of+ ParseOk (HsModule _ _ _ _ [HsPatBind _ _ (HsUnGuardedRhs e) _])+ -> Right $ fixPrecedence $ unparen e+ ParseFailed (SrcLoc _ _ col) msg+ -> Left $ showParseError msg (col - length prefix) s+ where+ prefix = "module Main where { main = ("+ wrapped = prefix ++ s ++ "\n)}"++ unparen (HsParen e) = e+ unparen e = e++ -- balanced (open-parentheses) (previous-character) (remaining-string)+ balanced :: Int -> Char -> String -> Bool+ balanced n _ "" = n == 0+ balanced n _ ('(':cs) = balanced (n+1) '(' cs+ balanced n _ (')':cs) = n > 0 && balanced (n-1) ')' cs+ balanced n p (c :cs)+ | c `elem` "\"'" && (not (isAlphaNum p) || c /= '\'')+ = balancedString c n cs+ balanced n p ('-':'-':_)+ | not (isSymbol p) = n == 0+ balanced n _ ('{':'-':cs) = balancedComment 1 n cs+ balanced n _ (c :cs) = balanced n c cs++ balancedString :: Char -> Int -> String -> Bool+ balancedString _ n "" = n == 0 -- the parse error will be reported by L.H.Parser+ balancedString delim n ('\\':c:cs)+ | isSpace c = case dropWhile isSpace cs of+ '\\':cs' -> balancedString delim n cs'+ cs' -> balancedString delim n cs'+ | otherwise = balancedString delim n cs+ balancedString delim n (c :cs)+ | delim == c = balanced n c cs+ | otherwise = balancedString delim n cs++ balancedComment :: Int -> Int -> String -> Bool+ balancedComment 0 n cs = balanced n ' ' cs+ balancedComment _ _ "" = True -- the parse error will be reported by L.H.Parser+ balancedComment m n ('{':'-':cs) = balancedComment (m+1) n cs+ balancedComment m n ('-':'}':cs) = balancedComment (m-1) n cs+ balancedComment m n (_ :cs) = balancedComment m n cs+++parseDecl :: String -> Either String HsDecl+parseDecl s = case parseModule s of+ ParseOk (HsModule _ _ _ _ [d]) -> Right $ fixPrecedence d+ ParseFailed (SrcLoc _ _ col) msg -> Left $ showParseError msg col s++showParseError :: String -> Int -> String -> String+showParseError msg col s = " " ++ msg+ ++ case (col < 0, drop (col - 1) s) of+ (True, _) -> " at end of input" -- on the next line, which has no prefix+ (_,[] ) -> " at end of input"+ (_,ctx ) -> let ctx' = takeWhile (/= ' ') ctx+ in " at \"" ++ (take 5 ctx')+ ++ (if length ctx' > 5 then "..." else "")+ ++ "\" (column " ++ show col ++ ")"++-- Not really parsing++withParsed :: (forall a. (Data a, Eq a) => a -> a) -> String -> String+withParsed f s = case (parseExpr s, parseDecl s) of+ (Right a, _) -> prettyPrintInLine $ f a+ (_, Right a) -> prettyPrintInLine $ f a+ (Left e, _) -> e++prettyPrintInLine :: Pretty a => a -> String+prettyPrintInLine = prettyPrintWithMode (defaultMode { layout = PPInLine })
+ Lambdabot/Pointful.hs view
@@ -0,0 +1,173 @@+{-# OPTIONS -fno-warn-missing-signatures #-}+module Lambdabot.Pointful (pointful, ParseResult(..), test, main, combinatorModule) where++import Lambdabot.Parser++import Control.Monad.State+import Data.Generics+import Data.Maybe+import Language.Haskell.Parser+import Language.Haskell.Syntax+import qualified Data.Map as M++---- Utilities ----++extT' :: (Typeable a, Typeable b) => (a -> a) -> (b -> b) -> a -> a+extT' = extT+infixl `extT'`++unkLoc = SrcLoc "<new>" 1 1++stabilize f x = let x' = f x in if x' == x then x else stabilize f x'++namesIn h = everything (++) (mkQ [] (\x -> case x of UnQual name -> [name]; _ -> [])) h+pVarsIn h = everything (++) (mkQ [] (\x -> case x of HsPVar name -> [name]; _ -> [])) h++succName (HsIdent s) = HsIdent . reverse . succAlpha . reverse $ s++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 (HsPatBind loc (HsPVar fname) (HsUnGuardedRhs (HsLambda _ pats rhs)) [])+ = HsFunBind [HsMatch loc fname pats (HsUnGuardedRhs rhs) []]+---- combine function binding and lambda+optimizeD (HsFunBind [HsMatch loc fname pats1 (HsUnGuardedRhs (HsLambda _ pats2 rhs)) []])+ = HsFunBind [HsMatch loc fname (pats1 ++ pats2) (HsUnGuardedRhs rhs) []]+optimizeD x = x++-- remove parens+optimizeRhs (HsUnGuardedRhs (HsParen x))+ = HsUnGuardedRhs x+optimizeRhs x = x++optimizeE :: HsExp -> HsExp+-- apply ((\x z -> ...x...) y) yielding (\z -> ...y...) if there is only one x or y is simple+optimizeE (HsApp (HsParen (HsLambda loc (HsPVar ident : pats) body)) arg) | single || simple+ = HsParen (HsLambda loc pats (everywhere (mkT (\x -> if x == (HsVar (UnQual ident)) then arg else x)) body))+ where single = gcount (mkQ False (== ident)) body == 1+ simple = case arg of HsVar _ -> True; _ -> False+-- apply ((\_ z -> ...) y) yielding (\z -> ...)+optimizeE (HsApp (HsParen (HsLambda loc (HsPWildCard : pats) body)) _)+ = HsParen (HsLambda loc pats body)+-- remove 0-arg lambdas resulting from application rules+optimizeE (HsLambda _ [] b)+ = b+-- replace (\x -> \y -> z) with (\x y -> z)+optimizeE (HsLambda loc p1 (HsLambda _ p2 body))+ = HsLambda loc (p1 ++ p2) body+-- remove double parens+optimizeE (HsParen (HsParen x))+ = HsParen x+-- remove lambda body parens+optimizeE (HsLambda l p (HsParen x))+ = HsLambda l p x+-- remove var, lit parens+optimizeE (HsParen x@(HsVar _))+ = x+optimizeE (HsParen x@(HsLit _))+ = x+-- remove infix+lambda parens+optimizeE (HsInfixApp a o (HsParen l@(HsLambda _ _ _)))+ = HsInfixApp a o l+-- remove left-assoc application parens+optimizeE (HsApp (HsParen (HsApp a b)) c)+ = HsApp (HsApp a b) c+-- restore infix+optimizeE (HsApp (HsApp (HsVar name@(UnQual (HsSymbol _))) l) r)+ = (HsInfixApp l (HsQVarOp name) r)+-- fail+optimizeE x = x++---- Decombinatorization ----++-- fresh name generation. TODO: prettify this+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 = do everywhereM (mkM (\e -> case e of+ (HsLambda _ 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' :: HsExp -> State (HsName, [HsName]) HsExp++-- expand plain combinators+uncomb' (HsVar qname) | isJust maybeDef = rename (fromJust maybeDef)+ where maybeDef = M.lookup qname combinators++-- eliminate sections+uncomb' (HsRightSection op arg)+ = do a <- fresh+ return (HsParen (HsLambda unkLoc [HsPVar a] (HsInfixApp (HsVar (UnQual a)) op arg)))+uncomb' (HsLeftSection arg op)+ = do a <- fresh+ return (HsParen (HsLambda unkLoc [HsPVar a] (HsInfixApp arg op (HsVar (UnQual a)))))+-- infix to prefix for canonicality+uncomb' (HsInfixApp lf (HsQVarOp name) rf)+ = return (HsParen (HsApp (HsApp (HsVar name) (HsParen lf)) (HsParen rf)))++-- fail+uncomb' expr = return expr++---- Simple combinator definitions ---++combinators = M.fromList $ map declToTuple defs+ where defs = case parseModule combinatorModule of+ ParseOk (HsModule _ _ _ _ d) -> d+ f@(ParseFailed _ _) -> error ("Combinator loading: " ++ show f)+ declToTuple (HsPatBind _ (HsPVar fname) (HsUnGuardedRhs body) [])+ = (UnQual fname, HsParen body)++-- 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 = map (\(UnQual n) -> n) $ M.keys combinators++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 ",+ " ",+ "-- 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) (HsIdent "`", 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 = withParsed (optimize . uncomb)++test s = case parseModule s of+ f@(ParseFailed _ _) -> fail (show f)+ ParseOk (HsModule _ _ _ _ defs) ->+ flip mapM_ defs $ \def -> do+ putStrLn . prettyPrintInLine $ def+ putStrLn . prettyPrintInLine . uncomb $ def+ putStrLn . prettyPrintInLine . optimize . uncomb $ def++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/Process.hs view
@@ -0,0 +1,79 @@+-- Copyright (c) 2004-6 Don Stewart - http://www.cse.unsw.edu.au/~dons+-- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html)++-- | A Posix.popen compatibility mapping.+module Lambdabot.Process (popen, run) where++import System.Exit+import System.IO+import System.Process+import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar)++import qualified Control.Exception++run :: FilePath -> String -> (String -> String) -> IO String+run binary src scrub = do+ (out,err,_) <- popen binary [] (Just src)+ let o = scrub out+ e = scrub err+ return $ case () of {_+ | null o && null e -> "Done."+ | null o -> e+ | otherwise -> o+ }++--+-- Ignoring exit status for now.+--+-- You have to ignore SIGPIPE, otherwise popening a non-existing executable+-- will result in an attempt to write to a closed pipe and crash the wholw+-- program.+--+-- XXX there are still issues. Large amounts of output can cause what+-- seems to be a dead lock on the pipe write from runplugs, for example.+-- Posix.popen doesn't have this problem, so maybe we can reproduce its+-- pipe handling somehow.+-- | popen lets you run a binary with specified arguments. This bypasses the shell.+popen :: FilePath -- ^ The binary to execute+ -> [String] -- ^ A list of arguments to pass to the binary. No need to+ -- space separate them+ -> Maybe String -- ^ stdin+ -> IO (String,String,ExitCode)+popen file args minput =+ Control.Exception.handle (\e -> return ([],show e,error (show e))) $ do++ (inp,out,err,pid) <- runInteractiveProcess file args Nothing Nothing++ case minput of+ Just input -> hPutStr inp input >> hClose inp -- importante!+ Nothing -> return ()++ -- Now, grab the input+ output <- hGetContents out+ errput <- hGetContents err++ -- SimonM sez:+ -- ... avoids blocking the main thread, but ensures that all the+ -- data gets pulled as it becomes available. you have to force the+ -- output strings before waiting for the process to terminate.+ --++ -- Samb says:+ -- Might as well try to avoid hanging my system...+ -- make sure it happens FIRST.++ outMVar <- newEmptyMVar+ errMVar <- newEmptyMVar++ forkIO (Control.Exception.evaluate (length output) >> putMVar outMVar ())+ forkIO (Control.Exception.evaluate (length errput) >> putMVar errMVar ())++ takeMVar outMVar+ takeMVar errMVar++ -- And now we wait. We must wait after we read, unsurprisingly.+ -- blocks without -threaded, you're warned.+ -- and maybe the process has already completed..+ e <- Control.Exception.catch (waitForProcess pid) (\_ -> return ExitSuccess)++ return (output,errput,e)
+ Lambdabot/Regex.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------+-- |+-- Module : Lambdabot.Regex+-- Copyright : (c) Don Stewart 2007+-- License : GPL (see LICENSE)+--+-- Maintainer : dons@galois.com+--+-----------------------------------------------------------------------------++module Lambdabot.Regex (+ -- ByteString interface+ regex, -- :: ByteString -> Regex+ matches, -- :: Regex -> ByteString -> Bool++ -- String interface+ regex', -- :: String -> Regex+ matches', -- :: Regex -> String -> Bool++ -- and the underlying module+ module Text.Regex.Posix.ByteString++ ) where++import Data.ByteString.Char8++import Text.Regex.Posix.ByteString+import System.IO.Unsafe (unsafePerformIO)++------------------------------------------------------------------------+--+-- convenient regex wrappers:+--++regex' :: String -> Regex+regex :: ByteString -> Regex++matches' :: Regex -> String -> Bool+matches :: Regex -> ByteString -> Bool++------------------------------------------------------------------------++-- For ghc 6.6 we use the regex-posix bytestring library++regex' s = regex (pack s)++regex p = unsafePerformIO $ do+ res <- compile compileFlags execFlags p+ case res of+ Left err -> error $ "regex failed: " ++ show err+ Right r -> return r+ where+ compileFlags = compExtended+ execFlags = 0++-- match a regex against a string or bytestring+matches' r s = matches r (pack s)++matches r p = unsafePerformIO $ do+ res <- execute r p+ case res of+ Left err -> error $ "regex execute failed: " ++ show err+ Right Nothing -> return False+ Right (Just _) -> return True
+ Lambdabot/Serial.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE CPP, 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.Serial (+ Serial(..),+ stdSerial, mapSerial, listSerial,+ mapPackedSerial, assocListPackedSerial, mapListPackedSerial,+ readM, Packable(..), {- instances of Packable -}+ packedListSerial,+ readOnly, gzip, gunzip+ ) 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)++#ifndef mingw32_HOST_OS+import Data.ByteString.Lazy (fromChunks,toChunks)++import Codec.Compression.GZip+#endif+++------------------------------------------------------------------------++-- 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+ }++#ifdef mingw32_HOST_OS+-- XXX I haven't built a gzip library yet.+gzip :: ByteString -> ByteString+gzip = id++gunzip :: ByteString -> ByteString+gunzip = id++#else+gzip :: ByteString -> ByteString+gzip = P.concat . toChunks . compress . fromChunks . (:[])++gunzip :: ByteString -> ByteString+gunzip = P.concat . toChunks . decompress .fromChunks . (:[])+#endif++--+-- 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+ }++-- | Serialize a list of 'a's. As for the 'mapSerializer', its output is line-wise.+listSerial :: (Read a, Show a) => Serial [a]+listSerial = Serial {+ serialize = Just .P.pack . unlines . map show,+ deserialize = Just . mapMaybe (readM . P.unpack) . P.lines+ }++packedListSerial :: Serial [P.ByteString]+packedListSerial = Serial {+ serialize = Just . P.unlines,+ deserialize = Just . 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/Signals.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP, DeriveDataTypeable #-}++-- | 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 catchIrc or+-- handleIrc++-- Here's where we do that.+module Lambdabot.Signals where++#ifdef mingw32_HOST_OS+import Data.Typeable+import Control.Monad.Error++type Signal = String+newtype SignalException = SignalException Signal deriving Typeable++ircSignalMessage :: Signal -> [Char]+ircSignalMessage s = s++withIrcSignalCatch :: (MonadError e m,MonadIO m) => m () -> m ()+withIrcSignalCatch m = m++#else+import Lambdabot.Error+import Lambdabot.Util++import Data.Typeable++import Control.Concurrent+import Control.Exception+import Control.Monad.Error++import System.IO.Unsafe+import System.Posix.Signals++-- A new type for the SignalException, must be Typeable so we can make a+-- dynamic exception out of it.+newtype SignalException = SignalException Signal deriving Typeable++--+-- A bit of sugar for installing a new handler+--+withHandler :: (MonadIO m,MonadError e m) => Signal -> Handler -> m () -> m ()+withHandler s h m+ = bracketError (io (installHandler s h Nothing))+ (io . flip (installHandler s) Nothing)+ (const m)++-- And more sugar for installing a list of handlers+withHandlerList :: (MonadError e m,MonadIO m)+ => [Signal] -> (Signal -> Handler) -> m () -> m ()+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]+ircSignalsToCatch = [+ busError,+ segmentationViolation,+ keyboardSignal,+ softwareTermination,+ keyboardTermination,+ lostConnection,+ internalAbort+ ]++--+-- User friendly names for the signals that we can catch+--+ircSignalMessage :: Signal -> [Char]+ircSignalMessage s+ | s==busError = "SIGBUS"+ | s==segmentationViolation = "SIGSEGV"+ | s==keyboardSignal = "SIGINT"+ | s==softwareTermination = "SIGTERM"+ | s==keyboardTermination = "SIGQUIT"+ | s==lostConnection = "SIGHUP"+ | s==internalAbort = "SIGABRT"+-- this case shouldn't happen if the list of messages is kept up to date+-- with the list of signals caught+ | otherwise = "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/catchIrc+--+ircSignalHandler :: ThreadId -> Signal -> Handler+ircSignalHandler threadid s+ = CatchOnce $ do+ putMVar catchLock ()+ releaseSignals+ throwDynTo threadid $ SignalException s++--+-- | Release all signal handlers+--+releaseSignals :: IO ()+releaseSignals =+ flip mapM_ ircSignalsToCatch+ (\sig -> installHandler sig Default Nothing)++--+-- 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 :: (MonadError e m,MonadIO m) => m () -> m ()+withIrcSignalCatch m = do+ io $ installHandler sigPIPE Ignore Nothing+ io $ installHandler sigALRM Ignore Nothing+ threadid <- io myThreadId+ withHandlerList ircSignalsToCatch (ircSignalHandler threadid) m+#endif
+ Lambdabot/Url.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE PatternGuards #-}++-- | URL Utility Functions++module Lambdabot.Url (+ getHtmlPage,+ getHeader,+ rawPageTitle,+ urlPageTitle,+ urlTitlePrompt,+ runWebReq+ ) where++import Data.List+import Data.Maybe+import Lambdabot.MiniHTTP++import Control.Monad.Reader+import Text.HTML.TagSoup.Parser+import Text.HTML.TagSoup.Match+import Text.HTML.TagSoup+import Codec.Binary.UTF8.String++-- | The string that I prepend to the quoted page title.+urlTitlePrompt :: String+urlTitlePrompt = "Title: "++-- | Limit the maximum title length to prevent jokers from spamming+-- the channel with specially crafted HTML pages.+maxTitleLength :: Int+maxTitleLength = 80++-- | A web request monad transformer for keeping hold of the proxy.+type WebReq a = ReaderT Proxy IO a+runWebReq :: WebReq a -> Proxy -> IO a+runWebReq = runReaderT++-- | 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 -> WebReq (Maybe String)+urlPageTitle url = do+ title <- rawPageTitle url+ return $ maybe Nothing prettyTitle title+ where+ limitLength s+ | length s > maxTitleLength = (take maxTitleLength s) ++ " ..."+ | otherwise = s++ prettyTitle = Just . (urlTitlePrompt ++) . limitLength++-- | 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 -> WebReq (Maybe String)+rawPageTitle url + | Just uri <- parseURI url' = do+ contents <- getHtmlPage uri+ case contentType contents of+ Just "text/html" -> return $ extractTitle contents+ Just "application/pdf" -> rawPageTitle (googleCacheURL url)+ _ -> return $ Nothing+ | otherwise = return Nothing+ -- URLs containing `#' fail to parse with parseURI, but+ -- these kind of URLs are commonly pasted, so we ought to try+ -- removing that part of provided URLs.+ where url' = takeWhile (/='#') url+ googleCacheURL = (gURL++) . escapeURIString (const False)+ gURL = "http://www.google.com/search?hl=en&q=cache:"++-- | Fetch the contents of a URL following HTTP redirects. It returns+-- a list of strings comprising the server response which includes the+-- status line, response headers, and body.+getHtmlPage :: URI -> WebReq [String]+getHtmlPage u = getHtmlPage' u 5+ where+ getHtmlPage' :: URI -> Int -> WebReq [String]+ getHtmlPage' _ 0 = return []+ getHtmlPage' uri n = do+ contents <- getURIContents uri+ case responseStatus contents of+ 301 -> getHtmlPage' (redirectedUrl contents) (n-1)+ 302 -> getHtmlPage' (redirectedUrl contents) (n-1)+ 200 -> return contents+ _ -> return []+ where+ -- | Parse the HTTP response code from a line in the following+ -- format: HTTP/1.1 200 Success.+ responseStatus hdrs = (read . (!!1) . words . (!!0)) hdrs :: Int++ -- | Return the value of the "Location" header in the server+ -- response+ redirectedUrl hdrs+ | Just loc <- getHeader "Location" hdrs =+ case parseURI loc of+ Nothing -> (fromJust . parseURI) $ fullUrl loc+ Just uri' -> uri'+ | otherwise = error("No Location header found in 3xx response.")++ -- | Construct a full absolute URL based on the current uri. This is+ -- used when a Location header violates the HTTP RFC and does not send+ -- an absolute URI in the response, instead, a relative URI is sent, so+ -- we must manually construct the absolute URI.+ fullUrl loc = let auth = fromJust $ uriAuthority uri+ in (uriScheme uri) ++ "//" +++ (uriRegName auth) +++ loc++-- | Fetch the contents of a URL returning a list of strings+-- comprising the server response which includes the status line,+-- response headers, and body.+getURIContents :: URI -> WebReq [String]+getURIContents uri = do+ proxy <- ask+ liftIO $ readNBytes 3048 proxy uri (request proxy) ""+ where+ request Nothing = ["GET " ++ abs_path ++ " HTTP/1.1",+ "host: " ++ host,+ "Connection: close", ""]+ request _ = ["GET " ++ show uri ++ " HTTP/1.0", ""]++ abs_path = case uriPath uri ++ uriQuery uri ++ uriFragment uri of+ url@('/':_) -> url+ url -> '/':url++ host = uriRegName . fromJust $ uriAuthority uri++-- | 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 . unlines 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)++-- | What is the type of the server response?+contentType :: [String] -> Maybe (String)+contentType [] = Nothing+contentType contents = Just val+ where+ val = takeWhile (/=';') ctype+ ctype = case getHeader "Content-Type" contents of+ Nothing -> error "Lib.URL.isTextHTML: getHeader failed"+ Just c -> c++-- | Retrieve the specified header from the server response being+-- careful to strip the trailing carriage return. I swiped this code+-- from Search.hs, but had to modify it because it was not properly+-- stripping off the trailing CR (must not have manifested itself as a+-- bug in that code; however, parseURI will fail against CR-terminated+-- strings.+getHeader :: String -> [String] -> Maybe String+getHeader _ [] = Nothing+getHeader hdr (_:hs) = lookup hdr $ concatMap mkassoc hs+ where+ removeCR = takeWhile (/='\r')+ mkassoc s = case findIndex (==':') s of+ Just n -> [(take n s, removeCR $ drop (n+2) s)]+ Nothing -> []
+ Lambdabot/Util.hs view
@@ -0,0 +1,559 @@+-- 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 (+ concatWith,+ split, split2,+ breakOnGlue,+ clean,+ dropSpace,+ dropSpaceEnd,+ dropNL,+ snoc,+ after,+ splitFirstWord,+ firstWord,+ debugStr,+ debugStrLn,+ lowerCaseString, upperCaseString,+ upperize, lowerize,+ quote, timeStamp,+ listToStr, showWidth,+ listToMaybeWith, listToMaybeAll,+ getRandItem, stdGetRandItem, randomElem,+ showClean,+ expandTab,+ closest, closests,+ withMWriter, parIO, timeout,+ choice,+ arePrefixesWithSpaceOf, arePrefixesOf,++ (</>), (<.>), (<+>), (<>), (<$>),+ basename, dirname, dropSuffix, joinPath,++ addList, mapMaybeMap, insertUpd,++ pprKeys,++ isLeft, isRight, unEither,++ io,++ random, insult, confirmation+ ) where++import Data.List (intersperse, isPrefixOf)+import Data.Char (isSpace, toLower, toUpper)+import Data.Maybe+import Control.Monad.State (MonadIO(..))++import qualified Data.Map as M+import Data.IORef (newIORef, readIORef, writeIORef)++import Control.Concurrent (MVar, newEmptyMVar, takeMVar, tryPutMVar, putMVar,+ forkIO, killThread, threadDelay)+import Control.Exception (bracket)++-- getStdRandom has a bug, see safeGetStdRandom below.+import System.Random hiding (split,random,getStdRandom)++import System.IO+import qualified System.Time as T++------------------------------------------------------------------------++-- | 'concatWith' joins lists with the given glue elements. Example:+--+-- > concatWith ", " ["one","two","three"] ===> "one, two, three"+concatWith :: [a] -- ^ Glue to join with+ -> [[a]] -- ^ Elements to glue together+ -> [a] -- ^ Result: glued-together list++concatWith glue xs = (concat . intersperse glue) xs++-- | Split a list into pieces that were held together by glue. Example:+--+-- > split ", " "one, two, three" ===> ["one","two","three"]+split :: Eq a => [a] -- ^ Glue that holds pieces together+ -> [a] -- ^ List to break into pieces+ -> [[a]] -- ^ Result: list of pieces+split glue xs = split' xs+ where+ split' [] = []+ split' xs' = piece : split' (dropGlue rest)+ where (piece, rest) = breakOnGlue glue xs'+ dropGlue = drop (length glue)++-- a variant?+split2 :: Char -> Int -> String -> [String]+split2 c i s =+ let fn 0 t = t:[]+ fn j t = let (xs,ys) = break (== c) t+ in case ys of+ [] -> xs:[]+ _ -> xs: fn (j-1) (tail ys)+ in fn (i-1) s+++-- | Break off the first piece of a list held together by glue,+-- leaving the glue attached to the remainder of the list. Example:+-- Like break, but works with a [a] match.+--+-- > breakOnGlue ", " "one, two, three" ===> ("one", ", two, three")+breakOnGlue :: (Eq a) => [a] -- ^ Glue that holds pieces together+ -> [a] -- ^ List from which to break off a piece+ -> ([a],[a]) -- ^ Result: (first piece, glue ++ rest of list)+breakOnGlue _ [] = ([],[])+breakOnGlue glue rest@(x:xs)+ | glue `isPrefixOf` rest = ([], rest)+ | otherwise = (x:piece, rest')+ where (piece, rest') = breakOnGlue glue xs+{-# INLINE breakOnGlue #-}++-- | Reverse cons. Add an element to the back of a list. Example:+--+-- > snoc 3 [2, 1] ===> [2, 1, 3]+snoc :: a -- ^ Element to be added+ -> [a] -- ^ List to add to+ -> [a] -- ^ Result: List ++ [Element]+snoc x xs = xs ++ [x]++-- | 'after' takes 2 strings, called the prefix and data. A necessary+-- precondition is that+--+-- > Data.List.isPrefixOf prefix data ===> True+--+-- 'after' returns a string based on data, where the prefix has been+-- removed as well as any excess space characters. Example:+--+-- > after "This is" "This is a string" ===> "a string"+after :: String -- ^ Prefix string+ -> String -- ^ Data string+ -> String -- ^ Result: Data string with Prefix string and excess whitespace+ -- removed+after [] ys = dropWhile isSpace ys+after (_:_) [] = error "after: (:) [] case"+after (x:xs) (y:ys)+ | x == y = after xs ys+ | otherwise = error "after: /= case"++-- | 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++-- | Get the first word of a string. Example:+--+-- > first_word "This is a fine day" ===> "This"+firstWord :: String -> String+firstWord = takeWhile (not . isSpace)++-- refactor, might be good for logging to file later+-- | 'debugStr' checks if we have the verbose flag turned on. If we have+-- it outputs the String given. Else, it is a no-op.++debugStr :: (MonadIO m) => String -> m ()+debugStr = liftIO . putStr++-- | 'debugStrLn' is a version of 'debugStr' that adds a newline to the end+-- of the string outputted.+debugStrLn :: (MonadIO m) => [Char] -> m ()+debugStrLn x = debugStr (x ++ "\n")++-- | 'lowerCaseString' transforms the string given to lower case.+--+-- > Example: lowerCaseString "MiXeDCaSe" ===> "mixedcase"+lowerCaseString :: String -> String+lowerCaseString = map toLower++-- | 'upperCaseString' transforms the string given to upper case.+--+-- > Example: upperCaseString "MiXeDcaSe" ===> "MIXEDCASE"+upperCaseString :: String -> String+upperCaseString = map toUpper++-- | 'lowerize' forces the first char of a string to be lowercase.+-- if the string is empty, the empty string is returned.+lowerize :: String -> String+lowerize [] = []+lowerize (c:cs) = toLower c:cs++-- | 'upperize' forces the first char of a string to be uppercase.+-- if the string is empty, the empty string is returned.+upperize :: String -> String+upperize [] = []+upperize (c:cs) = toUpper c:cs++-- | 'quote' puts a string into quotes but does not escape quotes in+-- the string itself.+quote :: String -> String+quote x = "\"" ++ x ++ "\""++-- | 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++-- | Like 'listToMaybe', but take a function to use in case of a non-null list.+-- I.e. @listToMaybe = listToMaybeWith head@+listToMaybeWith :: ([a] -> b) -> [a] -> Maybe b+listToMaybeWith _ [] = Nothing+listToMaybeWith f xs = Just (f xs)++-- | @listToMaybeAll = listToMaybeWith id@+listToMaybeAll :: [a] -> Maybe [a]+listToMaybeAll = listToMaybeWith id++------------------------------------------------------------------------++-- | getStdRandom has a bug when 'f' returns bottom, we strictly evaluate the+-- new generator before calling setStdGen.+safeGetStdRandom :: (StdGen -> (a,StdGen)) -> IO a+safeGetStdRandom f = do+ g <- getStdGen+ let (x, g') = f g+ setStdGen $! g'+ return x++-- | 'getRandItem' takes as input a list and a random number generator. It+-- then returns a random element from the list, paired with the altered+-- state of the RNG+getRandItem :: (RandomGen g) =>+ [a] -- ^ The list to pick a random item from+ -> g -- ^ The RNG to use+ -> (a, g) -- ^ A pair of the item, and the new RNG seed+getRandItem [] g = (error "getRandItem: empty list", g)+getRandItem mylist rng = (mylist !! index,newRng)+ where+ llen = length mylist+ (index, newRng) = randomR (0,llen - 1) rng++-- | 'stdGetRandItem' is the specialization of 'getRandItem' to the standard+-- RNG embedded within the IO monad. The advantage of using this is that+-- you use the Operating Systems provided RNG instead of rolling your own+-- and the state of the RNG is hidden, so one don't need to pass it+-- explicitly.+stdGetRandItem :: [a] -> IO a+stdGetRandItem = safeGetStdRandom . getRandItem++randomElem :: [a] -> IO a+randomElem = stdGetRandItem++random :: MonadIO m => [a] -> m a+random = liftIO . randomElem++------------------------------------------------------------------------++-- | '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++-- | 'clean' takes a Char x and returns [x] unless the Char is '\CR' in+-- case [] is returned.+clean :: Char -> [Char]+clean x | x == '\CR' = []+ | otherwise = [x]++------------------------------------------------------------------------++-- | show a list without heavyweight formatting+showClean :: (Show a) => [a] -> String+showClean = concatWith " " . map (init . tail . show)++dropNL :: [Char] -> [Char]+dropNL = reverse . dropWhile (== '\n') . reverse++-- | untab an string+expandTab :: String -> String+expandTab [] = []+expandTab ('\t':xs) = ' ':' ':' ':' ':' ':' ':' ':' ':expandTab xs+expandTab (x:xs) = x : expandTab xs++------------------------------------------------------------------------++--+-- | Find string in list with smallest levenshtein distance from first+-- argument, return the string and the distance from pat it is. Will+-- return the alphabetically first match if there are multiple matches+-- (this may not be desirable, e.g. "mroe" -> "moo", not "more"+--+closest :: String -> [String] -> (Int,String)+closest pat ss = minimum ls+ where+ ls = map (\s -> (levenshtein pat s,s)) ss++closests :: String -> [String] -> (Int,[String])+closests pat ss =+ let (m,_) = minimum ls+ in (m, map snd (filter ((m ==) . fst) ls))+ where+ ls = map (\s -> (levenshtein pat s,s)) ss++--+-- | Levenshtein edit-distance algorithm+-- Translated from an Erlang version by Fredrik Svensson and Adam Lindberg+--+levenshtein :: String -> String -> Int+levenshtein [] [] = 0+levenshtein s [] = length s+levenshtein [] s = length s+levenshtein s t = lvn s t [0..length t] 1++lvn :: String -> String -> [Int] -> Int -> Int+lvn [] _ dl _ = last dl+lvn (s:ss) t dl n = lvn ss t (lvn' t dl s [n] n) (n + 1)++lvn' :: String -> [Int] -> Char -> [Int] -> Int -> [Int]+lvn' [] _ _ ndl _ = ndl+lvn' (t:ts) (dlh:dlt) c ndl ld | length dlt > 0 = lvn' ts dlt c (ndl ++ [m]) m+ where+ m = foldl1 min [ld + 1, head dlt + 1, dlh + (dif t c)]+lvn' _ _ _ _ _ = error "levenshtein, ran out of numbers"++dif :: Char -> Char -> Int+dif = (fromEnum .) . (/=)++{-+--+-- naive implementation, O(2^n)+-- Too slow after around d = 8+--+-- V. I. Levenshtein. Binary codes capable of correcting deletions,+-- insertions and reversals. Doklady Akademii Nauk SSSR 163(4) p845-848,+-- 1965+--+-- A Guided Tour to Approximate String Matching, G. Navarro+--+levenshtein :: (Eq a) => [a] -> [a] -> Int+levenshtein [] [] = 0+levenshtein s [] = length s+levenshtein [] s = length s+levenshtein (s:ss) (t:ts) =+ min3 (eq + (levenshtein ss ts))+ (1 + (levenshtein (ss++[s]) ts))+ (1 + (levenshtein ss (ts++[t])))+ where+ eq = fromEnum (s /= t)+ min3 a b c = min c (min a b)+-}++------------------------------------------------------------------------++-- | Thread-safe modification of an MVar.+withMWriter :: MVar a -> (a -> (a -> IO ()) -> IO b) -> IO 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)+++-- stolen from+-- http://www.haskell.org/pipermail/haskell-cafe/2005-January/008314.html+parIO :: IO a -> IO a -> IO a+parIO a1 a2 = do+ m <- newEmptyMVar+ c1 <- forkIO $ putMVar m =<< a1+ c2 <- forkIO $ putMVar m =<< a2+ r <- takeMVar m+ -- killThread blocks until the thread has been killed. Therefore, we call+ -- killThread asynchronously in case one thread is blocked in a foreign+ -- call.+ forkIO $ killThread c1 >> killThread c2+ return r++-- | run an action with a timeout+timeout :: Int -> IO a -> IO (Maybe a)+timeout n a = parIO (Just `fmap` a) (threadDelay n >> return Nothing)++------------------------------------------------------------------------++-- some filename manipulation stuff++--+-- | </>, <.> : join two path components+--+infixr 6 </>+infixr 6 <.>+infixr 6 <+>+infixr 6 <>+infixr 6 <$>++(</>), (<.>), (<+>), (<>), (<$>) :: FilePath -> FilePath -> FilePath+[] </> b = b+a </> b = a ++ "/" ++ b++[] <.> b = b+a <.> b = a ++ "." ++ b++[] <+> b = b+a <+> b = a ++ " " ++ b++[] <> b = b+a <> b = a ++ b++[] <$> b = b+a <$> b = a ++ "\n" ++ b++basename :: FilePath -> FilePath+basename = reverse . takeWhile ('/' /=) . reverse++dirname :: FilePath -> FilePath+dirname p =+ case reverse $ dropWhile (/= '/') $ reverse p of+ [] -> "."+ p' -> p'++dropSuffix :: FilePath -> FilePath+dropSuffix = reverse . tail . dropWhile ('.' /=) . reverse++joinPath :: FilePath -> FilePath -> FilePath+joinPath p q =+ case reverse p of+ '/':_ -> p ++ q+ [] -> q+ _ -> p ++ "/" ++ q++{-# INLINE choice #-}+choice :: (r -> Bool) -> (r -> a) -> (r -> a) -> (r -> a)+choice p f g x = if p x then f x else g x++-- Generalizations:+-- choice :: ArrowChoice (~>) => r ~> Bool -> r ~> a -> r ~> a -> r ~> a+-- choice :: Monad m => m Bool -> m a -> m a -> m a++------------------------------------------------------------------------++addList :: (Ord k) => [(k,a)] -> M.Map k a -> M.Map k a+addList l m = M.union (M.fromList l) m+{-# INLINE addList #-}++-- | Data.Maybe.mapMaybe for Maps+mapMaybeMap :: Ord k => (a -> Maybe b) -> M.Map k a -> M.Map k b+mapMaybeMap f = fmap fromJust . M.filter isJust . fmap f++-- | This makes way more sense than @insertWith@ because we don't need to+-- remember the order of arguments of @f@.+insertUpd :: Ord k => (a -> a) -> k -> a -> M.Map k a -> M.Map k a+insertUpd f = M.insertWith (\_ -> f)++-- | Print map keys+pprKeys :: (Show k) => M.Map k a -> String+pprKeys = showClean . M.keys++-- | Two functions that really should be in Data.Either+isLeft, isRight :: Either a b -> Bool+isLeft (Left _) = True+isLeft _ = False+isRight = not . isLeft++-- | Another useful Either function to easily get out of an Either+unEither :: Either a a -> a+unEither = either id id+++-- convenience:+io :: MonadIO m => IO a -> m a+io = liftIO+{-# INLINE io #-}+++arePrefixesWithSpaceOf :: [String] -> String -> Bool+arePrefixesWithSpaceOf els str = any (flip isPrefixOf str) $ map (++" ") els++arePrefixesOf :: [String] -> String -> Bool+arePrefixesOf = flip (any . flip isPrefixOf)++-- | 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 :: T.ClockTime -> String+timeStamp ct = let cal = T.toUTCTime ct+ in (showWidth 2 $ T.ctHour cal) ++ ":" +++ (showWidth 2 $ T.ctMin cal) ++ ":" +++ (showWidth 2 $ T.ctSec cal)++++--+-- 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!",+ "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?",++ "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",++ -- 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.",+ -- 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!"+ ]
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMainWithHooks defaultUserHooks
+ lambdabot-utils.cabal view
@@ -0,0 +1,34 @@+Name: lambdabot-utils+Version: 4.1+License: GPL+License-file: LICENSE+Author: Don Stewart+Maintainer: Cale Gibbard <cgibbard@gmail.com>+Category: Development, Web+Synopsis: Utility libraries for the advanced IRC bot, Lambdabot+Description: Lambdabot is an IRC bot written over several years by+ those on the #haskell IRC channel.+ .+ Our own custom libraries for various plugin functions.+ .+ AltTime.hs: alternate version of the time library+ .+ MiniHTTP.hs: a mini http server+ .+ Process.hs: a wrapper over System.Process+ .+ Regex.hsc: a fast packed string regex library+ .+ Serial.hs:: a serialisation API+ .+ Util.hs: miscellaneous string, and other, functions+Homepage: http://haskell.org/haskellwiki/Lambdabot+build-type: Simple++Build-depends: base, haskell-src, containers, zlib, bytestring, mtl,+ regex-compat, regex-posix, process, network, old-time, binary, unix, random, tagsoup, utf8-string+Exposed-modules: Lambdabot.FixPrecedence, Lambdabot.Serial,+ Lambdabot.Error, Lambdabot.Url, Lambdabot.Process,+ Lambdabot.Regex, Lambdabot.MiniHTTP, Lambdabot.AltTime,+ Lambdabot.Pointful, Lambdabot.Parser, Lambdabot.Signals,+ Lambdabot.Util