{-# LANGUAGE FlexibleContexts #-}
-- |A module describing applicative functors
module Clean.Applicative(
  module Clean.Functor,module Clean.Unit,

  Applicative(..),
  ZipList(..),ZipTree(..),Backwards(..),

  (*>),(<*),ap
  ) where

import Clean.Monoid
import Clean.Functor
import Clean.Classes
import Clean.Unit
import Clean.Core
import Data.Tree
import Clean.Foldable

instance Applicative (Either a)
instance Monad (Either a) where join (Right a) = a
                                join (Left a) = Left a
instance Applicative ((->) a) 
instance Monad ((->) a) where join f x = f x x
instance Monoid w => Applicative ((,) w)
instance Monoid w => Monad ((,) w) where
  join ~(w,~(w',a)) = (w+w',a)
instance Applicative []
instance Monad [] where join = fold
instance Applicative Tree
instance Monad Tree where
  join (Node (Node a subs) subs') = Node a (subs + map join subs')

{-|
A wrapper type for lists with zipping Applicative instances, such that
@ZipList [f1,...,fn] '<*>' ZipList [x1,...,xn] == ZipList [f1 x1,...,fn xn]@
-}
newtype ZipList a = ZipList { getZipList :: [a] }
instance Nil a => Nil (ZipList a) where zero = pure zero
instance Monoid a => Monoid (ZipList a) where
  a + b = (+)<$>a<*>b
instance Functor ZipList where
  map f (ZipList l) = ZipList (map f l)
instance Unit ZipList where
  pure a = ZipList (repeat a)
    where repeat a = a:repeat a
instance Applicative ZipList where
  ZipList fs <*> ZipList xs = ZipList (zip fs xs)
    where zip (f:fs) (x:xs) = f x:zip fs xs
          zip _ _ = []
deriving instance Foldable ZipList

-- |The Tree equivalent to ZipList
newtype ZipTree a = ZipTree (Tree a)
instance Functor ZipTree where
  map f (ZipTree t) = ZipTree (map f t)
instance Unit ZipTree where
  pure a = ZipTree (Node a (getZipList (pure (pure a))))
instance Applicative ZipTree where
  ZipTree (Node f fs) <*> ZipTree (Node x xs) =
    ZipTree (Node (f x) (getZipList ((<*>)<$>ZipList fs<*>ZipList xs)))
deriving instance Foldable ZipTree

-- |A wrapper for Applicative functors with action executed in the reverse order
newtype Backwards f a = Backwards { forwards :: f a }
deriving instance Nil (f a) => Nil (Backwards f a)
deriving instance Monoid (f a) => Monoid (Backwards f a)
deriving instance Unit f => Unit (Backwards f)
deriving instance Functor f => Functor (Backwards f)
instance Applicative f => Applicative (Backwards f) where
  Backwards fs <*> Backwards xs = Backwards (map (flip ($)) xs <*> fs)

ap = (<*>)
a *> b = flip const<$>a<*>b
a <* b = const<$>a<*>b