Testsuite: tabs -> spaces [skip ci]
[ghc.git] / testsuite / tests / simplCore / should_run / simplrun009.hs
1 {-# LANGUAGE ExistentialQuantification #-}
2
3 -- This test is really meant for human looking; do a -ddump-simpl.
4
5 -- The definition that you want to look at is for foo.
6 -- It produces a nested unfold that should look something
7 -- like the code below. Note the 'lvl1_shW'. It is BAD
8 -- if this is a lambda instead; you get a lot more allocation
9 -- See Note [Escaping a value lambda] in SetLevels
10
11
12 {-
13 $wunfold_shU =
14 \ (ww_she :: [[a_abm]]) (ww1_shf :: Data.Maybe.Maybe (Stream.Stream a_abm)) ->
15 case ww1_shf of wild2_afo {
16 Data.Maybe.Nothing ->
17 case ww_she of wild_ad6 {
18 [] -> GHC.Base.[] @ a_abm;
19 : x_ado xs1_adp ->
20 $wunfold_shU
21 xs1_adp
22 (Data.Maybe.Just
23 @ (Stream.Stream a_abm) (Stream.Stream @ a_abm @ [a_abm]
24 *** lvl1_shW ***
25 x_ado))
26 };
27 Data.Maybe.Just ds3_afJ ->
28 case ds3_afJ of wild3_afL { Stream.Stream @ s1_afN stepb_afO sb_afP ->
29 case stepb_afO sb_afP of wild4_afR {
30 Stream.Done -> $wunfold_shU ww_she (Data.Maybe.Nothing @ (Stream.Stream a_abm));
31 Stream.Yield x_afV sb'_afW ->
32 GHC.Base.:
33 @ a_abm
34 x_afV
35 ($wunfold_shU
36 ww_she
37 (Data.Maybe.Just
38 @ (Stream.Stream a_abm) (Stream.Stream @ a_abm @ s1_afN stepb_afO sb'_afW)));
39 Stream.Skip sb'_afZ ->
40 $wunfold_shU
41 ww_she
42 (Data.Maybe.Just
43 @ (Stream.Stream a_abm) (Stream.Stream @ a_abm @ s1_afN stepb_afO sb'_afZ))
44 }
45 }
46 -}
47
48
49
50 module Main( main, foo ) where
51 -- Must export foo to make the issue show up
52
53 import Prelude hiding ( concatMap, map)
54
55 main = print (sum (foo [[1,2], [3,4,5]]))
56
57 foo :: Num a => [[a]] -> [a]
58 foo xss = Main.concatMap (\xs -> Main.map (+1) xs) xss
59
60
61 instance StreamableSequence [] where
62 stream = listToStream
63 unstream = streamToList
64 -- These inline pragmas are useless (see #5084)
65 {-
66 {-# INLINE stream #-}
67 {-# INLINE unstream #-}
68 -}
69
70 listToStream :: [a] -> Stream a
71 listToStream xs = Stream next xs
72 where next [] = Done
73 next (x:xs) = Yield x xs
74 {-# INLINE [0] listToStream #-}
75
76 streamToList :: Stream a -> [a]
77 streamToList (Stream next s) = unfold s
78 where unfold s =
79 case next s of
80 Done -> []
81 Skip s' -> unfold s'
82 Yield x s' -> x : unfold s'
83 {-# INLINE [0] streamToList #-}
84
85 {-# RULES
86 "stream/unstream"
87 forall s. listToStream (streamToList s) = s
88 #-}
89
90 map :: (a -> b) -> [a] -> [b]
91 map f = unstream . mapS f . stream
92 {-# INLINE map #-}
93
94 concatMap :: (a -> [b]) -> [a] -> [b]
95 concatMap f = unstream . concatMapS (stream . f) . stream
96 {-# INLINE concatMap #-}
97
98
99 data Stream a = forall s. Stream (s -> Step a s) s
100
101 data Step a s = Done
102 | Yield a s
103 | Skip s
104
105 class StreamableSequence seq where
106 stream :: seq a -> Stream a
107 unstream :: Stream a -> seq a
108
109 -- axiom: stream . unstream = id
110 -- These inline pragmas are useless (see #5084)
111 {-
112 {-# INLINE stream #-}
113 {-# INLINE unstream #-}
114 -}
115
116 {-
117 --version that does not require the sequence type
118 --to be polymorphic in its elements:
119
120 class StreamableSequence seq a | seq -> a where
121 stream :: seq -> Stream a
122 unstream :: Stream a -> seq
123 -}
124
125
126 mapS :: (a -> b) -> Stream a -> Stream b
127 mapS f (Stream next s0) = Stream next' s0
128 where next' s = case next s of
129 Done -> Done
130 Skip s' -> Skip s'
131 Yield x s' -> Yield (f x) s'
132 {-# INLINE [0] mapS #-}
133
134
135 concatMapS :: (a -> Stream b) -> Stream a -> Stream b
136 concatMapS f (Stream step s) = Stream step' (s, Nothing)
137 where step' (s, Nothing) =
138 case step s of
139 Yield x s' -> Skip (s', Just (f x))
140 Skip s' -> Skip (s', Nothing)
141 Done -> Done
142
143 step' (s, Just (Stream stepb sb)) =
144 case stepb sb of
145 Yield x sb' -> Yield x (s, Just (Stream stepb sb'))
146 Skip sb' -> Skip (s, Just (Stream stepb sb'))
147 Done -> Skip (s, Nothing)
148 {-# INLINE [0] concatMapS #-}
149