Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
4fb93d65
Commit
4fb93d65
authored
Oct 20, 2009
by
Simon Peyton Jones
Browse files
Test Trac
#3591
parent
1e29f07d
Changes
3
Show whitespace changes
Inline
Sidebyside
Showing
3 changed files
with
628 additions
and
0 deletions
+628
0
testsuite/tests/ghcregress/simplCore/should_run/T3591.hs
testsuite/tests/ghcregress/simplCore/should_run/T3591.hs
+171
0
testsuite/tests/ghcregress/simplCore/should_run/T3591.stderr
...suite/tests/ghcregress/simplCore/should_run/T3591.stderr
+456
0
testsuite/tests/ghcregress/simplCore/should_run/all.T
testsuite/tests/ghcregress/simplCore/should_run/all.T
+1
0
No files found.
testsuite/tests/ghcregress/simplCore/should_run/T3591.hs
0 → 100644
View file @
4fb93d65
{
Copyright 2009 Mario Blazevic
This file is part of the Streaming Component Combinators (SCC) project.
The SCC project is free software: you can redistribute it and/or modify it under the terms of the GNU General Public
License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later
version.
SCC is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
You should have received a copy of the GNU General Public License along with SCC. If not, see
<http://www.gnu.org/licenses/>.
}
  Module "Trampoline" defines the pipe computations and their basic building blocks.
{# LANGUAGE ScopedTypeVariables, Rank2Types, MultiParamTypeClasses, TypeFamilies, KindSignatures,
FlexibleContexts, FlexibleInstances, OverlappingInstances, UndecidableInstances
#}
module
Main
where
import
Control.Monad
(
liftM
,
liftM2
,
when
)
 import Control.Monad.Identity
import
Debug.Trace
(
trace
)
newtype
Identity
a
=
Identity
{
runIdentity
::
a
}
instance
Monad
Identity
where
return
a
=
Identity
a
m
>>=
k
=
k
(
runIdentity
m
)
newtype
Trampoline
m
s
r
=
Trampoline
{
bounce
::
m
(
TrampolineState
m
s
r
)}
data
TrampolineState
m
s
r
=
Done
r

Suspend
!
(
s
(
Trampoline
m
s
r
))
instance
(
Monad
m
,
Functor
s
)
=>
Monad
(
Trampoline
m
s
)
where
return
x
=
Trampoline
(
return
(
Done
x
))
t
>>=
f
=
Trampoline
(
bounce
t
>>=
apply
f
)
where
apply
f
(
Done
x
)
=
bounce
(
f
x
)
apply
f
(
Suspend
s
)
=
return
(
Suspend
(
fmap
(
>>=
f
)
s
))
data
Yield
x
y
=
Yield
!
x
y
instance
Functor
(
Yield
x
)
where
fmap
f
(
Yield
x
y
)
=
trace
"fmap yield"
$
Yield
x
(
f
y
)
data
Await
x
y
=
Await
!
(
x
>
y
)
instance
Functor
(
Await
x
)
where
fmap
f
(
Await
g
)
=
trace
"fmap await"
$
Await
(
f
.
g
)
data
EitherFunctor
l
r
x
=
LeftF
(
l
x
)

RightF
(
r
x
)
instance
(
Functor
l
,
Functor
r
)
=>
Functor
(
EitherFunctor
l
r
)
where
fmap
f
v
=
trace
"fmap Either"
$
case
v
of
LeftF
l
>
trace
"fmap LeftF"
$
LeftF
(
fmap
f
l
)
RightF
r
>
trace
"fmap RightF"
$
RightF
(
fmap
f
r
)
type
TryYield
x
=
EitherFunctor
(
Yield
x
)
(
Await
Bool
)
suspend
::
(
Monad
m
,
Functor
s
)
=>
s
(
Trampoline
m
s
x
)
>
Trampoline
m
s
x
suspend
s
=
Trampoline
(
return
(
Suspend
s
))
yield
::
forall
m
x
.
Monad
m
=>
x
>
Trampoline
m
(
Yield
x
)
()
yield
x
=
suspend
(
Yield
x
(
return
()
))
await
::
forall
m
x
.
Monad
m
=>
Trampoline
m
(
Await
x
)
x
await
=
suspend
(
Await
return
)
tryYield
::
forall
m
x
.
Monad
m
=>
x
>
Trampoline
m
(
TryYield
x
)
Bool
tryYield
x
=
suspend
(
LeftF
(
Yield
x
(
suspend
(
RightF
(
Await
return
)))))
canYield
::
forall
m
x
.
Monad
m
=>
Trampoline
m
(
TryYield
x
)
Bool
canYield
=
suspend
(
RightF
(
Await
return
))
liftBounce
::
Monad
m
=>
m
x
>
Trampoline
m
s
x
liftBounce
=
Trampoline
.
liftM
Done
fromTrampoline
::
Monad
m
=>
Trampoline
m
s
x
>
m
x
fromTrampoline
t
=
bounce
t
>>=
\
(
Done
x
)
>
return
x
runTrampoline
::
Monad
m
=>
Trampoline
m
Maybe
x
>
m
x
runTrampoline
=
fromTrampoline
coupleNestedFinite
::
(
Functor
s
,
Monad
m
)
=>
Trampoline
m
(
EitherFunctor
s
(
TryYield
a
))
x
>
Trampoline
m
(
EitherFunctor
s
(
Await
(
Maybe
a
)))
y
>
Trampoline
m
s
(
x
,
y
)
coupleNestedFinite
t1
t2
=
trace
"bounce start"
$
liftBounce
(
liftM2
(,)
(
bounce
t1
)
(
bounce
t2
))
>>=
\
(
s1
,
s2
)
>
trace
"bounce end"
$
case
(
s1
,
s2
)
of
(
Done
x
,
Done
y
)
>
return
(
x
,
y
)
(
Done
x
,
Suspend
(
RightF
(
Await
c2
)))
>
coupleNestedFinite
(
return
x
)
(
c2
Nothing
)
(
Suspend
(
RightF
(
LeftF
(
Yield
_
c1
))),
Done
y
)
>
coupleNestedFinite
c1
(
return
y
)
(
Suspend
(
RightF
(
LeftF
(
Yield
x
c1
))),
Suspend
(
RightF
(
Await
c2
)))
>
coupleNestedFinite
c1
(
c2
$
Just
x
)
(
Suspend
(
RightF
(
RightF
(
Await
c1
))),
Suspend
s2
@
(
RightF
Await
{}))
>
coupleNestedFinite
(
c1
True
)
(
suspend
s2
)
(
Suspend
(
RightF
(
RightF
(
Await
c1
))),
Done
y
)
>
coupleNestedFinite
(
c1
False
)
(
return
y
)
(
Suspend
(
LeftF
s
),
Done
y
)
>
suspend
(
fmap
(
flip
coupleNestedFinite
(
return
y
))
s
)
(
Done
x
,
Suspend
(
LeftF
s
))
>
suspend
(
fmap
(
coupleNestedFinite
(
return
x
))
s
)
(
Suspend
(
LeftF
s1
),
Suspend
(
LeftF
s2
))
>
suspend
(
fmap
(
coupleNestedFinite
$
suspend
$
LeftF
s1
)
s2
)
(
Suspend
(
LeftF
s1
),
Suspend
(
RightF
s2
))
>
suspend
(
fmap
(
flip
coupleNestedFinite
(
suspend
$
RightF
s2
))
s1
)
(
Suspend
(
RightF
s1
),
Suspend
(
LeftF
s2
))
>
suspend
(
fmap
(
coupleNestedFinite
(
suspend
$
RightF
s1
))
s2
)
local
::
forall
m
l
r
x
.
(
Monad
m
,
Functor
r
)
=>
Trampoline
m
r
x
>
Trampoline
m
(
EitherFunctor
l
r
)
x
local
(
Trampoline
mr
)
=
Trampoline
(
liftM
inject
mr
)
where
inject
::
TrampolineState
m
r
x
>
TrampolineState
m
(
EitherFunctor
l
r
)
x
inject
(
Done
x
)
=
Done
x
inject
(
Suspend
r
)
=
Suspend
(
RightF
$
fmap
local
r
)
out
::
forall
m
l
r
x
.
(
Monad
m
,
Functor
l
)
=>
Trampoline
m
l
x
>
Trampoline
m
(
EitherFunctor
l
r
)
x
out
(
Trampoline
ml
)
=
Trampoline
(
liftM
inject
ml
)
where
inject
::
TrampolineState
m
l
x
>
TrampolineState
m
(
EitherFunctor
l
r
)
x
inject
(
Done
x
)
=
Done
x
inject
(
Suspend
l
)
=
Suspend
(
LeftF
$
fmap
out
l
)
class
(
Functor
a
,
Functor
d
)
=>
AncestorFunctor
a
d
where
liftFunctor
::
a
x
>
d
x
instance
Functor
a
=>
AncestorFunctor
a
a
where
liftFunctor
=
trace
"liftFunctor id"
.
id
instance
(
Functor
a
,
Functor
d'
,
Functor
d
,
d
~
EitherFunctor
d'
s
,
AncestorFunctor
a
d'
)
=>
AncestorFunctor
a
d
where
liftFunctor
=
LeftF
.
(
trace
"liftFunctor other"
.
liftFunctor
::
a
x
>
d'
x
)
liftOut
::
forall
m
a
d
x
.
(
Monad
m
,
Functor
a
,
AncestorFunctor
a
d
)
=>
Trampoline
m
a
x
>
Trampoline
m
d
x
liftOut
(
Trampoline
ma
)
=
trace
"liftOut"
$
Trampoline
(
liftM
inject
ma
)
where
inject
::
TrampolineState
m
a
x
>
TrampolineState
m
d
x
inject
(
Done
x
)
=
Done
x
inject
(
Suspend
a
)
=
trace
"inject suspend"
$
Suspend
(
liftFunctor
$
trace
"calling fmap"
$
fmap
liftOut
(
trace
"poking a"
a
))
data
Sink
(
m
::
*
>
*
)
a
x
=
Sink
{
put
::
forall
d
.
(
AncestorFunctor
(
EitherFunctor
a
(
TryYield
x
))
d
)
=>
x
>
Trampoline
m
d
Bool
,
canPut
::
forall
d
.
(
AncestorFunctor
(
EitherFunctor
a
(
TryYield
x
))
d
)
=>
Trampoline
m
d
Bool
}
newtype
Source
(
m
::
*
>
*
)
a
x
=
Source
{
get
::
forall
d
.
(
AncestorFunctor
(
EitherFunctor
a
(
Await
(
Maybe
x
)))
d
)
=>
Trampoline
m
d
(
Maybe
x
)}
pipe
::
forall
m
a
x
r1
r2
.
(
Monad
m
,
Functor
a
)
=>
(
Sink
m
a
x
>
Trampoline
m
(
EitherFunctor
a
(
TryYield
x
))
r1
)
>
(
Source
m
a
x
>
Trampoline
m
(
EitherFunctor
a
(
Await
(
Maybe
x
)))
r2
)
>
Trampoline
m
a
(
r1
,
r2
)
pipe
producer
consumer
=
coupleNestedFinite
(
producer
sink
)
(
consumer
source
)
where
sink
=
Sink
{
put
=
liftOut
.
(
local
.
tryYield
::
x
>
Trampoline
m
(
EitherFunctor
a
(
TryYield
x
))
Bool
),
canPut
=
liftOut
(
local
canYield
::
Trampoline
m
(
EitherFunctor
a
(
TryYield
x
))
Bool
)}
::
Sink
m
a
x
source
=
Source
(
liftOut
(
local
await
::
Trampoline
m
(
EitherFunctor
a
(
Await
(
Maybe
x
)))
(
Maybe
x
)))
::
Source
m
a
x
pipeProducer
sink
=
do
put
sink
1
(
c
,
d
)
<
pipe
(
\
sink'
>
do
put
sink'
2
put
sink
3
put
sink'
4
return
5
)
(
\
source'
>
do
Just
n
<
get
source'
put
sink
n
put
sink
6
return
n
)
put
sink
c
put
sink
d
return
(
c
,
d
)
testPipe
=
print
$
runIdentity
$
runTrampoline
$
do
(
a
,
b
)
<
pipe
pipeProducer
(
\
source
>
do
Just
n1
<
get
source
Just
n2
<
get
source
Just
n3
<
get
source
return
(
n1
,
n2
,
n3
))
return
(
a
,
b
)
main
=
testPipe
testsuite/tests/ghcregress/simplCore/should_run/T3591.stderr
0 → 100644
View file @
4fb93d65
bounce start
bounce end
liftOut
inject suspend
liftFunctor id
calling fmap
fmap Either
poking a
fmap RightF
fmap Either
fmap RightF
fmap Either
fmap Either
fmap Either
fmap LeftF
fmap LeftF
fmap LeftF
fmap yield
fmap yield
fmap yield
liftOut
inject suspend
liftFunctor id
calling fmap
fmap Either
poking a
fmap RightF
fmap Either
fmap RightF
fmap await
fmap await
fmap await
bounce start
bounce end
liftOut
inject suspend
liftFunctor id
calling fmap
fmap Either
poking a
fmap RightF
fmap Either
fmap RightF
fmap Either
fmap Either
fmap Either
fmap RightF
fmap RightF
fmap RightF
fmap await
fmap await
fmap await
liftOut
fmap Either
fmap RightF
fmap await
bounce start
bounce end
liftOut
bounce start
bounce end
liftOut
inject suspend
liftFunctor id
calling fmap
fmap Either
poking a
fmap RightF
fmap Either
fmap RightF
fmap Either
fmap Either
fmap Either
fmap LeftF
fmap LeftF
fmap LeftF
fmap yield
fmap yield
fmap yield
liftOut
inject suspend
liftFunctor id
calling fmap
fmap Either
poking a
fmap RightF
fmap Either
fmap RightF
fmap await
fmap await
fmap await
bounce start
bounce end
liftOut
inject suspend
liftFunctor id
calling fmap
fmap Either
poking a
fmap RightF
fmap Either
fmap RightF
fmap Either
fmap Either
fmap Either
fmap RightF
fmap RightF
fmap RightF
fmap await
fmap await
fmap await
liftOut
liftOut
inject suspend
fmap Either
fmap LeftF
fmap Either
fmap Either
liftFunctor other
liftFunctor id
calling fmap
fmap Either
poking a
fmap RightF
fmap RightF
fmap RightF
fmap Either
fmap RightF
fmap Either
fmap Either
fmap Either
fmap Either
fmap Either
fmap LeftF
fmap LeftF
fmap LeftF
fmap LeftF
fmap LeftF
fmap yield
fmap yield
fmap yield
fmap yield
fmap yield
bounce start
bounce end
bounce start
bounce end
liftOut
inject suspend
fmap Either
fmap LeftF
fmap Either
fmap Either
liftFunctor other
liftFunctor id
calling fmap
fmap Either
poking a
fmap RightF
fmap RightF
fmap RightF
fmap Either
fmap RightF
fmap Either
fmap Either
fmap Either
fmap Either
fmap Either
fmap RightF
fmap RightF
fmap RightF
fmap RightF
fmap RightF
fmap await
fmap await
fmap await
fmap await
fmap await
liftOut
fmap Either
fmap RightF
fmap await
bounce start
bounce end
bounce start
bounce end
liftOut
liftOut
inject suspend
fmap Either
fmap LeftF
fmap Either
fmap Either
liftFunctor other
liftFunctor id
calling fmap
fmap Either
poking a
fmap RightF
fmap RightF
fmap RightF
fmap Either
fmap RightF
fmap Either
fmap Either
fmap Either
fmap Either
fmap Either
fmap LeftF
fmap LeftF
fmap LeftF
fmap LeftF
fmap LeftF
fmap yield
fmap yield
fmap yield
fmap yield
fmap yield
bounce start
bounce end
bounce start
bounce end
liftOut
inject suspend
fmap Either
fmap LeftF
fmap Either
fmap Either
liftFunctor other
liftFunctor id
calling fmap
fmap Either
poking a
fmap RightF
fmap RightF
fmap RightF
fmap Either
fmap RightF
fmap Either
fmap Either
fmap Either
fmap Either
fmap Either
fmap RightF
fmap RightF
fmap RightF
fmap RightF
fmap RightF
fmap await
fmap await
fmap await
fmap await
fmap await
liftOut
bounce start
bounce end
bounce start
bounce end
liftOut
bounce start
bounce end
liftOut
liftOut
inject suspend
fmap Either
fmap LeftF
fmap Either
fmap Either
liftFunctor other
liftFunctor id
calling fmap
fmap Either
poking a
fmap RightF
fmap RightF
fmap RightF
fmap Either
fmap RightF
fmap Either
fmap Either
fmap Either
fmap Either
fmap Either
fmap LeftF
fmap LeftF
fmap LeftF
fmap LeftF
fmap LeftF
fmap yield
fmap yield
fmap yield
fmap yield
fmap yield
bounce start
bounce end
bounce start
bounce end
liftOut
inject suspend
fmap Either
fmap LeftF
fmap Either
fmap Either
liftFunctor other
liftFunctor id
calling fmap
fmap Either
poking a
fmap RightF
fmap RightF
fmap RightF
fmap Either
fmap RightF
fmap Either
fmap Either
fmap Either
fmap Either
fmap Either
fmap RightF
fmap RightF
fmap RightF
fmap RightF
fmap RightF
fmap await
fmap await
fmap await
fmap await
fmap await
bounce start
bounce end
bounce start
bounce end
liftOut
liftOut
inject suspend
liftFunctor id
calling fmap
fmap Either
poking a
fmap RightF
fmap Either
fmap RightF
fmap Either
fmap Either
fmap Either
fmap LeftF
fmap LeftF
fmap LeftF
fmap yield
fmap yield
fmap yield
bounce start
bounce end
liftOut
inject suspend
liftFunctor id
calling fmap
fmap Either
poking a
fmap RightF
fmap Either
fmap RightF
fmap Either
fmap Either
fmap Either
fmap RightF
fmap RightF
fmap RightF
fmap await
fmap await
fmap await
bounce start
bounce end
liftOut
liftOut
inject suspend
liftFunctor id
calling fmap
fmap Either
poking a
fmap RightF
fmap Either
fmap RightF
fmap Either
fmap Either
fmap Either
fmap LeftF
fmap LeftF
fmap LeftF
fmap yield
fmap yield
fmap yield
bounce start
bounce end
liftOut
inject suspend
liftFunctor id
calling fmap
fmap Either
poking a
fmap RightF
fmap Either
fmap RightF
fmap Either
fmap Either
fmap Either
fmap RightF
fmap RightF
fmap RightF
fmap await
fmap await
fmap await
bounce start
bounce end
liftOut
liftOut
inject suspend
liftFunctor id
calling fmap
fmap Either
poking a
fmap RightF
fmap Either
fmap RightF
fmap Either
fmap Either
fmap Either
fmap LeftF
fmap LeftF
fmap LeftF
fmap yield
fmap yield
fmap yield
bounce start