├── .gitignore ├── LICENSE ├── Setup.lhs ├── Tests └── test-monad-loops.hs ├── monad-loops.cabal └── src └── Control └── Monad └── Loops.hs /.gitignore: -------------------------------------------------------------------------------- 1 | ############## 2 | # Global/OSX # 3 | ############## 4 | 5 | .DS_Store 6 | Icon? 7 | 8 | # Thumbnails 9 | ._* 10 | 11 | # Files that might appear on external disk 12 | .Spotlight-V100 13 | .Trashes 14 | 15 | 16 | ########### 17 | # Haskell # 18 | ########### 19 | 20 | dist 21 | *.o 22 | *.hi 23 | *.chi 24 | *.chs.h 25 | 26 | 27 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | All rights reserved. 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions 5 | are met: 6 | 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 14 | 3. Neither the name of the author nor the names of his contributors 15 | may be used to endorse or promote products derived from this software 16 | without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 19 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 20 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 21 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 22 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 26 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 27 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 28 | POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | 3 | > import Distribution.Simple 4 | > main = defaultMain 5 | 6 | -------------------------------------------------------------------------------- /Tests/test-monad-loops.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Main (main) where 4 | 5 | import Test.Tasty 6 | import Test.Tasty.HUnit 7 | 8 | import Control.Monad.Loops 9 | 10 | testTakeWhileM :: Assertion 11 | testTakeWhileM = do 12 | actual <- takeWhileM (return . id) [True, True, False] 13 | let expected = takeWhile ( id) [True, True, False] 14 | actual @?= expected 15 | 16 | testTakeWhileMEdgeCase1 :: Assertion 17 | testTakeWhileMEdgeCase1 = do 18 | actual <- takeWhileM (return . id) [] 19 | let expected = takeWhile ( id) [] 20 | actual @?= expected 21 | 22 | testTakeWhileMEdgeCase2 :: Assertion 23 | testTakeWhileMEdgeCase2 = do 24 | actual <- takeWhileM (return . id) [False, False, False] 25 | let expected = takeWhile ( id) [False, False, False] 26 | actual @?= expected 27 | 28 | testTakeWhileMEdgeCase3 :: Assertion 29 | testTakeWhileMEdgeCase3 = do 30 | let emptyList :: [Int] = [] 31 | actual <- takeWhileM (const undefined) emptyList 32 | let expected = takeWhile (const undefined) emptyList 33 | actual @?= expected 34 | 35 | tests :: TestTree 36 | tests = testGroup "unit tests" 37 | [ testCase 38 | "Testing `takeWhileM`" 39 | testTakeWhileM 40 | , testCase 41 | "Testing `takeWhileM (edge case 1)`" 42 | testTakeWhileMEdgeCase1 43 | , testCase 44 | "Testing `takeWhileM (edge case 2)`" 45 | testTakeWhileMEdgeCase2 46 | , testCase 47 | "Testing `takeWhileM (edge case 3)`" 48 | testTakeWhileMEdgeCase3 49 | ] 50 | 51 | main :: IO () 52 | main = defaultMain tests -------------------------------------------------------------------------------- /monad-loops.cabal: -------------------------------------------------------------------------------- 1 | name: monad-loops 2 | version: 0.4.2.1 3 | stability: provisional 4 | license: PublicDomain 5 | 6 | cabal-version: >= 1.8 7 | build-type: Simple 8 | 9 | author: James Cook 10 | maintainer: James Cook 11 | homepage: https://github.com/mokus0/monad-loops 12 | 13 | category: Control 14 | synopsis: Monadic loops 15 | description: Some useful control operators for looping. 16 | . 17 | New in 0.4: STM loop operators have been split into a 18 | new package instead of being conditionally-built. 19 | . 20 | New in 0.3.2.0: various functions for traversing lists and 21 | computing minima/maxima using arbitrary procedures to compare 22 | or score the elements. 23 | 24 | source-repository head 25 | type: git 26 | location: git://github.com/mokus0/monad-loops.git 27 | 28 | Flag base4 29 | Description: Build using base >= 4 30 | Default: True 31 | 32 | Library 33 | hs-source-dirs: src 34 | if impl(ghc >= 7) 35 | ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing 36 | exposed-modules: Control.Monad.Loops 37 | if flag(base4) 38 | cpp-options: -Dbase4 39 | build-depends: base >= 4 && < 5 40 | else 41 | build-depends: base >= 2 && < 4 42 | 43 | Test-Suite test-monad-loops 44 | type: exitcode-stdio-1.0 45 | main-is: Tests/test-monad-loops.hs 46 | if flag(base4) 47 | cpp-options: -Dbase4 48 | build-depends: base >= 4 && < 5, tasty, tasty-hunit, monad-loops 49 | else 50 | build-depends: base >= 2 && < 4, tasty, tasty-hunit, monad-loops -------------------------------------------------------------------------------- /src/Control/Monad/Loops.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- |A collection of loop operators for use in monads (mostly in stateful ones). 4 | -- 5 | -- There is a general naming pattern for many of these: 6 | -- Functions with names ending in _ discard the results of the loop body 7 | -- as in the standard Prelude 'mapM' functions. 8 | -- 9 | -- Functions with names ending in ' collect their results into 'MonadPlus' 10 | -- containers. Note that any short-circuit effect that those types' 11 | -- 'MonadPlus' instances may provide in a lazy context (such as the instance 12 | -- for 'Maybe') will _not_ cause execution to short-circuit in these loops. 13 | -- 14 | -- Functions with names ending in neither of those will generally return 15 | -- just plain old lists. 16 | 17 | module Control.Monad.Loops 18 | ( module Control.Monad.Loops 19 | ) where 20 | 21 | import Control.Monad 22 | 23 | import Control.Exception 24 | import Control.Concurrent 25 | 26 | #ifndef base4 27 | #define SomeException Exception 28 | #endif 29 | 30 | -- possibly-useful addition? : 31 | -- concatMapM :: (Monad m, Traversable f, Monoid w) => (a -> m w) -> (f a) -> m w 32 | 33 | -- would also like to implement an "interleavable" version of forkMapM (probably 34 | -- using something other than a list in the return) that can effectively handle 35 | -- very large or even infinite input lists. 36 | 37 | -- |Like 'mapM', but run all the actions in parallel threads, collecting up 38 | -- the results and returning them all. Does not return until all actions finish. 39 | forkMapM :: (a -> IO b) -> [a] -> IO [Either SomeException b] 40 | forkMapM f xs = do 41 | mvars <- forM xs $ \x -> do 42 | mvar <- newEmptyMVar 43 | forkIO $ do 44 | result <- handle (return . Left) $ do 45 | y <- f x 46 | return (Right y) 47 | putMVar mvar result 48 | return mvar 49 | 50 | mapM takeMVar mvars 51 | 52 | -- | like 'forkMapM' but without bothering to keep the return values 53 | forkMapM_ :: (a -> IO b) -> [a] -> IO [Maybe SomeException] 54 | forkMapM_ f xs = do 55 | mvars <- forM xs $ \x -> do 56 | mvar <- newEmptyMVar 57 | forkIO $ do 58 | -- in base >=4, need to nail down the type of 'handle' 59 | let handleAny :: (SomeException -> IO a) -> IO a -> IO a 60 | handleAny = handle 61 | result <- handleAny (return . Just) $ do 62 | f x 63 | return Nothing 64 | putMVar mvar result 65 | return mvar 66 | 67 | mapM takeMVar mvars 68 | 69 | -- | like 'forkMapM_' but not even bothering to track success or failure 70 | -- of the child threads. Still waits for them all though. 71 | forkMapM__ :: (a -> IO b) -> [a] -> IO () 72 | forkMapM__ f xs = do 73 | mvars <- forM xs $ \x -> do 74 | mvar <- newEmptyMVar 75 | forkIO $ do 76 | -- in base >=4, need to nail down the type of 'handle' 77 | let handleAny :: (SomeException -> IO a) -> IO a -> IO a 78 | handleAny = handle 79 | handleAny (\_ -> return ()) $ do 80 | f x 81 | return () 82 | putMVar mvar () 83 | return mvar 84 | 85 | mapM_ takeMVar mvars 86 | 87 | {-# SPECIALIZE whileM :: IO Bool -> IO a -> IO [a] #-} 88 | {-# SPECIALIZE whileM' :: Monad m => m Bool -> m a -> m [a] #-} 89 | {-# SPECIALIZE whileM' :: IO Bool -> IO a -> IO [a] #-} 90 | {-# SPECIALIZE whileM_ :: IO Bool -> IO a -> IO () #-} 91 | 92 | -- |Execute an action repeatedly as long as the given boolean expression 93 | -- returns True. The condition is evaluated before the loop body. 94 | -- Collects the results into a list. 95 | whileM :: Monad m => m Bool -> m a -> m [a] 96 | whileM = whileM' 97 | 98 | -- |Execute an action repeatedly as long as the given boolean expression 99 | -- returns True. The condition is evaluated before the loop body. 100 | -- Collects the results into an arbitrary 'MonadPlus' value. 101 | whileM' :: (Monad m, MonadPlus f) => m Bool -> m a -> m (f a) 102 | whileM' p f = go 103 | where go = do 104 | x <- p 105 | if x 106 | then do 107 | x <- f 108 | xs <- go 109 | return (return x `mplus` xs) 110 | else return mzero 111 | 112 | -- |Execute an action repeatedly as long as the given boolean expression 113 | -- returns True. The condition is evaluated before the loop body. 114 | -- Discards results. 115 | whileM_ :: (Monad m) => m Bool -> m a -> m () 116 | whileM_ p f = go 117 | where go = do 118 | x <- p 119 | if x 120 | then f >> go 121 | else return () 122 | 123 | -- |Execute an action repeatedly until its result fails to satisfy a predicate, 124 | -- and return that result (discarding all others). 125 | iterateWhile :: Monad m => (a -> Bool) -> m a -> m a 126 | iterateWhile p = iterateUntil (not . p) 127 | 128 | {-# SPECIALIZE iterateM_ :: (a -> IO a) -> a -> IO b #-} 129 | -- |Execute an action forever, feeding the result of each execution as the 130 | -- input to the next. 131 | iterateM_ :: Monad m => (a -> m a) -> a -> m b 132 | iterateM_ f = g 133 | where g x = f x >>= g 134 | 135 | {-# SPECIALIZE untilM :: IO a -> IO Bool -> IO [a] #-} 136 | {-# SPECIALIZE untilM' :: Monad m => m a -> m Bool -> m [a] #-} 137 | {-# SPECIALIZE untilM' :: IO a -> IO Bool -> IO [a] #-} 138 | {-# SPECIALIZE untilM_ :: IO a -> IO Bool -> IO () #-} 139 | 140 | infixr 0 `untilM` 141 | infixr 0 `untilM'` 142 | infixr 0 `untilM_` 143 | infixr 0 `iterateUntilM` 144 | 145 | -- |Execute an action repeatedly until the condition expression returns True. 146 | -- The condition is evaluated after the loop body. Collects results into a list. 147 | -- Parameters are arranged for infix usage. eg. do {...} `untilM_` ... 148 | untilM :: Monad m => m a -> m Bool -> m [a] 149 | untilM = untilM' 150 | 151 | -- |Execute an action repeatedly until the condition expression returns True. 152 | -- The condition is evaluated after the loop body. Collects results into a 153 | -- "MonadPlus" value. 154 | -- Parameters are arranged for infix usage. eg. do {...} `untilM_` ... 155 | untilM' :: (Monad m, MonadPlus f) => m a -> m Bool -> m (f a) 156 | f `untilM'` p = do 157 | x <- f 158 | xs <- whileM' (liftM not p) f 159 | return (return x `mplus` xs) 160 | 161 | -- |Execute an action repeatedly until the condition expression returns True. 162 | -- The condition is evaluated after the loop body. Discards results. 163 | -- Parameters are arranged for infix usage. eg. do {...} `untilM_` ... 164 | untilM_ :: (Monad m) => m a -> m Bool -> m () 165 | f `untilM_` p = f >> whileM_ (liftM not p) f 166 | 167 | 168 | -- | Analogue of @('Prelude.until')@ 169 | -- Yields the result of applying f until p holds. 170 | iterateUntilM :: (Monad m) => (a -> Bool) -> (a -> m a) -> a -> m a 171 | iterateUntilM p f v 172 | | p v = return v 173 | | otherwise = f v >>= iterateUntilM p f 174 | 175 | -- |Execute an action repeatedly until its result satisfies a predicate, 176 | -- and return that result (discarding all others). 177 | iterateUntil :: Monad m => (a -> Bool) -> m a -> m a 178 | iterateUntil p x = x >>= iterateUntilM p (const x) 179 | 180 | {-# SPECIALIZE whileJust :: IO (Maybe a) -> (a -> IO b) -> IO [b] #-} 181 | {-# SPECIALIZE whileJust' :: Monad m => m (Maybe a) -> (a -> m b) -> m [b] #-} 182 | {-# SPECIALIZE whileJust' :: IO (Maybe a) -> (a -> IO b) -> IO [b] #-} 183 | {-# SPECIALIZE whileJust_ :: IO (Maybe a) -> (a -> IO b) -> IO () #-} 184 | 185 | -- |As long as the supplied "Maybe" expression returns "Just _", the loop 186 | -- body will be called and passed the value contained in the 'Just'. Results 187 | -- are collected into a list. 188 | whileJust :: Monad m => m (Maybe a) -> (a -> m b) -> m [b] 189 | whileJust = whileJust' 190 | 191 | -- |As long as the supplied "Maybe" expression returns "Just _", the loop 192 | -- body will be called and passed the value contained in the 'Just'. Results 193 | -- are collected into an arbitrary MonadPlus container. 194 | whileJust' :: (Monad m, MonadPlus f) => m (Maybe a) -> (a -> m b) -> m (f b) 195 | whileJust' p f = go 196 | where go = do 197 | x <- p 198 | case x of 199 | Nothing -> return mzero 200 | Just x -> do 201 | x <- f x 202 | xs <- go 203 | return (return x `mplus` xs) 204 | 205 | -- |As long as the supplied "Maybe" expression returns "Just _", the loop 206 | -- body will be called and passed the value contained in the 'Just'. Results 207 | -- are discarded. 208 | whileJust_ :: (Monad m) => m (Maybe a) -> (a -> m b) -> m () 209 | whileJust_ p f = go 210 | where go = do 211 | x <- p 212 | case x of 213 | Nothing -> return () 214 | Just x -> do 215 | f x 216 | go 217 | 218 | -- |Run the supplied "Maybe" computation repeatedly until it returns a 219 | -- value. Returns that value. 220 | untilJust :: Monad m => m (Maybe a) -> m a 221 | untilJust m = go 222 | where 223 | go = do 224 | x <- m 225 | case x of 226 | Nothing -> go 227 | Just x -> return x 228 | 229 | {-# SPECIALIZE unfoldM :: IO (Maybe a) -> IO [a] #-} 230 | {-# SPECIALIZE unfoldM' :: (Monad m) => m (Maybe a) -> m [a] #-} 231 | {-# SPECIALIZE unfoldM' :: IO (Maybe a) -> IO [a] #-} 232 | {-# SPECIALIZE unfoldM_ :: IO (Maybe a) -> IO () #-} 233 | 234 | -- |The supplied "Maybe" expression will be repeatedly called until it 235 | -- returns 'Nothing'. All values returned are collected into a list. 236 | unfoldM :: (Monad m) => m (Maybe a) -> m [a] 237 | unfoldM = unfoldM' 238 | 239 | -- |The supplied "Maybe" expression will be repeatedly called until it 240 | -- returns 'Nothing'. All values returned are collected into an arbitrary 241 | -- 'MonadPlus' thing. 242 | unfoldM' :: (Monad m, MonadPlus f) => m (Maybe a) -> m (f a) 243 | unfoldM' m = whileJust' m return 244 | 245 | -- |The supplied "Maybe" expression will be repeatedly called until it 246 | -- returns 'Nothing'. All values returned are discarded. 247 | unfoldM_ :: (Monad m) => m (Maybe a) -> m () 248 | unfoldM_ m = whileJust_ m return 249 | 250 | -- |Repeatedly evaluates the second argument until the value satisfies 251 | -- the given predicate, and returns a list of all values that satisfied the 252 | -- predicate. Discards the final one (which failed the predicate). 253 | unfoldWhileM :: Monad m => (a -> Bool) -> m a -> m [a] 254 | unfoldWhileM p m = loop id 255 | where 256 | loop f = do 257 | x <- m 258 | if p x 259 | then loop (f . (x:)) 260 | else return (f []) 261 | 262 | -- |Repeatedly evaluates the second argument until the value satisfies 263 | -- the given predicate, and returns a 'MonadPlus' collection of all values 264 | -- that satisfied the predicate. Discards the final one (which failed the predicate). 265 | unfoldWhileM' :: (Monad m, MonadPlus f) => (a -> Bool) -> m a -> m (f a) 266 | unfoldWhileM' p m = loop mzero 267 | where 268 | loop xs = do 269 | x <- m 270 | if p x 271 | then loop (xs `mplus` return x) 272 | else return xs 273 | 274 | {-# SPECIALIZE unfoldrM :: (a -> IO (Maybe (b,a))) -> a -> IO [b] #-} 275 | {-# SPECIALIZE unfoldrM' :: (Monad m) => (a -> m (Maybe (b,a))) -> a -> m [b] #-} 276 | {-# SPECIALIZE unfoldrM' :: (a -> IO (Maybe (b,a))) -> a -> IO [b] #-} 277 | 278 | -- |See 'Data.List.unfoldr'. This is a monad-friendly version of that. 279 | unfoldrM :: (Monad m) => (a -> m (Maybe (b,a))) -> a -> m [b] 280 | unfoldrM = unfoldrM' 281 | 282 | -- |See 'Data.List.unfoldr'. This is a monad-friendly version of that, with a 283 | -- twist. Rather than returning a list, it returns any MonadPlus type of your 284 | -- choice. 285 | unfoldrM' :: (Monad m, MonadPlus f) => (a -> m (Maybe (b,a))) -> a -> m (f b) 286 | unfoldrM' f = go 287 | where go z = do 288 | x <- f z 289 | case x of 290 | Nothing -> return mzero 291 | Just (x, z') -> do 292 | xs <- go z' 293 | return (return x `mplus` xs) 294 | 295 | {-# SPECIALIZE concatM :: [a -> IO a] -> (a -> IO a) #-} 296 | 297 | -- |Compose a list of monadic actions into one action. Composes using 298 | -- ('>=>') - that is, the output of each action is fed to the input of 299 | -- the one after it in the list. 300 | concatM :: (Monad m) => [a -> m a] -> (a -> m a) 301 | concatM fs = foldr (>=>) return fs 302 | 303 | {-# SPECIALIZE andM :: [IO Bool] -> IO Bool #-} 304 | {-# SPECIALIZE orM :: [IO Bool] -> IO Bool #-} 305 | 306 | -- |short-circuit 'and' for values of type Monad m => m Bool 307 | andM :: (Monad m) => [m Bool] -> m Bool 308 | andM [] = return True 309 | andM (p:ps) = do 310 | q <- p 311 | if q 312 | then andM ps 313 | else return False 314 | 315 | -- |short-circuit 'or' for values of type Monad m => m Bool 316 | orM :: (Monad m) => [m Bool] -> m Bool 317 | orM [] = return False 318 | orM (p:ps) = do 319 | q <- p 320 | if q 321 | then return True 322 | else orM ps 323 | 324 | {-# SPECIALIZE anyPM :: [a -> IO Bool] -> (a -> IO Bool) #-} 325 | {-# SPECIALIZE allPM :: [a -> IO Bool] -> (a -> IO Bool) #-} 326 | 327 | -- |short-circuit 'any' with a list of \"monadic predicates\". Tests the 328 | -- value presented against each predicate in turn until one passes, then 329 | -- returns True without any further processing. If none passes, returns False. 330 | anyPM :: (Monad m) => [a -> m Bool] -> (a -> m Bool) 331 | anyPM [] _ = return False 332 | anyPM (p:ps) x = do 333 | q <- p x 334 | if q 335 | then return True 336 | else anyPM ps x 337 | 338 | -- |short-circuit 'all' with a list of \"monadic predicates\". Tests the value 339 | -- presented against each predicate in turn until one fails, then returns False. 340 | -- if none fail, returns True. 341 | allPM :: (Monad m) => [a -> m Bool] -> (a -> m Bool) 342 | allPM [] _ = return True 343 | allPM (p:ps) x = do 344 | q <- p x 345 | if q 346 | then allPM ps x 347 | else return False 348 | 349 | {-# SPECIALIZE anyM :: (a -> IO Bool) -> [a] -> IO Bool #-} 350 | {-# SPECIALIZE allM :: (a -> IO Bool) -> [a] -> IO Bool #-} 351 | 352 | -- |short-circuit 'any' with a \"monadic predicate\". 353 | anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool 354 | anyM _ [] = return False 355 | anyM p (x:xs) = do 356 | q <- p x 357 | if q 358 | then return True 359 | else anyM p xs 360 | 361 | -- |short-circuit 'all' with a \"monadic predicate\". 362 | allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool 363 | allM _ [] = return True 364 | allM p (x:xs) = do 365 | q <- p x 366 | if q 367 | then allM p xs 368 | else return False 369 | 370 | -- | Monadic 'takeWhile'. 371 | takeWhileM :: (Monad m) => (a -> m Bool) -> [a] -> m [a] 372 | takeWhileM _ [] = return [] 373 | takeWhileM p (x:xs) = do 374 | q <- p x 375 | if q 376 | then (takeWhileM p xs) >>= (return . (:) x) 377 | else return [] 378 | 379 | -- | Monadic 'dropWhile'. 380 | dropWhileM :: (Monad m) => (a -> m Bool) -> [a] -> m [a] 381 | dropWhileM _ [] = return [] 382 | dropWhileM p (x:xs) = do 383 | q <- p x 384 | if q 385 | then dropWhileM p xs 386 | else return (x:xs) 387 | 388 | -- |like 'dropWhileM' but trims both ends of the list. 389 | trimM :: (Monad m) => (a -> m Bool) -> [a] -> m [a] 390 | trimM p xs = do 391 | xs <- dropWhileM p xs 392 | rxs <- dropWhileM p (reverse xs) 393 | return (reverse rxs) 394 | 395 | -- |return the first value from a list, if any, satisfying the given predicate. 396 | firstM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a) 397 | firstM _ [] = return Nothing 398 | firstM p (x:xs) = do 399 | q <- p x 400 | if q 401 | then return (Just x) 402 | else firstM p xs 403 | 404 | {-# INLINE minimaOnByM #-} 405 | minimaOnByM :: Monad m => (a -> m b) -> (b -> b -> m Ordering) -> [a] -> m [a] 406 | minimaOnByM _ _ [] = return [] 407 | minimaOnByM f cmp (x:xs) = do 408 | fx<- f x 409 | loop (x:) fx xs 410 | where loop ms _ [] = return (ms []) 411 | loop ms fm (x:xs) = do 412 | fx <- f x 413 | ord <- cmp fm fx 414 | case ord of 415 | LT -> loop ms fm xs 416 | EQ -> loop (ms . (x:)) fm xs 417 | GT -> loop (x:) fx xs 418 | 419 | {-# INLINE maximaOnByM #-} 420 | maximaOnByM :: Monad m => (a -> m b) -> (b -> b -> m Ordering) -> [a] -> m [a] 421 | maximaOnByM f = minimaOnByM f . flip 422 | 423 | minimaByM :: Monad m => (a -> a -> m Ordering) -> [a] -> m [a] 424 | minimaByM = minimaOnByM return 425 | 426 | maximaByM :: Monad m => (a -> a -> m Ordering) -> [a] -> m [a] 427 | maximaByM = maximaOnByM return 428 | 429 | minimaOnM :: (Monad m, Ord b) => (a -> m b) -> [a] -> m [a] 430 | minimaOnM f = minimaOnByM f (\x y -> return (compare x y)) 431 | 432 | maximaOnM :: (Monad m, Ord b) => (a -> m b) -> [a] -> m [a] 433 | maximaOnM f = maximaOnByM f (\x y -> return (compare x y)) 434 | 435 | {-# INLINE minimumOnByM #-} 436 | minimumOnByM :: Monad m => (a -> m b) -> (b -> b -> m Ordering) -> [a] -> m (Maybe a) 437 | minimumOnByM _ _ [] = return Nothing 438 | minimumOnByM f cmp (x:xs) = do 439 | fx <- f x 440 | loop x fx xs 441 | where loop m _ [] = return (Just m) 442 | loop m fm (x:xs) = do 443 | fx <- f x 444 | ord <- cmp fm fx 445 | case ord of 446 | LT -> loop m fm xs 447 | EQ -> loop m fm xs 448 | GT -> loop x fx xs 449 | 450 | {-# INLINE maximumOnByM #-} 451 | maximumOnByM :: Monad m => (a -> m b) -> (b -> b -> m Ordering) -> [a] -> m (Maybe a) 452 | maximumOnByM f = minimumOnByM f . flip 453 | 454 | minimumByM :: Monad m => (a -> a -> m Ordering) -> [a] -> m (Maybe a) 455 | minimumByM = minimumOnByM return 456 | 457 | maximumByM :: Monad m => (a -> a -> m Ordering) -> [a] -> m (Maybe a) 458 | maximumByM = maximumOnByM return 459 | 460 | minimumOnM :: (Monad m, Ord b) => (a -> m b) -> [a] -> m (Maybe a) 461 | minimumOnM f = minimumOnByM f (\x y -> return (compare x y)) 462 | 463 | maximumOnM :: (Monad m, Ord b) => (a -> m b) -> [a] -> m (Maybe a) 464 | maximumOnM f = maximumOnByM f (\x y -> return (compare x y)) 465 | --------------------------------------------------------------------------------