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)
import System.Random hiding (split,random,getStdRandom)
import System.IO
import qualified System.Time as T
concatWith :: [a]
-> [[a]]
-> [a]
concatWith glue xs = (concat . intersperse glue) xs
split :: Eq a => [a]
-> [a]
-> [[a]]
split glue xs = split' xs
where
split' [] = []
split' xs' = piece : split' (dropGlue rest)
where (piece, rest) = breakOnGlue glue xs'
dropGlue = drop (length glue)
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 (j1) (tail ys)
in fn (i1) s
breakOnGlue :: (Eq a) => [a]
-> [a]
-> ([a],[a])
breakOnGlue _ [] = ([],[])
breakOnGlue glue rest@(x:xs)
| glue `isPrefixOf` rest = ([], rest)
| otherwise = (x:piece, rest')
where (piece, rest') = breakOnGlue glue xs
snoc :: a
-> [a]
-> [a]
snoc x xs = xs ++ [x]
after :: String
-> String
-> String
after [] ys = dropWhile isSpace ys
after (_:_) [] = error "after: (:) [] case"
after (x:xs) (y:ys)
| x == y = after xs ys
| otherwise = error "after: /= case"
splitFirstWord :: String
-> (String, String)
splitFirstWord xs = (w, dropWhile isSpace xs')
where (w, xs') = break isSpace xs
firstWord :: String -> String
firstWord = takeWhile (not . isSpace)
debugStr :: (MonadIO m) => String -> m ()
debugStr = liftIO . putStr
debugStrLn :: (MonadIO m) => [Char] -> m ()
debugStrLn x = debugStr (x ++ "\n")
lowerCaseString :: String -> String
lowerCaseString = map toLower
upperCaseString :: String -> String
upperCaseString = map toUpper
lowerize :: String -> String
lowerize [] = []
lowerize (c:cs) = toLower c:cs
upperize :: String -> String
upperize [] = []
upperize (c:cs) = toUpper c:cs
quote :: String -> String
quote x = "\"" ++ x ++ "\""
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
listToMaybeWith :: ([a] -> b) -> [a] -> Maybe b
listToMaybeWith _ [] = Nothing
listToMaybeWith f xs = Just (f xs)
listToMaybeAll :: [a] -> Maybe [a]
listToMaybeAll = listToMaybeWith id
safeGetStdRandom :: (StdGen -> (a,StdGen)) -> IO a
safeGetStdRandom f = do
g <- getStdGen
let (x, g') = f g
setStdGen $! g'
return x
getRandItem :: (RandomGen g) =>
[a]
-> g
-> (a, g)
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 :: [a] -> IO a
stdGetRandItem = safeGetStdRandom . getRandItem
randomElem :: [a] -> IO a
randomElem = stdGetRandItem
random :: MonadIO m => [a] -> m a
random = liftIO . randomElem
dropSpace :: [Char] -> [Char]
dropSpace = let f = reverse . dropWhile isSpace in f . f
dropSpaceEnd :: [Char] -> [Char]
dropSpaceEnd = reverse . dropWhile isSpace . reverse
clean :: Char -> [Char]
clean x | x == '\CR' = []
| otherwise = [x]
showClean :: (Show a) => [a] -> String
showClean = concatWith " " . map (init . tail . show)
dropNL :: [Char] -> [Char]
dropNL = reverse . dropWhile (== '\n') . reverse
expandTab :: String -> String
expandTab [] = []
expandTab ('\t':xs) = ' ':' ':' ':' ':' ':' ':' ':' ':expandTab xs
expandTab (x:xs) = x : expandTab xs
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 :: 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 .) . (/=)
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)
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
forkIO $ killThread c1 >> killThread c2
return r
timeout :: Int -> IO a -> IO (Maybe a)
timeout n a = parIO (Just `fmap` a) (threadDelay n >> return Nothing)
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
choice :: (r -> Bool) -> (r -> a) -> (r -> a) -> (r -> a)
choice p f g x = if p x then f x else g x
addList :: (Ord k) => [(k,a)] -> M.Map k a -> M.Map k a
addList l m = M.union (M.fromList l) m
mapMaybeMap :: Ord k => (a -> Maybe b) -> M.Map k a -> M.Map k b
mapMaybeMap f = fmap fromJust . M.filter isJust . fmap f
insertUpd :: Ord k => (a -> a) -> k -> a -> M.Map k a -> M.Map k a
insertUpd f = M.insertWith (\_ -> f)
pprKeys :: (Show k) => M.Map k a -> String
pprKeys = showClean . M.keys
isLeft, isRight :: Either a b -> Bool
isLeft (Left _) = True
isLeft _ = False
isRight = not . isLeft
unEither :: Either a a -> a
unEither = either id id
io :: MonadIO m => IO a -> m a
io = liftIO
arePrefixesWithSpaceOf :: [String] -> String -> Bool
arePrefixesWithSpaceOf els str = any (flip isPrefixOf str) $ map (++" ") els
arePrefixesOf :: [String] -> String -> Bool
arePrefixesOf = flip (any . flip isPrefixOf)
showWidth :: Int
-> Int
-> 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)
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",
"You untyped fool!",
"My brain just exploded",
"I am sorry.","Sorry.",
"Maybe you made a typo?",
"Just try something else.",
"There are some things that I just don't know.",
":(",":(",
"","",""
]
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!"
]