Working

interruptible.cabal

@@ -36,4 +36,17 @@ library
       transformers,
       either
   hs-source-dirs:      src
-  default-language:    Haskell2010
+  default-language:    Haskell2010
+
+Test-suite all
+  type: detailed-0.9
+  test-module: Test
+  hs-source-dirs:
+    test
+  build-depends:
+    base >=4.7 && <5.0,
+    Cabal >= 1.9.2,
+    either,
+    interruptible
+  ghc-options: -Wall -fno-warn-unused-do-bind -fwarn-incomplete-patterns -threaded
+  default-language: Haskell2010

src/Control/Monad/Trans/Interruptible.hs

@@ -1,6 +1,9 @@
 {-# LANGUAGE TypeFamilies #-}
 
-module Control.Monad.Trans.Interruptible where
+module Control.Monad.Trans.Interruptible (
+  module Control.Monad.Trans.Interruptible.Class,
+  intercalateWith
+  )where
 
 import Control.Monad.Trans.Interruptible.Class
 
@@ -21,8 +24,8 @@ intercalateM f [a00, a10, a20] [b1, b2] = do
 
 Usefull for consuming lazy sequences.
 -}
-intercalateM :: (InterruptibleMonadTrans m, Monad n) => (b -> a -> m n a) -> [b] -> [RDt m a] -> n [RDt m a]
-intercalateM _ [] aa = return aa
-intercalateM f (b:bb) aa = do
-  aa' <- mapM (\x -> runT x $ f b) aa
-  intercalateM f bb aa'
+intercalateWith :: Monad m => ((a -> t a) -> rsta -> m (rsta)) -> (b -> a -> t a) -> [b] -> [rsta] -> m [rsta]
+intercalateWith _ _ [] aa = return aa
+intercalateWith res f (b:bb) aa = do
+  aa' <- mapM (res $ f b) aa
+  intercalateWith res f bb aa'

src/Control/Monad/Trans/Interruptible/Class.hs

@@ -5,10 +5,30 @@ module Control.Monad.Trans.Interruptible.Class where
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Either
 
-class MonadTrans m => InterruptibleMonadTrans m where
-  type RDt m :: * -> *
-  runT :: Monad n => RDt m a -> (a -> m n b) -> n (RDt m b)
+class MonadTrans t => Interruptible t where
+  type RSt t :: * -> *
+  resume :: Monad m => (a -> t m b) -> RSt t a -> m (RSt t b)
 
-instance InterruptibleMonadTrans (EitherT e) where
-  type RDt (EitherT e) = Either e
-  runT st f = runEitherT (hoistEither st >>= f)
+instance Interruptible (EitherT e) where
+  type RSt (EitherT e) = Either e
+  resume f st = runEitherT (hoistEither st >>= f)
+
+resume2 :: (Monad m, Interruptible t, Monad (t m), Interruptible u) =>
+           (a -> u (t m) b) -> RSt t (RSt u a) -> m (RSt t (RSt u b))
+resume2 = resume.resume
+resume3 :: (Monad m, Interruptible t0, Monad (t0 m), Interruptible t1,
+            Monad (t1 (t0 m)), Interruptible t2) =>
+           (a -> t2 (t1 (t0 m)) b) -> RSt t0 (RSt t1 (RSt t2 a)) ->
+           m (RSt t0 (RSt t1 (RSt t2 b)))
+resume3 = resume2.resume
+resume4 :: (Monad m, Interruptible t0, Interruptible t1, Interruptible t2,
+            Interruptible t3, Monad (t0 m), Monad (t1 (t0 m)), Monad (t2 (t1 (t0 m)))) =>
+           (a -> t3 (t2 (t1 (t0 m))) b) -> RSt t0 (RSt t1 (RSt t2 (RSt t3 a))) ->
+           m (RSt t0 (RSt t1 (RSt t2 (RSt t3 b))))
+resume4 = resume3.resume
+resume5 :: (Monad m, Interruptible t0, Interruptible t1, Interruptible t2,
+            Interruptible t3, Interruptible t4, Monad (t0 m), Monad (t1 (t0 m)),
+            Monad (t2 (t1 (t0 m))), Monad (t3 (t2 (t1 (t0 m))))) =>
+           (a -> t4 (t3 (t2 (t1 (t0 m)))) b) -> RSt t0 (RSt t1 (RSt t2 (RSt t3 (RSt t4 a)))) ->
+           m (RSt t0 (RSt t1 (RSt t2 (RSt t3 (RSt t4 b)))))
+resume5 = resume4.resume

