control-monad-loop-0.1/0000755000000000000000000000000011776226650013277 5ustar0000000000000000control-monad-loop-0.1/LICENSE0000644000000000000000000000276211776226650014313 0ustar0000000000000000Copyright (c) 2012, Joseph Adams All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Joseph Adams nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. control-monad-loop-0.1/Setup.hs0000644000000000000000000000005611776226650014734 0ustar0000000000000000import Distribution.Simple main = defaultMain control-monad-loop-0.1/control-monad-loop.cabal0000644000000000000000000000212211776226650020003 0ustar0000000000000000name: control-monad-loop version: 0.1 synopsis: Simple monad transformer for imperative-style loops description: A library of looping constructs with @continue@ and @exit@ control flow statements. homepage: https://github.com/joeyadams/haskell-control-monad-loop bug-reports: https://github.com/joeyadams/haskell-control-monad-loop/issues license: BSD3 license-file: LICENSE author: Joey Adams maintainer: joeyadams3.14159@gmail.com copyright: Copyright (c) Joseph Adams 2012 category: Control build-type: Simple cabal-version: >=1.8 extra-source-files: test/leak.hs test/liftLocal.hs test/lift-continue.hs test/recycled-numbers.hs source-repository head type: git location: git://github.com/joeyadams/haskell-control-monad-loop library exposed-modules: Control.Monad.Trans.Loop build-depends : base >= 4 && < 5 , transformers , transformers-base ghc-options: -Wall -fwarn-tabs control-monad-loop-0.1/Control/0000755000000000000000000000000011776226650014717 5ustar0000000000000000control-monad-loop-0.1/Control/Monad/0000755000000000000000000000000011776226650015755 5ustar0000000000000000control-monad-loop-0.1/Control/Monad/Trans/0000755000000000000000000000000011776226650017044 5ustar0000000000000000control-monad-loop-0.1/Control/Monad/Trans/Loop.hs0000644000000000000000000001363511776226650020321 0ustar0000000000000000-- | -- Module : Control.Monad.Trans.Loop -- Copyright : (c) Joseph Adams 2012 -- License : BSD3 -- Maintainer : joeyadams3.14159@gmail.com -- {-# LANGUAGE Rank2Types #-} -- Needed for the MonadBase instance {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} module Control.Monad.Trans.Loop ( -- * The LoopT monad transformer LoopT(..), stepLoopT, -- * continue and exit continue, exit, continueWith, exitWith, -- * Looping constructs foreach, while, doWhile, once, repeatLoopT, iterateLoopT, -- * Lifting other operations liftLocalLoopT, ) where import Control.Applicative (Applicative(pure, (<*>))) import Control.Monad.Base (MonadBase(liftBase), liftBaseDefault) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Trans.Class (MonadTrans(lift)) -- | 'LoopT' is a monad transformer for the loop body. It provides two -- capabilities: -- -- * 'continue' to the next iteration. -- -- * 'exit' the whole loop. newtype LoopT c e m a = LoopT { runLoopT :: forall r. -- This universal quantification forces the -- LoopT computation to call one of the -- following continuations. (c -> m r) -- continue -> (e -> m r) -- exit -> (a -> m r) -- return a value -> m r } instance Functor (LoopT c e m) where fmap f m = LoopT $ \next fin cont -> runLoopT m next fin (cont . f) instance Applicative (LoopT c e m) where pure a = LoopT $ \_ _ cont -> cont a f1 <*> f2 = LoopT $ \next fin cont -> runLoopT f1 next fin $ \f -> runLoopT f2 next fin (cont . f) instance Monad (LoopT c e m) where return a = LoopT $ \_ _ cont -> cont a m >>= k = LoopT $ \next fin cont -> runLoopT m next fin $ \a -> runLoopT (k a) next fin cont instance MonadTrans (LoopT c e) where lift m = LoopT $ \_ _ cont -> m >>= cont instance MonadIO m => MonadIO (LoopT c e m) where liftIO = lift . liftIO instance MonadBase b m => MonadBase b (LoopT c e m) where liftBase = liftBaseDefault -- | Call a loop body, passing it a continuation for the next iteration. -- This can be used to construct custom looping constructs. For example, -- here is the definition of 'foreach': -- -- >foreach list body = loop list -- > where loop [] = return () -- > loop (x:xs) = stepLoopT (body x) (\_ -> loop xs) stepLoopT :: Monad m => LoopT c e m c -> (c -> m e) -> m e stepLoopT body next = runLoopT body next return next ------------------------------------------------------------------------ -- continue and exit -- | Skip the rest of the loop body and go to the next iteration. continue :: LoopT () e m a continue = continueWith () -- | Break out of the loop entirely. exit :: LoopT c () m a exit = exitWith () -- | Like 'continue', but return a value from the loop body. continueWith :: c -> LoopT c e m a continueWith c = LoopT $ \next _ _ -> next c -- | Like 'exit', but return a value from the loop as a whole. -- See the documentation of 'iterateLoopT' for an example. exitWith :: e -> LoopT c e m a exitWith e = LoopT $ \_ fin _ -> fin e ------------------------------------------------------------------------ -- Looping constructs -- | Call the loop body with each item in the list. -- -- If you do not need to 'continue' or 'exit' the loop, consider using -- 'Control.Monad.forM_' instead. foreach :: Monad m => [a] -> (a -> LoopT c () m c) -> m () foreach list body = loop list where loop [] = return () loop (x:xs) = stepLoopT (body x) (\_ -> loop xs) -- | Repeat the loop body while the predicate holds. Like a @while@ loop in C, -- the condition is tested first. while :: Monad m => m Bool -> LoopT c () m c -> m () while cond body = loop where loop = do b <- cond if b then stepLoopT body (\_ -> loop) else return () -- | Like a @do while@ loop in C, where the condition is tested after -- the loop body. -- -- 'doWhile' returns the result of the last iteration. This is possible -- because, unlike 'foreach' and 'while', the loop body is guaranteed to be -- executed at least once. doWhile :: Monad m => LoopT a a m a -> m Bool -> m a doWhile body cond = loop where loop = stepLoopT body $ \a -> do b <- cond if b then loop else return a -- | Execute the loop body once. This is a convenient way to introduce early -- exit support to a block of code. -- -- 'continue' and 'exit' do the same thing inside of 'once'. once :: Monad m => LoopT a a m a -> m a once body = runLoopT body return return return -- | Execute the loop body again and again. The only way to exit 'repeatLoopT' -- is to call 'exit' or 'exitWith'. repeatLoopT :: Monad m => LoopT c e m a -> m e repeatLoopT body = loop where loop = runLoopT body (\_ -> loop) return (\_ -> loop) -- | Call the loop body again and again, passing it the result of the previous -- iteration each time around. The only way to exit 'iterateLoopT' is to call -- 'exit' or 'exitWith'. -- -- Example: -- -- >count :: Int -> IO Int -- >count n = iterateLoopT 0 $ \i -> -- > if i < n -- > then do -- > lift $ print i -- > return $ i+1 -- > else exitWith i iterateLoopT :: Monad m => c -> (c -> LoopT c e m c) -> m e iterateLoopT z body = loop z where loop c = stepLoopT (body c) loop ------------------------------------------------------------------------ -- Lifting other operations -- | Lift a function like 'Control.Monad.Trans.Reader.local' or -- 'Control.Exception.mask_'. liftLocalLoopT :: Monad m => (forall a. m a -> m a) -> LoopT c e m b -> LoopT c e m b liftLocalLoopT f cb = LoopT $ \next fin cont -> do m <- f $ runLoopT cb (return . next) (return . fin) (return . cont) m control-monad-loop-0.1/test/0000755000000000000000000000000011776226650014256 5ustar0000000000000000control-monad-loop-0.1/test/leak.hs0000644000000000000000000000117311776226650015530 0ustar0000000000000000-- Make sure basic loops don't leak memory import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Loop import Control.Monad.Trans.State.Strict import Data.Int (Int64) count :: Int64 -> IO Int64 count n = iterateLoopT 0 $ \i -> if i < n then return $! i+1 else exitWith i sumLoop :: [Int64] -> Int64 sumLoop list = flip execState 0 $ foreach list $ \i -> do when (i == 10000000) exit lift $ modify' (+i) where modify' f = do x <- get put $! f x main :: IO () main = do count 100000000 >>= print print $ sumLoop [1..10000000] + 10000000 control-monad-loop-0.1/test/recycled-numbers.hs0000644000000000000000000000442011776226650020055 0ustar0000000000000000-- This solves Google Code Jam 2012 Qualification Problem C "Recycled Numbers" [1]. -- The problem is: given a range of numbers with the same number of digits, -- count how many pairs of them are the same modulo rotation of digits. -- -- [1]: http://code.google.com/codejam/contest/1460488/dashboard#s=p2 {-# LANGUAGE ScopedTypeVariables #-} import Control.Monad.Trans.Loop import Control.Applicative ((<$>)) import Control.Monad import Control.Monad.ST import Control.Monad.Trans.Class import Data.Array.ST import Data.STRef recycledNumbers :: (Int, Int) -> Int recycledNumbers (lb, ub) | not (1 <= lb && lb <= ub && factor == rotateFactor ub) = error "recycledNumbers: invalid bounds" | otherwise = runST $ do bmp <- newArray (lb, ub) False :: ST s (STUArray s Int Bool) total <- newSTRef 0 forM_ [lb..ub] $ \i -> do count <- newSTRef 0 foreach (iterate rotate i) $ \j -> do when (not $ j >= i && j <= ub) continue whenM (lift $ readArray bmp j) exit lift $ writeArray bmp j True lift $ modifySTRef' count (+1) readSTRef count >>= modifySTRef' total . (+) . numPairs readSTRef total where factor = rotateFactor lb rotate x = let (n, d) = x `divMod` 10 in d*factor + n numPairs n = (n-1) * n `div` 2 main :: IO () main = do t <- readLn forM_ [1..t] $ \(x :: Int) -> do [a, b] <- map read . words <$> getLine let y = recycledNumbers (a, b) putStrLn $ "Case #" ++ show x ++ ": " ++ show y ------------------------------------------------------------------------ -- Helper functions -- | Return the power of 10 corresponding to the most significant digit in the -- number. rotateFactor :: Int -> Int rotateFactor n | n < 1 = error "rotateFactor: n < 1" | otherwise = loop 1 where loop p | p' > n = p | p' < p = p -- in case of overflow | otherwise = loop p' where p' = p * 10 modifySTRef' :: STRef s a -> (a -> a) -> ST s () modifySTRef' ref f = do x <- readSTRef ref writeSTRef ref $! f x whenM :: Monad m => m Bool -> m () -> m () whenM p m = p >>= \b -> if b then m else return () control-monad-loop-0.1/test/lift-continue.hs0000644000000000000000000000105711776226650017375 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} import Control.Monad import Control.Monad.Base import Control.Monad.Trans.Class import Control.Monad.Trans.Loop main :: IO () main = do foreach [1..10] $ \(i :: Int) -> do foreach [1..10] $ \(j :: Int) -> do when (j > i) $ lift continue when (i == 2 && j == 2) $ exit when (i == 9 && j == 9) $ lift exit liftBase $ print (i, j) liftBase $ putStrLn "Inner loop finished" putStrLn "Outer loop finished" control-monad-loop-0.1/test/liftLocal.hs0000644000000000000000000000234011776226650016522 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} import Prelude hiding (log) import Control.Monad.Trans.Loop import Control.Exception import Control.Monad.Reader import Control.Monad.Writer test1 :: IO () test1 = foreach [1..4] $ \(i :: Int) -> do let log msg = liftIO $ putStrLn $ "test1: " ++ show i ++ ": " ++ msg logMaskingState = do b <- lift getMaskingState log $ "getMaskingState: " ++ show b logMaskingState liftLocalLoopT mask_ $ do logMaskingState when (i == 3) $ do log "continue" continue logMaskingState -- This test is interesting because we're using mtl's 'local', which in this -- context walks up the WriterT too. test2 :: IO () test2 = mapM_ putStrLn $ flip runReader (0 :: Int) $ execWriterT $ foreach [1..4] $ \(i :: Int) -> do let log msg = lift $ tell ["test2: " ++ show i ++ ": " ++ msg] logAsk = do n <- lift ask log $ "ask: " ++ show n logAsk liftLocalLoopT (local (+1)) $ do logAsk when (i == 3) $ do log "continue" continue logAsk