{-# LANGUAGE CPP #-}
module Control.Monad.Loops
( module Control.Monad.Loops
) where
import Control.Monad
import Control.Exception
import Control.Concurrent
#ifndef base4
#define SomeException Exception
#endif
forkMapM :: (a -> IO b) -> [a] -> IO [Either SomeException b]
forkMapM f xs = do
mvars <- forM xs $ \x -> do
mvar <- newEmptyMVar
forkIO $ do
result <- handle (return . Left) $ do
y <- f x
return (Right y)
putMVar mvar result
return mvar
mapM takeMVar mvars
forkMapM_ :: (a -> IO b) -> [a] -> IO [Maybe SomeException]
forkMapM_ f xs = do
mvars <- forM xs $ \x -> do
mvar <- newEmptyMVar
forkIO $ do
let handleAny :: (SomeException -> IO a) -> IO a -> IO a
handleAny = handle
result <- handleAny (return . Just) $ do
f x
return Nothing
putMVar mvar result
return mvar
mapM takeMVar mvars
forkMapM__ :: (a -> IO b) -> [a] -> IO ()
forkMapM__ f xs = do
mvars <- forM xs $ \x -> do
mvar <- newEmptyMVar
forkIO $ do
let handleAny :: (SomeException -> IO a) -> IO a -> IO a
handleAny = handle
handleAny (\_ -> return ()) $ do
f x
return ()
putMVar mvar ()
return mvar
mapM_ takeMVar mvars
{-# SPECIALIZE whileM :: IO Bool -> IO a -> IO [a] #-}
{-# SPECIALIZE whileM' :: Monad m => m Bool -> m a -> m [a] #-}
{-# SPECIALIZE whileM' :: IO Bool -> IO a -> IO [a] #-}
{-# SPECIALIZE whileM_ :: IO Bool -> IO a -> IO () #-}
whileM :: Monad m => m Bool -> m a -> m [a]
whileM = whileM'
whileM' :: (Monad m, MonadPlus f) => m Bool -> m a -> m (f a)
whileM' p f = go
where go = do
x <- p
if x
then do
x <- f
xs <- go
return (return x `mplus` xs)
else return mzero
whileM_ :: (Monad m) => m Bool -> m a -> m ()
whileM_ p f = go
where go = do
x <- p
if x
then f >> go
else return ()
iterateWhile :: Monad m => (a -> Bool) -> m a -> m a
iterateWhile p = iterateUntil (not . p)
{-# SPECIALIZE iterateM_ :: (a -> IO a) -> a -> IO b #-}
iterateM_ :: Monad m => (a -> m a) -> a -> m b
iterateM_ f = g
where g x = f x >>= g
{-# SPECIALIZE untilM :: IO a -> IO Bool -> IO [a] #-}
{-# SPECIALIZE untilM' :: Monad m => m a -> m Bool -> m [a] #-}
{-# SPECIALIZE untilM' :: IO a -> IO Bool -> IO [a] #-}
{-# SPECIALIZE untilM_ :: IO a -> IO Bool -> IO () #-}
infixr 0 `untilM`
infixr 0 `untilM'`
infixr 0 `untilM_`
infixr 0 `iterateUntilM`
untilM :: Monad m => m a -> m Bool -> m [a]
untilM = untilM'
untilM' :: (Monad m, MonadPlus f) => m a -> m Bool -> m (f a)
f `untilM'` p = do
x <- f
xs <- whileM' (liftM not p) f
return (return x `mplus` xs)
untilM_ :: (Monad m) => m a -> m Bool -> m ()
f `untilM_` p = f >> whileM_ (liftM not p) f
iterateUntilM :: (Monad m) => (a -> Bool) -> (a -> m a) -> a -> m a
iterateUntilM p f v
| p v = return v
| otherwise = f v >>= iterateUntilM p f
iterateUntil :: Monad m => (a -> Bool) -> m a -> m a
iterateUntil p x = x >>= iterateUntilM p (const x)
{-# SPECIALIZE whileJust :: IO (Maybe a) -> (a -> IO b) -> IO [b] #-}
{-# SPECIALIZE whileJust' :: Monad m => m (Maybe a) -> (a -> m b) -> m [b] #-}
{-# SPECIALIZE whileJust' :: IO (Maybe a) -> (a -> IO b) -> IO [b] #-}
{-# SPECIALIZE whileJust_ :: IO (Maybe a) -> (a -> IO b) -> IO () #-}
whileJust :: Monad m => m (Maybe a) -> (a -> m b) -> m [b]
whileJust = whileJust'
whileJust' :: (Monad m, MonadPlus f) => m (Maybe a) -> (a -> m b) -> m (f b)
whileJust' p f = go
where go = do
x <- p
case x of
Nothing -> return mzero
Just x -> do
x <- f x
xs <- go
return (return x `mplus` xs)
whileJust_ :: (Monad m) => m (Maybe a) -> (a -> m b) -> m ()
whileJust_ p f = go
where go = do
x <- p
case x of
Nothing -> return ()
Just x -> do
f x
go
untilJust :: Monad m => m (Maybe a) -> m a
untilJust m = go
where
go = do
x <- m
case x of
Nothing -> go
Just x -> return x
{-# SPECIALIZE unfoldM :: IO (Maybe a) -> IO [a] #-}
{-# SPECIALIZE unfoldM' :: (Monad m) => m (Maybe a) -> m [a] #-}
{-# SPECIALIZE unfoldM' :: IO (Maybe a) -> IO [a] #-}
{-# SPECIALIZE unfoldM_ :: IO (Maybe a) -> IO () #-}
unfoldM :: (Monad m) => m (Maybe a) -> m [a]
unfoldM = unfoldM'
unfoldM' :: (Monad m, MonadPlus f) => m (Maybe a) -> m (f a)
unfoldM' m = whileJust' m return
unfoldM_ :: (Monad m) => m (Maybe a) -> m ()
unfoldM_ m = whileJust_ m return
unfoldWhileM :: Monad m => (a -> Bool) -> m a -> m [a]
unfoldWhileM p m = loop id
where
loop f = do
x <- m
if p x
then loop (f . (x:))
else return (f [])
unfoldWhileM' :: (Monad m, MonadPlus f) => (a -> Bool) -> m a -> m (f a)
unfoldWhileM' p m = loop mzero
where
loop xs = do
x <- m
if p x
then loop (xs `mplus` return x)
else return xs
{-# SPECIALIZE unfoldrM :: (a -> IO (Maybe (b,a))) -> a -> IO [b] #-}
{-# SPECIALIZE unfoldrM' :: (Monad m) => (a -> m (Maybe (b,a))) -> a -> m [b] #-}
{-# SPECIALIZE unfoldrM' :: (a -> IO (Maybe (b,a))) -> a -> IO [b] #-}
unfoldrM :: (Monad m) => (a -> m (Maybe (b,a))) -> a -> m [b]
unfoldrM = unfoldrM'
unfoldrM' :: (Monad m, MonadPlus f) => (a -> m (Maybe (b,a))) -> a -> m (f b)
unfoldrM' f = go
where go z = do
x <- f z
case x of
Nothing -> return mzero
Just (x, z') -> do
xs <- go z'
return (return x `mplus` xs)
{-# SPECIALIZE concatM :: [a -> IO a] -> (a -> IO a) #-}
concatM :: (Monad m) => [a -> m a] -> (a -> m a)
concatM fs = foldr (>=>) return fs
{-# SPECIALIZE andM :: [IO Bool] -> IO Bool #-}
{-# SPECIALIZE orM :: [IO Bool] -> IO Bool #-}
andM :: (Monad m) => [m Bool] -> m Bool
andM [] = return True
andM (p:ps) = do
q <- p
if q
then andM ps
else return False
orM :: (Monad m) => [m Bool] -> m Bool
orM [] = return False
orM (p:ps) = do
q <- p
if q
then return True
else orM ps
{-# SPECIALIZE anyPM :: [a -> IO Bool] -> (a -> IO Bool) #-}
{-# SPECIALIZE allPM :: [a -> IO Bool] -> (a -> IO Bool) #-}
anyPM :: (Monad m) => [a -> m Bool] -> (a -> m Bool)
anyPM [] _ = return False
anyPM (p:ps) x = do
q <- p x
if q
then return True
else anyPM ps x
allPM :: (Monad m) => [a -> m Bool] -> (a -> m Bool)
allPM [] _ = return True
allPM (p:ps) x = do
q <- p x
if q
then allPM ps x
else return False
{-# SPECIALIZE anyM :: (a -> IO Bool) -> [a] -> IO Bool #-}
{-# SPECIALIZE allM :: (a -> IO Bool) -> [a] -> IO Bool #-}
anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
anyM _ [] = return False
anyM p (x:xs) = do
q <- p x
if q
then return True
else anyM p xs
allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
allM _ [] = return True
allM p (x:xs) = do
q <- p x
if q
then allM p xs
else return False
takeWhileM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
takeWhileM _ [] = return []
takeWhileM p (x:xs) = do
q <- p x
if q
then (takeWhileM p xs) >>= (return . (:) x)
else return []
dropWhileM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
dropWhileM _ [] = return []
dropWhileM p (x:xs) = do
q <- p x
if q
then dropWhileM p xs
else return (x:xs)
trimM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
trimM p xs = do
xs <- dropWhileM p xs
rxs <- dropWhileM p (reverse xs)
return (reverse rxs)
firstM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a)
firstM _ [] = return Nothing
firstM p (x:xs) = do
q <- p x
if q
then return (Just x)
else firstM p xs
{-# INLINE minimaOnByM #-}
minimaOnByM :: Monad m => (a -> m b) -> (b -> b -> m Ordering) -> [a] -> m [a]
minimaOnByM _ _ [] = return []
minimaOnByM f cmp (x:xs) = do
fx<- f x
loop (x:) fx xs
where loop ms _ [] = return (ms [])
loop ms fm (x:xs) = do
fx <- f x
ord <- cmp fm fx
case ord of
LT -> loop ms fm xs
EQ -> loop (ms . (x:)) fm xs
GT -> loop (x:) fx xs
{-# INLINE maximaOnByM #-}
maximaOnByM :: Monad m => (a -> m b) -> (b -> b -> m Ordering) -> [a] -> m [a]
maximaOnByM f = minimaOnByM f . flip
minimaByM :: Monad m => (a -> a -> m Ordering) -> [a] -> m [a]
minimaByM = minimaOnByM return
maximaByM :: Monad m => (a -> a -> m Ordering) -> [a] -> m [a]
maximaByM = maximaOnByM return
minimaOnM :: (Monad m, Ord b) => (a -> m b) -> [a] -> m [a]
minimaOnM f = minimaOnByM f (\x y -> return (compare x y))
maximaOnM :: (Monad m, Ord b) => (a -> m b) -> [a] -> m [a]
maximaOnM f = maximaOnByM f (\x y -> return (compare x y))
{-# INLINE minimumOnByM #-}
minimumOnByM :: Monad m => (a -> m b) -> (b -> b -> m Ordering) -> [a] -> m (Maybe a)
minimumOnByM _ _ [] = return Nothing
minimumOnByM f cmp (x:xs) = do
fx <- f x
loop x fx xs
where loop m _ [] = return (Just m)
loop m fm (x:xs) = do
fx <- f x
ord <- cmp fm fx
case ord of
LT -> loop m fm xs
EQ -> loop m fm xs
GT -> loop x fx xs
{-# INLINE maximumOnByM #-}
maximumOnByM :: Monad m => (a -> m b) -> (b -> b -> m Ordering) -> [a] -> m (Maybe a)
maximumOnByM f = minimumOnByM f . flip
minimumByM :: Monad m => (a -> a -> m Ordering) -> [a] -> m (Maybe a)
minimumByM = minimumOnByM return
maximumByM :: Monad m => (a -> a -> m Ordering) -> [a] -> m (Maybe a)
maximumByM = maximumOnByM return
minimumOnM :: (Monad m, Ord b) => (a -> m b) -> [a] -> m (Maybe a)
minimumOnM f = minimumOnByM f (\x y -> return (compare x y))
maximumOnM :: (Monad m, Ord b) => (a -> m b) -> [a] -> m (Maybe a)
maximumOnM f = maximumOnByM f (\x y -> return (compare x y))