I didn't say arbitrary.
At the risk of an overly complicated example, just because I have it handy:
In the following type: rep 1000 "a" folds in logarithmic time, lots of
operations actually get to exploit the obliviousness of (*>) and (<*) and
(>>) to one argument or the other's values to exploit replication heavily
for parts of the result as well. This is needed to match the asymptotics of
Fritz Henglein's linear time table joins in a final encoding for instance.
data Table a = Table
{ count :: {-# UNPACK #-} !Int
, runTable :: forall r. Monoid r => (a -> r) -> r
}
instance IsList (Table a) where
type Item (Table a) = a
fromList = foldMap pure
toList = Foldable.toList
fromListN n xs = Table n (`foldMap` xs)
instance Functor Table where
fmap f (Table i m) = Table i $ \k -> m (k.f)
instance Foldable Table where
foldMap f (Table _ m) = m f
foldr f z (Table _ m) = m (Endo . f) `appEndo` z
instance Monoid (Table a) where
mempty = Table 0 $ \_ -> mempty
mappend (Table i m) (Table j n) = Table (i + j) $ \k -> m k `mappend` n k
newtype Ap f a = Ap { runAp :: f a }
instance (Applicative f, Monoid a) => Monoid (Ap f a) where
mempty = Ap (pure mempty)
mappend (Ap m) (Ap n) = Ap (liftA2 mappend m n)
instance Traversable Table where
-- this reassembles the result with sharing!
traverse f = runAp . foldMap (Ap . fmap pure . f)
instance Applicative Table where
pure a = Table 1 $ \k -> k a
Table n as <*> Table m bs = Table (n * m) $ \k -> as $ \f -> bs (k . f)
Table n as <* Table m _ = Table (n * m) $ \k -> as (rep m . k)
Table n _ *> Table m bs = Table (n * m) $ rep n . bs
-- peasant multiplication
rep :: Monoid m => Int -> m -> m
rep y0 x0
| y0 <= 0 = mempty
| otherwise = f x0 y0
where
f x y
| even y = f (mappend x x) (quot y 2)
| y == 1 = x
| otherwise = g (mappend x x) (quot (y - 1) 2) x
g x y z
| even y = g (mappend x x) (quot y 2) z
| y == 1 = mappend x z
| otherwise = g (mappend x x) (quot (y - 1) 2) (mappend x z)
bag :: (forall m. Monoid m => (a -> m) -> m) -> Table a
bag k = Table (getSum $ k $ \_ -> Sum 1) k
instance Monad Table where
return a = Table 1 $ \k -> k a
as >>= f = bag $ \k -> runTable as $ \a -> runTable (f a) k
(>>) = (*>)
fail _ = empty
instance MonadZip Table where
-- we can handle this in a smarter fashion now
mzipWith k m n = foldMap pure $ mzipWith k (Foldable.toList m)
(Foldable.toList n)
munzip m = (fmap fst m, fmap snd m)
instance Alternative Table where
empty = Table 0 $ \_ -> mempty
Table m as <|> Table n bs = Table (m + n) $ \k -> as k `mappend` bs k
instance MonadPlus Table where
mzero = Table 0 $ \_ -> mempty
Table m as `mplus` Table n bs = Table (m + n) $ \k -> as k `mappend` bs k
instance MonadFix Table where
mfix a2ba = foldMap pure $ mfix (Foldable.toList . a2ba)
etc.
On Sun, Feb 1, 2015 at 4:17 PM, Roman Cheplyaka
On 01/02/15 22:56, Edward Kmett wrote:
sum = getSum . foldMap sum
is the implementation that ensures that it doesn't destroy the asymptotics of the number of uses of 'mappend' in foldMap.
The right container can readily fold 2^20th a's with 20 mappends.
Fold 2^20 *arbitrary* a's? What kind of container is that?
Roman