    {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    {- |
    This module provides a type-indexed / parameterized version of the 'Functor' and 'Applicative' classes.
    -}
    module Control.Applicative.Indexed where

    import Control.Applicative (Applicative(pure, (<*>)))

    ------------------------------------------------------------------------------
    -- * type-indexed / parameterized classes
    ------------------------------------------------------------------------------

    -- | a class for a 'type-indexed' or 'paramaterized' functor
    --
    -- note: not sure what the most correct name is for this class, or if
    -- it exists in a well supported library already.
    class IndexedFunctor f where
        -- | imap is similar to fmap
        imap :: (x -> y) -- ^ function to apply to first parameter
             -> (a -> b) -- ^ function to apply to second parameter
             -> f x a    -- ^ indexed functor
             -> f y b

    -- | a class for a 'type-indexed' or 'paramaterized' applicative functors
    --
    -- note: not sure what the most correct name is for this class, or if
    -- it exists in a well supported library already.
    class (IndexedFunctor f) => IndexedApplicative f where
        -- | similar to 'pure'
        ipure   :: x -> a -> f x a
        -- | similar to '<*>'
        (<<*>>) :: f (x -> y) (a -> b) -> f x a -> f y b
        -- | similar to 'Control.Applicative.*>'
        (*>>) :: f x a -> f y b -> f y b
        (*>>) = liftIA2 (const id) (const id)
        -- | similar to 'Control.Applicative.<*'
        (<<*) :: f x a -> f y b -> f x a
        (<<*) = liftIA2 const const

    infixl 4 <<*>>, <<*, *>> -- , <<**>>

    -- | similar to 'Data.Functor.<$>'. An alias for @imap id@
    (<<$>>) :: IndexedFunctor f => (a -> b) -> f y a -> f y b
    (<<$>>) = imap id

    infixl 4 <<$>>

    -- | A variant of '<<*>>' with the arguments reversed.
    (<<**>>) :: (IndexedApplicative f) => f x a -> f (x -> y) (a -> b) -> f y b
    (<<**>>) = liftIA2 (flip ($)) (flip ($))

    -- | Lift a function to actions.
    -- This function may be used as a value for `imap` in a `IndexedFunctor` instance.
    liftIA :: (IndexedApplicative f) => (a -> b) -> (x -> y) -> f a x -> f b y
    liftIA f g a = ipure f g <<*>> a

    -- | Lift a binary function to actions.
    liftIA2 :: (IndexedApplicative f) => (a -> b -> c) -> (x -> y -> z) -> f a x -> f b y -> f c z
    liftIA2 f g a b = ipure f g <<*>> a <<*>> b

    -- | Lift a binary function to actions.
    liftIA3 :: (IndexedApplicative f) => (a -> b -> c -> d) -> (w -> x -> y -> z) -> f a w -> f b x -> f c y -> f d z
    liftIA3 f g a b c = ipure f g <<*>> a <<*>> b <<*>> c

    ------------------------------------------------------------------------------
    -- * WrappedApplicative
    ------------------------------------------------------------------------------

    -- | a wrapper which lifts a value with an 'Applicative' instance so that it can be used as an 'IndexedFunctor' or 'IndexedApplicative'
    --
    -- > d :: WrappedApplicative Maybe y Char
    -- > d = WrappedApplicative (Just succ) <<*>> WrappedApplicative (Just 'c')
    newtype WrappedApplicative f index a = WrappedApplicative { unwrapApplicative :: f a }
        deriving (Functor, Applicative, Monad, Eq, Ord, Read, Show)

    instance (Functor f) => IndexedFunctor (WrappedApplicative f) where
        imap f g (WrappedApplicative a) = WrappedApplicative (fmap g a)

    instance (Applicative f) => IndexedApplicative (WrappedApplicative f) where
        ipure x a = WrappedApplicative (pure a)
        (WrappedApplicative f) <<*>> (WrappedApplicative a) = WrappedApplicative (f <*> a)