lambdabot-utils-4.2.2/0000755000000000000000000000000012107664126012775 5ustar0000000000000000lambdabot-utils-4.2.2/Setup.hs0000644000000000000000000000014212107664126014426 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMainWithHooks defaultUserHooks lambdabot-utils-4.2.2/LICENSE0000644000000000000000000000225612107664126014007 0ustar0000000000000000Copyright (c) 2003 Andrew J. Bromage Portions Copyright (c) 2003 Shae Erisson, Sven M. Hallberg, Taylor Campbell Portions Copyright (c) 2003-2006 Members of the AUTHORS file Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. lambdabot-utils-4.2.2/lambdabot-utils.cabal0000644000000000000000000000461112107664126017046 0ustar0000000000000000name: lambdabot-utils version: 4.2.2 license: GPL license-file: LICENSE author: Don Stewart et al. maintainer: Jan Stolarek 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 bug-reports: https://github.com/killy9999/lambdabot-utils/issues build-type: Simple tested-with: GHC>=7.6 cabal-version: >= 1.10 source-repository head type: git location: git://github.com/killy9999/lambdabot-utils library default-language: Haskell2010 build-depends: base >=4 && <5, binary, bytestring, containers, haskell-src, mtl, network, old-time, process, random, regex-compat, regex-posix, syb, tagsoup > 0.6, unix, utf8-string, zlib ghc-options: -Wall exposed-modules: Lambdabot.AltTime, Lambdabot.Error, Lambdabot.FixPrecedence, Lambdabot.MiniHTTP, Lambdabot.Parser, Lambdabot.Pointful, Lambdabot.Process, Lambdabot.Regex, Lambdabot.Serial, Lambdabot.Signals, Lambdabot.Url, Lambdabot.Util lambdabot-utils-4.2.2/Lambdabot/0000755000000000000000000000000012107664126014662 5ustar0000000000000000lambdabot-utils-4.2.2/Lambdabot/Serial.hs0000644000000000000000000001440112107664126016435 0ustar0000000000000000{-# 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-utils-4.2.2/Lambdabot/Process.hs0000644000000000000000000000542412107664126016641 0ustar0000000000000000-- Copyright (c) 2004-6 Don Stewart - http://www.cse.unsw.edu.au/~dons -- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) -- | 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, killThread) import qualified Control.Exception as E 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 } -- | popen lets you run a binary with specified arguments. This bypasses the shell. -- | It'll also terminate (SIGTERM) the spawned process in case of -- | exception, this is very important if the timeout for a Plugin -- | expires while it is waiting for the result of a looping process. -- | It's fundamental to link the final executable with -threaded. 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 = E.handle (\(E.SomeException e) -> return ([],show e,error (show e))) $ E.bracketOnError (runInteractiveProcess file args Nothing Nothing) (\(_,_,_,pid) -> terminateProcess pid) $ \(inp,out,err,pid) -> do case minput of Just input -> hPutStr inp input >> E.catch (hClose inp) (\(E.SomeException _) -> return ()) 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 E.bracketOnError (do t1 <- forkIO (E.evaluate (length output) >> putMVar outMVar ()) t2 <- forkIO (E.evaluate (length errput) >> putMVar errMVar ()) return (t1,t2)) (\(t1,t2) -> killThread t1 >> killThread t2 ) (\_ -> 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 <- waitForProcess pid return (output,errput,e) lambdabot-utils-4.2.2/Lambdabot/Regex.hs0000644000000000000000000000333112107664126016270 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- 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-utils-4.2.2/Lambdabot/Pointful.hs0000644000000000000000000001574312107664126017030 0ustar0000000000000000{-# 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 succName _ = error "HsIdent expected" 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) declToTuple _ = error "Can't conver declaration to tuple: incorrect pattern bindings" -- 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-utils-4.2.2/Lambdabot/Util.hs0000644000000000000000000004253312107664126016142 0ustar0000000000000000-- Copyright (c) 2006 Don Stewart - http://www.cse.unsw.edu.au/~dons -- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) -- | String and other utilities module Lambdabot.Util ( 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 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!" ] lambdabot-utils-4.2.2/Lambdabot/AltTime.hs0000644000000000000000000000570312107664126016562 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} -- | 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-utils-4.2.2/Lambdabot/Parser.hs0000644000000000000000000001004412107664126016451 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} -- Haskell expression parser. Big hack, but only uses documented APIs so it -- should be more robust than the previous hack. module Lambdabot.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 _ -> Left $ "Unexpected result of parsing an expression" 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 _ -> Left $ "Unexpected result of parsing a declaration" 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-utils-4.2.2/Lambdabot/Signals.hs0000644000000000000000000001012312107664126016613 0ustar0000000000000000{-# 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 (Show,Typeable) instance Exception SignalException 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 (myThreadId, newEmptyMVar, putMVar, MVar, ThreadId) import Control.Exception.Base (Exception,throwTo) 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 (Show, Typeable) instance Exception SignalException -- -- 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 throwTo 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-utils-4.2.2/Lambdabot/FixPrecedence.hs0000644000000000000000000003320712107664126017727 0ustar0000000000000000module 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-utils-4.2.2/Lambdabot/Url.hs0000644000000000000000000001464412107664126015771 0ustar0000000000000000{-# 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.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-utils-4.2.2/Lambdabot/MiniHTTP.hs0000644000000000000000000000661012107664126016615 0ustar0000000000000000-- | 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 [] = [] lambdabot-utils-4.2.2/Lambdabot/Error.hs0000644000000000000000000000751412107664126016316 0ustar0000000000000000-- | 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)