Ticket #3787: Trampoline-small.hs

File Trampoline-small.hs, 1.9 KB (added by ajd, 4 years ago)

Trimmed down file that causes the bug.

Line 
1{-
2    Copyright 2009 Mario Blazevic
3
4    This file is part of the Streaming Component Combinators (SCC) project.
5
6    The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
7    License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
8    version.
9
10    SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
11    of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
12
13    You should have received a copy of the GNU General Public License along with SCC.  If not, see
14    <http://www.gnu.org/licenses/>.
15-}
16
17-- | Module "Trampoline" defines the trampoline computations and their basic building blocks.
18
19{-# LANGUAGE TypeFamilies #-}
20
21module Control.Concurrent.SCC.Trampoline where
22
23-- | Suspending monadic computations.
24newtype Trampoline s m r = Trampoline {
25   -- | Run the next step of a `Trampoline` computation.
26   bounce :: m (TrampolineState s m r)
27   }
28
29data TrampolineState s m r = Suspend (s (Trampoline s m r))
30
31data Yield x y = Yield x y
32
33data Await x y = Await (x -> y)
34
35data EitherFunctor l r x = LeftF (l x) | RightF (r x)
36
37newtype NestedFunctor l r x = NestedFunctor (l (r x))
38
39data SomeFunctor l r x = LeftSome (l x) | RightSome (r x) | Both (NestedFunctor l r x)
40
41type TryYield x = EitherFunctor (Yield x) (Await Bool)
42
43resolveProducerConsumer :: (s' ~ SomeFunctor (SinkFunctor s a) (SourceFunctor s a))
44                           => s' (Trampoline s' m (x, y)) -> Trampoline s' m (x, y)
45resolveProducerConsumer (LeftSome (RightF (LeftF (Yield _ c)))) = c
46resolveProducerConsumer (RightSome (RightF (Await c))) = c Nothing
47resolveProducerConsumer (Both (NestedFunctor (RightF (LeftF (Yield x (RightF (Await c))))))) = undefined
48
49type SourceFunctor a x = EitherFunctor a (Await (Maybe x))
50type SinkFunctor a x = EitherFunctor a (TryYield x)