-----------------------------------------------------------------------------
--
-- Module      :  Control.GeneralisedFunctor.Functor
-- Copyright   :
-- License     :  AllRightsReserved
--
-- Maintainer  :  clintonmead@gmail.com
-- Stability   :  Experimental
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}

module Control.GeneralisedFunctor.Functor (
  OrdinaryFunctorParam,
  FunctorParam,
  Functor(fmap, FunctorInput, FunctorOutput, FunctorCategory),
  ExoFunctor(exoMap, ExoInput, ExoOutput),
  ContraFunctorParam,
  ContraFunctor(contramap, ContraFunctorInput, ContraFunctorOutput, ContraFunctorCategory),
  ExoContraFunctor(exoContraMap, ExoContraInput, ExoContraOutput),
) where

import Control.Category (Category, (.))
import Prelude hiding (Functor, fmap, (.))
import Control.Arrow (Kleisli, runKleisli, arr)
import qualified Data.Functor

import qualified Text.ParserCombinators.ReadP
import qualified Text.ParserCombinators.ReadPrec
import qualified Data.Monoid
import qualified GHC.Conc
import qualified Control.Exception
import qualified Control.Applicative
import qualified Data.Functor.Identity
import qualified System.Console.GetOpt
import qualified Control.Monad.ST
import qualified Data.Proxy
import qualified Control.Arrow
import qualified Control.Monad.ST.Lazy

type family FunctorParam (c :: * -> * -> *) t'

data OrdinaryFunctorParam (f :: * -> *)
data PairFunctorParam

type instance FunctorParam (->) ([] _1) = OrdinaryFunctorParam []
type instance FunctorParam (->) (IO _1) = OrdinaryFunctorParam IO
type instance FunctorParam (->) (Maybe _1) = OrdinaryFunctorParam Maybe
type instance FunctorParam (->) (Text.ParserCombinators.ReadP.ReadP _1) = OrdinaryFunctorParam Text.ParserCombinators.ReadP.ReadP
type instance FunctorParam (->) (Text.ParserCombinators.ReadPrec.ReadPrec _1) = OrdinaryFunctorParam Text.ParserCombinators.ReadPrec.ReadPrec
type instance FunctorParam (->) (Data.Monoid.Last _1) = OrdinaryFunctorParam Data.Monoid.Last
type instance FunctorParam (->) (Data.Monoid.First _1) = OrdinaryFunctorParam Data.Monoid.First
type instance FunctorParam (->) (GHC.Conc.STM _1) = OrdinaryFunctorParam GHC.Conc.STM
type instance FunctorParam (->) (Control.Exception.Handler _1) = OrdinaryFunctorParam Control.Exception.Handler
type instance FunctorParam (->) (Control.Applicative.ZipList _1) = OrdinaryFunctorParam Control.Applicative.ZipList
type instance FunctorParam (->) (Data.Functor.Identity.Identity _1) = OrdinaryFunctorParam Data.Functor.Identity.Identity
type instance FunctorParam (->) (System.Console.GetOpt.ArgDescr _1) = OrdinaryFunctorParam System.Console.GetOpt.ArgDescr
type instance FunctorParam (->) (System.Console.GetOpt.OptDescr _1) = OrdinaryFunctorParam System.Console.GetOpt.OptDescr
type instance FunctorParam (->) (System.Console.GetOpt.ArgOrder _1) = OrdinaryFunctorParam System.Console.GetOpt.ArgOrder
type instance FunctorParam (->) (r -> _1) = OrdinaryFunctorParam ((->) r)
type instance FunctorParam (->) (Either a _1) = OrdinaryFunctorParam (Either a)
type instance FunctorParam (->) (Control.Monad.ST.ST s _1) = OrdinaryFunctorParam (Control.Monad.ST.ST s)
type instance FunctorParam (->) (Data.Proxy.Proxy _1) = OrdinaryFunctorParam Data.Proxy.Proxy
type instance FunctorParam (->) (Control.Arrow.ArrowMonad a _1) = OrdinaryFunctorParam (Control.Arrow.ArrowMonad a)
type instance FunctorParam (->) (Control.Applicative.WrappedMonad m _1) = OrdinaryFunctorParam (Control.Applicative.WrappedMonad m)
type instance FunctorParam (->) (Control.Applicative.Const m _1) = OrdinaryFunctorParam (Control.Applicative.Const m)
type instance FunctorParam (->) (Control.Monad.ST.Lazy.ST s _1) = OrdinaryFunctorParam (Control.Monad.ST.Lazy.ST s)
type instance FunctorParam (->) (Data.Monoid.Alt f _1) = OrdinaryFunctorParam (Data.Monoid.Alt f)
type instance FunctorParam (->) (Control.Applicative.WrappedArrow a b _1) = OrdinaryFunctorParam (Control.Applicative.WrappedArrow a b)

