diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Lambdabot/AltTime.hs b/Lambdabot/AltTime.hs
new file mode 100644
--- /dev/null
+++ b/Lambdabot/AltTime.hs
@@ -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)
+
+
diff --git a/Lambdabot/Error.hs b/Lambdabot/Error.hs
new file mode 100644
--- /dev/null
+++ b/Lambdabot/Error.hs
@@ -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)
diff --git a/Lambdabot/FixPrecedence.hs b/Lambdabot/FixPrecedence.hs
new file mode 100644
--- /dev/null
+++ b/Lambdabot/FixPrecedence.hs
@@ -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
+
diff --git a/Lambdabot/MiniHTTP.hs b/Lambdabot/MiniHTTP.hs
new file mode 100644
--- /dev/null
+++ b/Lambdabot/MiniHTTP.hs
@@ -0,0 +1,110 @@
+-- | HTTP protocol binding.
+--
+--
+
+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 [] = []
diff --git a/Lambdabot/Parser.hs b/Lambdabot/Parser.hs
new file mode 100644
--- /dev/null
+++ b/Lambdabot/Parser.hs
@@ -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 })
diff --git a/Lambdabot/Pointful.hs b/Lambdabot/Pointful.hs
new file mode 100644
--- /dev/null
+++ b/Lambdabot/Pointful.hs
@@ -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 "" 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' .) . (==))) =<<)"
diff --git a/Lambdabot/Process.hs b/Lambdabot/Process.hs
new file mode 100644
--- /dev/null
+++ b/Lambdabot/Process.hs
@@ -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)
diff --git a/Lambdabot/Regex.hs b/Lambdabot/Regex.hs
new file mode 100644
--- /dev/null
+++ b/Lambdabot/Regex.hs
@@ -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
diff --git a/Lambdabot/Serial.hs b/Lambdabot/Serial.hs
new file mode 100644
--- /dev/null
+++ b/Lambdabot/Serial.hs
@@ -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)
+
+------------------------------------------------------------------------
diff --git a/Lambdabot/Signals.hs b/Lambdabot/Signals.hs
new file mode 100644
--- /dev/null
+++ b/Lambdabot/Signals.hs
@@ -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
diff --git a/Lambdabot/Url.hs b/Lambdabot/Url.hs
new file mode 100644
--- /dev/null
+++ b/Lambdabot/Url.hs
@@ -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 -> []
diff --git a/Lambdabot/Util.hs b/Lambdabot/Util.hs
new file mode 100644
--- /dev/null
+++ b/Lambdabot/Util.hs
@@ -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!"
+ ]
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+import Distribution.Simple
+main = defaultMainWithHooks defaultUserHooks
diff --git a/lambdabot-utils.cabal b/lambdabot-utils.cabal
new file mode 100644
--- /dev/null
+++ b/lambdabot-utils.cabal
@@ -0,0 +1,34 @@
+Name: lambdabot-utils
+Version: 4.1
+License: GPL
+License-file: LICENSE
+Author: Don Stewart
+Maintainer: Cale Gibbard
+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