Attempt at a pipes-inspired interface with a good MonadTrans instance

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
-- Pipes, adapted & modified from: 
-- https://github.com/Gabriel439/Haskell-Pipes-Library

-- Probably involves the base monad m too much
-- Not all laws successfully proven (yet?)

data Pipe i o m r = 
  Done r | Await (i -> MPipe i o m r) | Yield (MPipe i o m r) o

newtype MPipe i o m r = MP {unMP :: m (Pipe i o m r)}

awaitm :: Monad m => (i -> MPipe i o m r) -> MPipe i o m r
awaitm k = MP (return (Await k))
{-# INLINE awaitm #-}

await :: Monad m => MPipe i o m i
await = awaitm return
{-# INLINE await #-}

yieldm :: Monad m => MPipe i o m r -> o -> MPipe i o m r
yieldm mr v = MP (return (Yield mr v))
{-# INLINE yieldm #-}

yield :: Monad m => o -> MPipe i o m ()
yield = yieldm (return ())
{-# INLINE yield #-}

instance Monad m => Monad (MPipe i o m) where
  return x = MP (return (Done x))
  MP m >>= k = 
    MP (m >>= \p -> unMP (
        case p of
         Done x -> k x
         Await g -> awaitm (\y -> g y >>= k) -- awaitm (g >=> k)
         Yield pp v -> yieldm (pp >>= k) v))

instance MonadTrans (MPipe i o) where
  lift m = MP (m >>= \x -> return (Done x))
         -- MP (liftM Done m)

pipe :: Monad m => (i -> o) -> MPipe i o m r
pipe f = forever (await >>= yield . f)

idP :: Monad m => MPipe i i m r
-- idP = pipe (\x -> x)
idP = let mz = awaitm (yieldm mz) in mz

infixr 9 <+<

yex :: Monad m => MPipe a b m r -> Pipe b c m r -> m (Pipe a c m r)
yex mq p = case p of
            Done x -> return (Done x)
            Yield mpp v -> return (Yield (MP (unMP mpp >>= yex mq)) v)
            Await g -> unMP mq >>= wex g
              
wex :: Monad m => (b -> MPipe b c m r) -> Pipe a b m r -> m (Pipe a c m r)
wex g q = case q of
           Done z -> return (Done z)
           Yield mqq w -> unMP (g w) >>= yex mqq
           Await h -> return (Await (\y -> MP (unMP (h y) >>= wex g)))

(<+<) :: Monad m => MPipe b c m r -> MPipe a b m r -> MPipe a c m r
mp <+< mq = MP (unMP mp >>= yex mq)