test/Test.hs

@@ -0,0 +1,84 @@
+module Test (tests) where
+
+import Distribution.TestSuite
+import System.IO.Error
+
+import Control.Monad.Trans.Either
+import Data.Either.Combinators
+import Control.Monad.Trans.Interruptible
+
+simpleTest :: String -> IO Progress -> Test
+simpleTest n t = 
+  let test = TestInstance
+        {run = t',
+         name = n,
+         tags = [],
+         options = [],
+         setOption = \_ _ -> Right test
+        }
+  in Test test
+  where
+    t' :: IO Progress
+    t' = catchIOError t (
+      \e -> return . Finished . Fail $ "Raised exception: " ++ show e
+      )
+
+tests :: IO [Test]
+tests = return [
+  simpleTest "resume" (tres),
+  simpleTest "resume2" (tres2),
+  simpleTest "resume3" (tres3),
+  simpleTest "resume4" (tres4),
+  simpleTest "resume5" (tres5),
+  simpleTest "intercalate1" (int1),
+  simpleTest "intercalate5" (int5)
+  ]
+
+tres :: IO Progress
+tres = do
+  let f = (\x -> return $ x + 1) :: Int -> EitherT () IO Int
+  r <- resume f (Right 1)
+  let v = fromRight 0 r
+  Finished <$> if v == 2 then return Pass else return $ Fail $ "Wrong value: " ++ show v
+  
+tres2 :: IO Progress
+tres2 = do
+  let f = (\x -> return $ x + 1) :: Int -> EitherT () (EitherT () IO) Int
+  r <- resume2 f (Right . Right $ 1)
+  let v = fromRight 0 . fromRight (Left ()) $ r
+  Finished <$> if v == 2 then return Pass else return $ Fail $ "Wrong value: " ++ show v
+  
+tres3 :: IO Progress
+tres3 = do
+  let f = (\x -> return $ x + 1) :: Int -> EitherT () (EitherT () (EitherT () IO)) Int
+  r <- resume3 f (Right . Right . Right $ 1)
+  let v = fromRight 0 . fromRight (Left ()) . fromRight (Left ()) $ r
+  Finished <$> if v == 2 then return Pass else return $ Fail $ "Wrong value: " ++ show v
+
+tres4 :: IO Progress
+tres4 = do
+  let f = (\x -> return $ x + 1) :: Int -> EitherT () (EitherT () (EitherT () (EitherT () IO))) Int
+  r <- resume4 f (Right . Right . Right . Right $ 1)
+  let v = fromRight 0 . fromRight (Left ()) . fromRight (Left ()) . fromRight (Left ()) $ r
+  Finished <$> if v == 2 then return Pass else return $ Fail $ "Wrong value: " ++ show v
+
+tres5 :: IO Progress
+tres5 = do
+  let f = (\x -> return $ x + 1) :: Int -> EitherT () (EitherT () (EitherT () (EitherT () (EitherT () IO)))) Int
+  r <- resume5 f (Right . Right . Right . Right . Right $ 1)
+  let v = fromRight 0 . fromRight (Left ()) . fromRight (Left ()) . fromRight (Left ()) . fromRight (Left ()) $ r
+  Finished <$> if v == 2 then return Pass else return $ Fail $ "Wrong value: " ++ show v
+
+int1 :: IO Progress
+int1 = do
+  let f = (\x y -> return $ x + y) :: Int -> Int -> EitherT () IO Int
+  r <- intercalateWith resume f [1, 2, 3] (map Right [10, 20])
+  let v = map (fromRight 0) r
+  Finished <$> if v == [16, 26] then return Pass else return $ Fail $ "Wrong value: " ++ show v
+
+int5 :: IO Progress
+int5 = do
+  let f = (\x y -> return $ x + y) :: Int -> Int -> EitherT () (EitherT () (EitherT () (EitherT () (EitherT () IO)))) Int
+  r <- intercalateWith resume5 f [1, 2, 3] (map (Right . Right . Right . Right . Right) [10, 20])
+  let v = map (fromRight 0 . fromRight (Left ()) . fromRight (Left ()) . fromRight (Left ()) . fromRight (Left ())) r
+  Finished <$> if v == [16, 26] then return Pass else return $ Fail $ "Wrong value: " ++ show v