{-# LANGUAGE StandaloneDeriving, GeneralizedNewtypeDeriving #-}

module Data.TrieMap.Applicative where

import Control.Applicative
import Control.Arrow
import Control.Monad

import Data.Monoid hiding (Dual)

newtype Id a = Id {unId :: a}
newtype WM w m a = WM {runWM :: m (w, a)}

instance Functor First where
	fmap f (First m) = First (fmap f m)

instance Functor Last where
	fmap f (Last m) = Last (fmap f m)

instance Monad First where
	return = First . return
	First m >>= k = First (m >>= getFirst . k)

instance Monad Last where
	return = Last . return
	Last m >>= k = Last (m >>= getLast . k)

instance Functor m => Functor (WM w m) where
	fmap f (WM x) = WM (fmap (second f) x)

instance (Applicative m, Monoid w) => Applicative (WM w m) where
	pure x = WM (pure (mempty, x))
	WM f <*> WM x = WM (fmap (\ (fW, ff) (xW, xx) -> (fW `mappend` xW, ff xx)) f <*> x)

instance (Alternative m, Monoid w) => Alternative (WM w m) where
	empty = WM empty
	WM a <|> WM b = WM (a <|> b)

write :: (Functor m, Monoid w) => w -> WM w m a -> WM w m a
write w (WM m) = WM (fmap (\ (v, xx) -> (v `mappend` w, xx)) m)

instance Applicative Id where
	pure = Id
	Id f <*> Id x = Id (f x)

instance Functor Id where
	fmap f (Id x) = Id (f x)

instance MonadPlus First where
	mzero = mempty
	mplus = mappend

instance MonadPlus Last where
	mzero = mempty
	mplus = mappend

-- instance Monad First where
-- 	return x = First (Just x)
-- 	First Nothing >>= _ = First Nothing
-- 	First (Just x) >>= k = k x
-- 
-- instance Monad Last

(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(f .: g) x y = f (g x y)

(<.>) :: Functor f => (b -> c) -> (a -> f b) -> a -> f c
f <.> g = fmap f . g

(<.:>) :: Functor f => (c -> d) -> (a -> b -> f c) -> a -> b -> f d
(f <.:> g) x y = f <$> g x y
{-
(<|>) :: MonadPlus m => m a -> m a -> m a
(<|>) = mplus-}

instance Applicative First where
	pure = return
	(<*>) = ap

instance Alternative First where
	empty = mempty
	(<|>) = mplus

instance Applicative Last where
	pure = return
	(<*>) = ap

instance Alternative Last where
	empty = mempty
	(<|>) = mplus

newtype Dual f a = Dual {runDual :: f a}

instance Functor f => Functor (Dual f) where
	fmap f (Dual x) = Dual (fmap f x)

instance Applicative f => Applicative (Dual f) where
	pure = Dual . pure
	Dual f <*> Dual x = Dual (flip ($) <$> x <*> f)

instance Alternative f => Alternative (Dual f) where
	empty = Dual empty
	Dual a <|> Dual b = Dual (b <|> a)