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
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
{-# LANGUAGE ExistentialQuantification #-}
-- This test is really meant for human looking; do a -ddump-simpl.
-- The definition that you want to look at is for foo.
-- It produces a nested unfold that should look something
-- like the code below. Note the 'lvl1_shW'. It is BAD
-- if this is a lambda instead; you get a lot more allocation
-- See Note [Escaping a value lambda] in GHC.Core.Op.SetLevels
{-
$wunfold_shU =
\ (ww_she :: [[a_abm]]) (ww1_shf :: Data.Maybe.Maybe (Stream.Stream a_abm)) ->
case ww1_shf of wild2_afo {
Data.Maybe.Nothing ->
case ww_she of wild_ad6 {
[] -> GHC.Base.[] @ a_abm;
: x_ado xs1_adp ->
$wunfold_shU
xs1_adp
(Data.Maybe.Just
@ (Stream.Stream a_abm) (Stream.Stream @ a_abm @ [a_abm]
*** lvl1_shW ***
x_ado))
};
Data.Maybe.Just ds3_afJ ->
case ds3_afJ of wild3_afL { Stream.Stream @ s1_afN stepb_afO sb_afP ->
case stepb_afO sb_afP of wild4_afR {
Stream.Done -> $wunfold_shU ww_she (Data.Maybe.Nothing @ (Stream.Stream a_abm));
Stream.Yield x_afV sb'_afW ->
GHC.Base.:
@ a_abm
x_afV
($wunfold_shU
ww_she
(Data.Maybe.Just
@ (Stream.Stream a_abm) (Stream.Stream @ a_abm @ s1_afN stepb_afO sb'_afW)));
Stream.Skip sb'_afZ ->
$wunfold_shU
ww_she
(Data.Maybe.Just
@ (Stream.Stream a_abm) (Stream.Stream @ a_abm @ s1_afN stepb_afO sb'_afZ))
}
}
-}
module Main( main, foo ) where
-- Must export foo to make the issue show up
import Prelude hiding ( concatMap, map)
main = print (sum (foo [[1,2], [3,4,5]]))
foo :: Num a => [[a]] -> [a]
foo xss = Main.concatMap (\xs -> Main.map (+1) xs) xss
instance StreamableSequence [] where
stream = listToStream
unstream = streamToList
-- These inline pragmas are useless (see #5084)
{-
{-# INLINE stream #-}
{-# INLINE unstream #-}
-}
listToStream :: [a] -> Stream a
listToStream xs = Stream next xs
where next [] = Done
next (x:xs) = Yield x xs
{-# INLINE [0] listToStream #-}
streamToList :: Stream a -> [a]
streamToList (Stream next s) = unfold s
where unfold s =
case next s of
Done -> []
Skip s' -> unfold s'
Yield x s' -> x : unfold s'
{-# INLINE [0] streamToList #-}
{-# RULES
"stream/unstream"
forall s. listToStream (streamToList s) = s
#-}
map :: (a -> b) -> [a] -> [b]
map f = unstream . mapS f . stream
{-# INLINE map #-}
concatMap :: (a -> [b]) -> [a] -> [b]
concatMap f = unstream . concatMapS (stream . f) . stream
{-# INLINE concatMap #-}
data Stream a = forall s. Stream (s -> Step a s) s
data Step a s = Done
| Yield a s
| Skip s
class StreamableSequence seq where
stream :: seq a -> Stream a
unstream :: Stream a -> seq a
-- axiom: stream . unstream = id
-- These inline pragmas are useless (see #5084)
{-
{-# INLINE stream #-}
{-# INLINE unstream #-}
-}
{-
--version that does not require the sequence type
--to be polymorphic in its elements:
class StreamableSequence seq a | seq -> a where
stream :: seq -> Stream a
unstream :: Stream a -> seq
-}
mapS :: (a -> b) -> Stream a -> Stream b
mapS f (Stream next s0) = Stream next' s0
where next' s = case next s of
Done -> Done
Skip s' -> Skip s'
Yield x s' -> Yield (f x) s'
{-# INLINE [0] mapS #-}
concatMapS :: (a -> Stream b) -> Stream a -> Stream b
concatMapS f (Stream step s) = Stream step' (s, Nothing)
where step' (s, Nothing) =
case step s of
Yield x s' -> Skip (s', Just (f x))
Skip s' -> Skip (s', Nothing)
Done -> Done
step' (s, Just (Stream stepb sb)) =
case stepb sb of
Yield x sb' -> Yield x (s, Just (Stream stepb sb'))
Skip sb' -> Skip (s, Just (Stream stepb sb'))
Done -> Skip (s, Nothing)
{-# INLINE [0] concatMapS #-}
|
