control-monad-loop (empty) → 0.1

raw patch · 8 files changed

+423/−0 lines, 8 filesdep +basedep +transformersdep +transformers-basesetup-changed

Dependencies added: base, transformers, transformers-base

Files

Control/Monad/Trans/Loop.hs +189/−0
LICENSE +30/−0
Setup.hs +2/−0
control-monad-loop.cabal +36/−0
test/leak.hs +28/−0
test/lift-continue.hs +19/−0
test/liftLocal.hs +49/−0
test/recycled-numbers.hs +70/−0

+ Control/Monad/Trans/Loop.hs view

@@ -0,0 +1,189 @@+-- |+-- 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

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ control-monad-loop.cabal view

@@ -0,0 +1,36 @@+name:               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

+ test/leak.hs view

@@ -0,0 +1,28 @@+-- 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

+ test/lift-continue.hs view

@@ -0,0 +1,19 @@+{-# 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"

+ test/liftLocal.hs view

@@ -0,0 +1,49 @@+{-# 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

+ test/recycled-numbers.hs view

@@ -0,0 +1,70 @@+-- 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 ()