Ticket #3767: Spec.hs

File Spec.hs, 1.9 KB (added by simonpj, 10 years ago)
Line 
1{-# LANGUAGE ExistentialQuantification #-}
2module Foo where
3
4data Step s a = Yield a s | Skip s | Done
5data Stream a = forall s. Stream (s -> Step s a) s
6
7{-
8rep :: Int -> a -> Stream a
9{-# INLINE rep #-}
10rep n x = n `seq` Stream next n
11  where
12    next n | n > 0     = Yield x (n-1)
13           | otherwise = Done
14
15unstream :: Stream a -> [a]
16{-# INLINE unstream #-}
17unstream (Stream step s) = go s
18  where
19    go s = case step s of
20             Yield x s' -> x : go s'
21             Skip    s' -> go s'
22             Done       -> []
23
24plus :: Stream Int -> Int
25{-# INLINE plus #-}
26plus (Stream step s) = go 0 s
27  where
28    go n s = n `seq` case step s of
29                       Yield x s' -> go (n+x) s'
30                       Skip    s' -> go n s'
31                       Done       -> n
32-}
33
34
35rep_even :: Int -> a -> Stream a
36{-# INLINE rep_even #-}
37rep_even n x = n `seq` Stream next n
38  where
39    next n | n > 0     = if even n then Yield x (n-1) else Skip (n-1)
40           | otherwise = Done
41
42plus_pos :: Stream Int -> Int
43{-# INLINE plus_pos #-}
44plus_pos (Stream step s) = go 0 s
45  where
46    go n s = n `seq` case step s of
47                       Yield x s' -> go (n+max x 0) s'
48                       Skip    s' -> go n s'
49                       Done       -> n
50
51app :: Stream a -> Stream a -> Stream a
52{-# INLINE app #-}
53app (Stream step1 s1) (Stream step2 s2) = Stream step (Left s1)
54  where
55    step (Left s1) = case step1 s1 of
56                       Yield x s1' -> Yield x (Left s1')
57                       Skip    s1' -> Skip    (Left s1')
58                       Done        -> Skip    (Right s2)
59
60    step (Right s2) = case step2 s2 of
61                        Yield x s2' -> Yield x (Right s2')
62                        Skip    s2' -> Skip    (Right s2')
63                        Done        -> Done
64
65foo :: Int -> Int -> Int
66foo n x = plus_pos $ app (rep_even n x) (rep_even n x)
67
68