{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveFunctor #-}

module Exercises.ChapterFourteen
  ( filterF
  , fold
  , traverse
  ) where

import Prelude
       (Applicative, Bool, Functor, Maybe(..), Show, (++), (.), (<$>),
        (<*>), const, id, pure)

class Monoid a where
  mempty :: a
  mappend :: a -> a -> a
  -- mconcat :: [a] -> a
  -- mconcat = foldr mappend mempty

instance (Monoid a, Monoid b) => Monoid (a, b)
  -- mempty :: (a,b)
                     where
  mempty = (mempty, mempty)
  -- mappend :: (a,b) -> (a,b) -> (a,b)
  (x1, y1) `mappend` (x2, y2) = (x1 `mappend` x2, y1 `mappend` y2)

instance Monoid b => Monoid (a -> b)
  -- mempty :: a -> b
                      where
  mempty = const mempty
  -- mappend :: (a -> b) -> (a -> b) -> (a -> b)
  f `mappend` g = \x -> f x `mappend` g x

class Foldable t
    -- | Combine the elements of a structure using a monoid.
                                                             where
  fold :: Monoid m => t m -> m
    -- | Map each element of the structure to a monoid,
    -- and combine the results.
  foldMap :: Monoid m => (a -> m) -> t a -> m
    -- | Right-associative fold of a structure.
    --
    -- In the case of lists, 'foldr', when applied to a binary operator, a
    -- starting value (typically the right-identity of the operator), and a
    -- list, reduces the list using the binary operator, from right to left:
    --
    -- > foldr f z [x1, x2, ..., xn] == x1 `f` (x2 `f` ... (xn `f` z)...)
    --
    -- Note that, since the head of the resulting expression is produced by
    -- an application of the operator to the first element of the list,
    -- 'foldr' can produce a terminating expression from an infinite list.
    --
    -- For a general 'Foldable' structure this should be semantically identical
    -- to,
    --
    -- @foldr f z = 'List.foldr' f z . 'toList'@
    --
  foldr :: (a -> b -> b) -> b -> t a -> b
    -- | Left-associative fold of a structure.
    --
    -- In the case of lists, 'foldl', when applied to a binary
    -- operator, a starting value (typically the left-identity of the operator),
    -- and a list, reduces the list using the binary operator, from left to
    -- right:
    --
    -- > foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn
    --
    -- Note that to produce the outermost application of the operator the
    -- entire input list must be traversed. This means that 'foldl'' will
    -- diverge if given an infinite list.
    --
    -- Also note that if you want an efficient left-fold, you probably want to
    -- use 'foldl'' instead of 'foldl'. The reason for this is that latter does
    -- not force the "inner" results (e.g. @z `f` x1@ in the above example)
    -- before applying them to the operator (e.g. to @(`f` x2)@). This results
    -- in a thunk chain @O(n)@ elements long, which then must be evaluated from
    -- the outside-in.
    --
    -- For a general 'Foldable' structure this should be semantically identical
    -- to,
    --
    -- @foldl f z = 'List.foldl' f z . 'toList'@
    --
  foldl :: (b -> a -> b) -> b -> t a -> b

class (Functor t, Foldable t) =>
      Traversable t
    -- | Map each element of a structure to an action, evaluate these actions
    -- from left to right, and collect the results. For a version that ignores
    -- the results see 'Data.Foldable.traverse_'.
                                                  where
  traverse :: Applicative f => (a -> f b) -> t a -> f (t b)

instance Monoid [a] where
  mempty = []
  mappend = (++)

instance Foldable Maybe
  -- fold :: Monoid m => t m -> m
                                  where
  fold = foldMap id
  -- foldMap :: Monoid m => (a -> m) -> t a -> m
  foldMap f = foldr (mappend . f) mempty
  -- foldr :: (a -> b -> b) -> b -> t a -> b
  foldr _ z Nothing = z
  foldr f z (Just x) = f x z
  -- foldl :: (b -> a -> b) -> b -> t a -> b
  foldl _ z Nothing = z
  foldl f z (Just x) = f z x

instance Traversable Maybe
  -- traverse :: Applicative f => (a -> f b) -> t a -> f (t b)
                                                               where
  traverse _ Nothing = pure Nothing
  traverse f (Just x) = Just <$> f x

data Tree a
  = Leaf
  | Node (Tree a)
         a
         (Tree a)
  deriving (Functor, Show)

instance Monoid (Tree a) where
  mempty = Leaf
  Leaf `mappend` x = x
  (Node l a r) `mappend` x = Node l a (r `mappend` x)

instance Foldable Tree
  -- fold :: Monoid m => t m -> m
                                  where
  fold = foldMap id
  -- foldMap :: Monoid m => (a -> m) -> t a -> m
  foldMap _ Leaf = mempty
  foldMap f (Node l k r) = foldMap f l `mappend` f k `mappend` foldMap f r
  -- foldr :: (a -> b -> b) -> b -> t a -> b
  foldr _ z Leaf = z
  foldr f z (Node l k r) = foldr f (f k (foldr f z r)) l
  -- foldl :: (b -> a -> b) -> b -> t a -> b
  foldl _ z Leaf = z
  foldl f z (Node l k r) = foldl f (f (foldl f z r) k) l

instance Traversable Tree
  -- traverse :: Applicative f => (a -> f b) -> t a -> f (t b)
                                                               where
  traverse _ Leaf = pure Leaf
  traverse f (Node l x r) = Node <$> traverse f l <*> f x <*> traverse f r

filterF :: Foldable t => (a -> Bool) -> t a -> [a]
filterF p = foldMap (\x -> [x | p x])