type instance FunctorParam (->) (_1,_1) = PairFunctorParam

class Functor f where
  type FunctorInput f t
  type FunctorOutput f t
  type FunctorCategory f :: (* -> * -> *)
  fmap ::
    (
      Category c,
      f ~ FunctorParam c a', f ~ FunctorParam c b',
      a ~ FunctorInput f a', b ~ FunctorInput f b',
      a' ~ FunctorOutput f a, b' ~ FunctorOutput f b,
      c ~ FunctorCategory f
    ) => c a b -> c a' b'

instance (Data.Functor.Functor f) => Functor (OrdinaryFunctorParam f) where
  type FunctorInput  (OrdinaryFunctorParam f) (_1 t) = t
  type FunctorOutput (OrdinaryFunctorParam f) t = (f t)
  type FunctorCategory (OrdinaryFunctorParam f) = (->)
  fmap = Data.Functor.fmap

instance Functor PairFunctorParam where
  type FunctorInput  PairFunctorParam (t,t) = t
  type FunctorOutput PairFunctorParam t = (t,t)
  type FunctorCategory PairFunctorParam = (->)
  fmap f (x1, x2) = (f x1, f x2)


class ExoFunctor c c' where
  type ExoInput c c' t'
  type ExoOutput c c' t'
  exoMap ::
    (
      Category c, Category c',
      a ~ ExoInput c c' a', b ~ ExoInput c c' b',
      a' ~ ExoOutput c c' a, b' ~ ExoOutput c c' b
    ) => c a b -> c' a' b'

instance ExoFunctor c c where
  type ExoInput c c t = t
  type ExoOutput c c t = t
  exoMap = id

instance (Monad m) => ExoFunctor (Kleisli m) (->) where
  type ExoInput (Kleisli m) (->) (_1 t) = t
  type ExoOutput (Kleisli m) (->) t = m t
  exoMap f x = x >>= (runKleisli f)

instance (Monad m) => ExoFunctor (->) (Kleisli m) where
  type ExoInput (->) (Kleisli m) t = t
  type ExoOutput (->) (Kleisli m) t = t
  exoMap = arr

type family ContraFunctorParam (c :: * -> * -> *) t'

class ContraFunctor f where
  type ContraFunctorInput f x
  type ContraFunctorOutput f x
  type ContraFunctorCategory f :: (* -> * -> *)
  contramap ::
    (
      Category c,
      f ~ ContraFunctorParam c a', f ~ ContraFunctorParam c b',
      a ~ ContraFunctorInput f a', b ~ ContraFunctorInput f b',
      a' ~ ContraFunctorOutput f a, b' ~ ContraFunctorOutput f b,
      c ~ ContraFunctorCategory f
    ) => c a b -> c b' a'

data PreapplyContraFunctorParam a

type instance ContraFunctorParam (->) (_1 -> r) = PreapplyContraFunctorParam r

instance ContraFunctor (PreapplyContraFunctorParam r) where
  type ContraFunctorInput (PreapplyContraFunctorParam r) (a -> _1) = a
  type ContraFunctorOutput (PreapplyContraFunctorParam r) a = (a -> r)
  type ContraFunctorCategory (PreapplyContraFunctorParam r) = (->)
  contramap = flip (.)

class ExoContraFunctor c c' where
  type ExoContraInput c c' x
  type ExoContraOutput c c' x
  exoContraMap ::
    (
      Category c, Category c',
      a ~ ExoContraInput c c' a', b ~ ExoContraInput c c' b',
      a' ~ ExoContraOutput c c' a, b' ~ ExoContraOutput c c' b
    ) => c a b -> c' b' a'