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