{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}

----------------------------------------------------------------------
-- |
-- Module      :  Data.StarToStar.Contra
-- Copyright   :  (c) Nicolas Frisby 2010
-- License     :  http://creativecommons.org/licenses/by-sa/3.0/
-- 
-- Maintainer  :  nicolas.frisby@gmail.com
-- Stability   :  experimental
-- Portability :  see LANGUAGE pragmas
-- 
-- Instances for the fundamental * -> * types that require
-- contravariance. Another O is defined to disambiguate the two valid Functor
-- and Cofunctor instances.
----------------------------------------------------------------------

module Data.StarToStar.Contra where

import qualified Data.StarToStar as DS

import Control.Arrow ((***))

import Control.Functor.Contra



instance Cofunctor DS.V where cofmap _ = undefined

instance Cofunctor DS.U where cofmap _ DS.U = DS.U

instance Cofunctor (DS.C b) where cofmap _ = DS.onC DS.toC



instance Cofunctor (DS.K r) where cofmap f = DS.toK . DS.onK (. f)



instance (Functor f, Cofunctor g) => Cofunctor (DS.O f g) where
  cofmap = DS.underO . fmap . cofmap

newtype O f g a = O (f (g a))
instance (Cofunctor f, Cofunctor g) => Functor (O f g) where
  fmap = underO . cofmap . cofmap
instance (Cofunctor f, Functor g) => Cofunctor (O f g) where
  cofmap = underO . cofmap . fmap
onO :: (f (g a) -> b) -> O f g a -> b
onO f (O x) = f x
underO :: (f (g a) -> h (i b)) -> O f g a -> O h i b
underO f = toO . onO f
toO :: f (g a) -> O f g a
toO x = O x
fromO :: O f g a -> f (g a)
fromO x = onO id x

instance (Cofunctor f, Cofunctor g) => Cofunctor (DS.S f g) where
  cofmap f = DS.onS' (DS.L . cofmap f) (DS.R . cofmap f)

instance (Cofunctor f, Cofunctor g) => Cofunctor (DS.P f g) where
  cofmap f = DS.underP (cofmap f *** cofmap f)

instance (Cofunctor f, Functor g) => Functor (DS.F f g) where
  fmap f = DS.underF ((fmap f .) . (. cofmap f))
instance (Functor f, Cofunctor g) => Cofunctor (DS.F f g) where
  cofmap f = DS.underF ((cofmap f .) . (. fmap f))

instance Cofunctor (ff (DS.Fix ff)) => Cofunctor (DS.Fix ff) where
  cofmap = DS.underFix . cofmap