1+ module Control.Monad.ListT
2+ ( ListT ()
3+ , nil
4+ , cons'
5+ , prepend'
6+ , prepend
7+ , singleton
8+ , fromEffect
9+ , wrapEffect
10+ , wrapLazy
11+ , unfold
12+ , fromArray
13+ , take
14+ , takeWhile
15+ , drop
16+ , dropWhile
17+ , filter
18+ , mapMaybe
19+ , catMaybes
20+ , uncons
21+ , head
22+ , tail
23+ , foldl
24+ , scanl
25+ , zipWith'
26+ , zipWith
27+ ) where
28+
29+ import Control.Monad
30+ import Control.Monad.Trans
31+ import Data.Lazy
32+ import Data.Monoid
33+ import Data.Maybe
34+ import Data.Tuple
35+ import qualified Data.Array as A
36+
37+ type LazyF f a = Lazy (f a )
38+
39+ data ListT f a = ListT (f (Step a (ListT f a)))
40+
41+ data Step a s =
42+ Yield a (Lazy s ) |
43+ Skip (Lazy s ) |
44+ Done
45+
46+ runListT :: forall f a. ListT f a -> f (Step a (ListT f a))
47+ runListT (ListT fa ) = fa
48+
49+ nil :: forall f a. (Applicative f ) => ListT f a
50+ nil = ListT $ pure Done
51+
52+ cons' :: forall f a. (Applicative f ) => Lazy a -> Lazy (ListT f a ) -> ListT f a
53+ cons' lh t = ListT $ f <$> (pure unit ) where
54+ f _ = Yield (force lh ) t
55+
56+ prepend' :: forall f a. (Applicative f ) => a -> Lazy (ListT f a ) -> ListT f a
57+ prepend' h t = ListT $ pure (Yield h t )
58+
59+ prepend :: forall f a. (Applicative f ) => a -> ListT f a -> ListT f a
60+ prepend h t = prepend' h (defer $ const t )
61+
62+ stepMap :: forall f a b. (Functor f ) => (Step a (ListT f a) -> Step b (ListT f b)) -> ListT f a -> ListT f b
63+ stepMap f l = ListT $ f <$> (runListT l )
64+
65+ concat :: forall f a. (Applicative f ) => ListT f a -> ListT f a -> ListT f a
66+ concat x y = stepMap f x where
67+ f (Yield a s ) = Yield a (g <$> s ) where g s = s <> y
68+ f (Skip s ) = Skip (g <$> s ) where g s = s <> y
69+ f Done = Skip (defer $ const y )
70+
71+ instance semigroupListT :: (Applicative f ) => Semigroup (ListT f a ) where
72+ (<>) = concat
73+
74+ instance monoidListT :: (Applicative f ) => Monoid (ListT f a ) where
75+ mempty = nil
76+
77+ instance functorListT :: (Functor f ) => Functor (ListT f ) where
78+ (<$>) f = stepMap g where
79+ g (Yield a s ) = Yield (f a ) ((<$>) f <$> s )
80+ g (Skip s ) = Skip ((<$>) f <$> s )
81+ g Done = Done
82+
83+ instance applyListT :: (Monad f ) => Apply (ListT f ) where
84+ (<*>) = zipWith g where g f x = f x
85+
86+ instance applicativeListT :: (Monad f ) => Applicative (ListT f ) where
87+ pure = singleton
88+
89+ instance bindListT :: (Monad f ) => Bind (ListT f ) where
90+ (>>=) fa f = stepMap g fa where
91+ g (Yield a s ) = Skip (h <$> s ) where h s = f a `concat` (s >>= f ) -- why overlapping instances?
92+ g (Skip s ) = Skip (h <$> s ) where h s = s >>= f
93+ g Done = Done
94+
95+ instance monadListT :: (Monad f ) => Monad (ListT f )
96+
97+ singleton :: forall f a. (Applicative f ) => a -> ListT f a
98+ singleton a = prepend a nil
99+
100+ fromEffect :: forall f a. (Applicative f ) => f a -> ListT f a
101+ fromEffect fa = ListT $ (flip Yield ) (defer $ \_ -> nil ) <$> fa
102+
103+ wrapEffect :: forall f a. (Monad f ) => f (ListT f a ) -> ListT f a
104+ wrapEffect v = ListT $ Skip <<< defer <<< const <$> v
105+
106+ wrapLazy :: forall f a. (Monad f ) => Lazy (ListT f a ) -> ListT f a
107+ wrapLazy v = ListT $ pure (Skip v )
108+
109+ unfold :: forall f a z. (Monad f ) => (z -> f (Maybe (Tuple z a))) -> z -> ListT f a
110+ unfold f z = ListT $ g <$> f z where
111+ g (Just (Tuple z a)) = Yield a (defer \_ -> (unfold f z))
112+ g Nothing = Done
113+
114+ fromArray :: forall f a. (Monad f ) => [a] -> ListT f a
115+ fromArray xs = unfold f 0 where
116+ f n = pure $ Tuple (n + 1) <$> (xs A .!! n )
117+
118+ take :: forall f a. (Applicative f ) => Number -> ListT f a -> ListT f a
119+ take 0 fa = nil
120+ take n fa = stepMap f fa where
121+ f (Yield a s ) = Yield a s' where s' = take (n - 1) <$> s
122+ f (Skip s ) = Skip s' where s' = take n <$> s
123+ f Done = Done
124+
125+ takeWhile :: forall f a. (Applicative f ) => (a -> Boolean ) -> ListT f a -> ListT f a
126+ takeWhile f = stepMap g where
127+ -- type inferencer bug with if/then/else !!!!!
128+ g (Yield a s ) = ifThenElse (f a ) (Yield a (takeWhile f <$> s)) Done where ifThenElse p a b = if p then a else b
129+ g (Skip s ) = Skip $ takeWhile f <$> s
130+ g Done = Done
131+
132+ drop :: forall f a. (Applicative f ) => Number -> ListT f a -> ListT f a
133+ drop 0 fa = fa
134+ drop n fa = stepMap f fa where
135+ f (Yield a s ) = Skip s' where s' = drop (n - 1) <$> s
136+ f (Skip s ) = Skip s' where s' = drop n <$> s
137+ f Done = Done
138+
139+ dropWhile :: forall f a. (Applicative f ) => (a -> Boolean ) -> ListT f a -> ListT f a
140+ dropWhile f = stepMap g where
141+ g (Yield a s ) = if f a then Skip (dropWhile f <$> s ) else Yield a s
142+ g (Skip s ) = Skip $ dropWhile f <$> s
143+ g Done = Done
144+
145+ filter :: forall f a. (Functor f ) => (a -> Boolean ) -> ListT f a -> ListT f a
146+ filter f = stepMap g where
147+ g (Yield a s ) = if f a then Yield a s' else Skip s' where s' = filter f <$> s
148+ g (Skip s ) = Skip s' where s' = filter f <$> s
149+ g Done = Done
150+
151+ mapMaybe :: forall f a b. (Functor f ) => (a -> Maybe b ) -> ListT f a -> ListT f b
152+ mapMaybe f = stepMap g where
153+ g (Yield a s ) = (fromMaybe Skip (Yield <$> (f a))) (mapMaybe f <$> s )
154+ g (Skip s ) = Skip $ mapMaybe f <$> s
155+ g Done = Done
156+
157+ catMaybes :: forall f a. (Functor f ) => ListT f (Maybe a ) -> ListT f a
158+ catMaybes = mapMaybe id
159+
160+ uncons :: forall f a. (Monad f ) => ListT f a -> f (Maybe (Tuple a (ListT f a)))
161+ uncons l = runListT l >>= g where
162+ g (Yield a s ) = pure $ Just $ Tuple a (force s )
163+ g (Skip s ) = uncons (force s )
164+ g Done = pure Nothing
165+
166+ head :: forall f a. (Monad f ) => ListT f a -> f (Maybe a )
167+ head l = ((<$>) fst ) <$> uncons l
168+
169+ tail :: forall f a. (Monad f ) => ListT f a -> f (Maybe (ListT f a))
170+ tail l = ((<$>) snd ) <$> uncons l
171+
172+ foldl :: forall f a b. (Monad f ) => (b -> a -> b ) -> b -> ListT f a -> f b
173+ foldl f = loop where
174+ loop b l = uncons l >>= g where
175+ g Nothing = pure b
176+ g (Just (Tuple a as)) = loop (f b a ) as
177+
178+ scanl :: forall f a b. (Monad f ) => (b -> a -> b ) -> b -> ListT f a -> ListT f b
179+ scanl f b l = unfold g (Tuple b l ) where
180+ g (Tuple b l ) = h <$> runListT l where
181+ h (Yield a s ) = Just $ Tuple (Tuple b' (force s)) b' where b' = f b a
182+ h (Skip s ) = Just $ Tuple (Tuple b (force s)) b
183+ h Done = Nothing
184+
185+ zipWith' :: forall f a b c. (Monad f ) => (a -> b -> f c ) -> ListT f a -> ListT f b -> ListT f c
186+ zipWith' f = loop where
187+ loop fa fb =
188+ wrapEffect $ do
189+ ua <- uncons fa
190+ ub <- uncons fb
191+ g ua ub
192+ where g _ Nothing = pure nil
193+ g Nothing _ = pure nil
194+ g (Just (Tuple ha ta)) (Just (Tuple hb tb)) = (flip prepend' ) (defer \_ -> zipWith' f ta tb ) <$> (f ha hb )
195+
196+ zipWith :: forall f a b c. (Monad f ) => (a -> b -> c ) -> ListT f a -> ListT f b -> ListT f c
197+ zipWith f = zipWith' g where
198+ g a b = pure $ f a b
0 commit comments