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

----------------------------------------------------------------------
-- |
-- Module      :  Data.StarToStar
-- 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
-- 
-- Fundamental * -> * types and (covariant) instances for the common classes:
-- Functor, Foldable, and Traversable.
----------------------------------------------------------------------

module Data.StarToStar where

import Data.Foldable; import Data.Monoid
import Data.Traversable; import Control.Applicative

import Control.Arrow ((***))



data V a
instance Functor V where fmap _ = undefined
instance Foldable V where foldMap _ = mempty
instance Traversable V where traverse _ = undefined

data U a = U
instance Functor U where fmap _ U = U
instance Foldable U where foldMap _ = mempty
instance Traversable U where traverse _ U = pure U

data C x a = C x
instance Functor (C x) where fmap _ = onC toC
instance Foldable (C x) where foldMap _ = mempty
instance Traversable (C x) where traverse _ = liftA toC . onC pure
onC :: (x -> b) -> C x a -> b
onC f = f . fromC
underC :: (x -> y) -> C x a -> C y b
underC f = toC . onC f
toC :: x -> C x a
toC x = C x
fromC :: C x a -> x
fromC (C x) = x



data I a = I a
instance Functor I where fmap = underI
instance Foldable I where foldMap = onI
instance Traversable I where traverse f = liftA toI . onI f
onI :: (a -> b) -> I a -> b
onI f = f . fromI
underI :: (a -> b) -> I a -> I b
underI f = toI . onI f
toI :: a -> I a
toI a = I a
fromI :: I a -> a
fromI (I a) = a

newtype E e a = E (e -> a)
instance Functor (E e) where fmap f = underE (f .)
onE :: ((e -> a) -> b) -> E e a -> b
onE f = f . fromE
underE :: ((e -> a) -> (f -> b)) -> E e a -> E f b
underE f = toE . onE f
toE :: (e -> a) -> E e a
toE f = E f
fromE :: E e a -> (e -> a)
fromE (E f) = f
infixr :->
type (:->) = E

newtype K r a = K (a -> r)
onK :: ((a -> r) -> b) -> K r a -> b
onK f (K x) = f x
underK :: ((a -> r) -> (b -> s)) -> K r a -> K s b
underK f = toK . onK f
toK :: (a -> r) -> K r a
toK f = K f
fromK :: K r a -> a -> r
fromK x = onK id x
infixr :<-
type (:<-) = K



newtype O f g a = O (f (g a))
instance (Functor f, Functor g) => Functor (O f g) where
  fmap = underO . fmap . fmap
instance (Foldable f, Foldable g) => Foldable (O f g) where
  foldMap = onO . foldMap . foldMap
instance (Traversable f, Traversable g) => Traversable (O f g) where
  traverse f = liftA toO . (onO . traverse . traverse $ f)
onO :: (f (g a) -> b) -> O f g a -> b
onO f = f . fromO
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 (O x) = x
infixr 9 :.
type (:.) = O

data S f g a = L (f a) | R (g a)
instance (Functor f, Functor g) => Functor (S f g) where
  fmap f = onS' (L . fmap f) (R . fmap f)
instance (Foldable f, Foldable g) => Foldable (S f g) where
  foldMap f = onS' (foldMap f) (foldMap f)
instance (Traversable f, Traversable g) => Traversable (S f g) where
  traverse f = onS' (liftA L . traverse f) (liftA R . traverse f)
onS :: (Either (f a) (g a) -> b) -> S f g a -> b
onS f = f . fromS
onS' :: (f a -> b) -> (g a -> b) -> S f g a -> b
onS' f g = either f g . fromS
underS :: (Either (f a) (g a) -> Either (h b) (i b)) -> S f g a -> S h i b
underS f = toS . onS f
toS :: Either (f a) (g a) -> S f g a
toS x = either L R x
fromS :: S f g a -> Either (f a) (g a)
fromS x = case x of
  L fa -> Left fa
  R ga -> Right ga
infixl 6 :+
type (:+) = S

data P f g a = P (f a) (g a)
instance (Functor f, Functor g) => Functor (P f g) where
  fmap f = underP (fmap f *** fmap f)
instance (Foldable f, Foldable g) => Foldable (P f g) where
  foldMap f = uncurry mappend . onP (foldMap f *** foldMap f)
instance (Traversable f, Traversable g) => Traversable (P f g) where
  traverse f = (uncurry . liftA2 . curry $ toP) . onP (traverse f *** traverse f)
onP :: ((f a, g a) -> b) -> P f g a -> b
onP f = f . fromP
underP :: ((f a, g a) -> (h b, i b)) -> P f g a -> P h i b
underP f = toP . onP f
toP :: (f a, g a) -> P f g a
toP (fa, ga) = P fa ga
fromP :: P f g a -> (f a, g a)
fromP (P fa ga) = (fa, ga)
infixl 7 :*
type (:*) = P



newtype F f g a = F (f a -> g a)
onF :: ((f a -> g a) -> b) -> F f g a -> b
onF f = f . fromF
underF :: ((f a -> g a) -> (h b -> i b)) -> F f g a -> F h i b
underF f = toF . onF f
toF :: (f a -> g a) -> F f g a
toF x = F x
fromF :: F f g a -> f a -> g a
fromF (F x) = x



newtype Fix ff a = In (ff (Fix ff) a)
instance Functor (ff (Fix ff)) => Functor (Fix ff) where
  fmap = underFix . fmap
instance Foldable (ff (Fix ff)) => Foldable (Fix ff) where
  foldMap f = foldMap f . fromFix
instance Traversable (ff (Fix ff)) => Traversable (Fix ff) where
  traverse f = liftA toFix . traverse f . fromFix
underFix :: (ff (Fix ff) a -> gg (Fix gg) b) -> Fix ff a -> Fix gg b
underFix f = toFix . f . fromFix
toFix :: ff (Fix ff) a -> Fix ff a
toFix x = In x
fromFix :: Fix ff a -> ff (Fix ff) a
fromFix (In x) = x



newtype Flip op f g a = Flip (op g f a)
instance Functor (op g f) => Functor (Flip op f g) where
  fmap f = underFlip (fmap f)
instance Foldable (op g f) => Foldable (Flip op f g) where
  foldMap f = onFlip (foldMap f)
instance Traversable (op g f) => Traversable (Flip op f g) where
  traverse f = liftA toFlip . onFlip (traverse f)
onFlip :: (op g f a -> b) -> Flip op f g a -> b
onFlip f = f . fromFlip
underFlip :: (op g f a -> op' g' f' a') -> Flip op f g a -> Flip op' f' g' a'
underFlip f = toFlip . onFlip f
toFlip :: op g f a -> Flip op f g a
toFlip x = Flip x
fromFlip :: Flip op f g a -> op g f a
fromFlip (Flip x) = x