ExceptT Control.Foldl example

import           Pipes
import qualified Pipes.Prelude as P
import qualified Control.Foldl as L
import           Control.Monad.Except

type ErrorReturnType = Either String ()

exampleProd :: Monad m => Producer (Int, Int) m ErrorReturnType
exampleProd = fmap Right $ each $ zip [1,1,1,1,2,2,2,2,4,4,4,4] [1,2,3,4,1,2,3,4,1,2,4,3]

printEveryElement :: MonadIO m => L.FoldM m (Int, Int) ()
printEveryElement = L.FoldM (\x a -> liftIO $ print a) (return ()) return

-- check that the inner loop consists of 1,2,3,4
checkInnerLoop :: Monad m => L.FoldM (ExceptT String m) (Int, Int) ()
checkInnerLoop = L.FoldM step init done
  where
    init :: Monad m => (ExceptT String m) Int
    init = return 1
    step :: Monad m => Int -> (Int, Int) -> ExceptT String m Int
    step state (_, inner) =
        if state == inner then
            return $ (state `mod` 4) + 1
        else
            throwError "Error in inner counter"
    done :: Monad m => Int -> ExceptT String m ()
    done = \_ -> return ()

-- check that the outer loop increases every four entries
checkOuterLoop :: Monad m => L.FoldM (ExceptT String m) (Int, Int) ()
checkOuterLoop = L.FoldM step init done
  where
    init :: Monad m => (ExceptT String m) Int
    init = return 0
    step :: Monad m => Int -> (Int, Int) -> ExceptT String m Int
    step state (outer, _) =
        if ((state `div` 4) + 1) == outer then
            return $ state + 1
        else
            throwError "Error in outer counter"
    done :: Monad m => Int -> ExceptT String m ()
    done = \_ -> return ()

-- just check the inner loop
combinedFold :: MonadIO m => L.FoldM (ExceptT String m) (Int, Int) ((),())
combinedFold = (,) <$> printEveryElement <*> checkInnerLoop

-- just check the outer loop
combinedFold2 :: MonadIO m => L.FoldM (ExceptT String m) (Int, Int) ((),(),())
combinedFold2 = (,,) <$> printEveryElement <*> checkInnerLoop <*> checkOuterLoop

main :: IO ()
main = do
    r <- runExceptT $ L.impurely P.foldM' combinedFold exampleProd
    print r
    r <- runExceptT $ L.impurely P.foldM' combinedFold2 exampleProd
    print r