-- | Sum and product functors, with the usual instances. 
-- You can in principle use these to extend existing expressions, for example
--
-- > type ExtendedExpression = Mu (Expr :+: Custom)
--
-- This module uses the TypeOperators language extension for convenience.
--

{-# LANGUAGE TypeOperators #-}
module Data.Generics.Fixplate.Functor 
  ( (:+:) (..) 
  , (:*:) (..)
  )
  where

--------------------------------------------------------------------------------

import Prelude hiding ( foldl , foldr , mapM )

import Control.Applicative ()
import Control.Monad ( liftM )

import Data.Generics.Fixplate

--------------------------------------------------------------------------------

-- | Sum of two functors
data (f :+: g) a = InL (f a) | InR (g a) deriving (Eq,Ord,Show)

-- | Product of two functors
data (f :*: g) a = (f a) :*: (g a)       deriving (Eq,Ord,Show)

infixl 6 :+:
infixl 7 :*:

--------------------------------------------------------------------------------

instance (Functor f, Functor g) => Functor (f :+: g) where
  fmap h (InL x) = InL (fmap h x)
  fmap h (InR y) = InR (fmap h y)

instance (Foldable f, Foldable g) => Foldable (f :+: g) where
  foldl h a (InL x) = foldl h a x
  foldl h a (InR y) = foldl h a y

  foldr h a (InL x) = foldr h a x 
  foldr h a (InR y) = foldr h a y 

instance (Traversable f, Traversable g) => Traversable (f :+: g) where
  traverse h (InL x) = InL <$> traverse h x
  traverse h (InR y) = InR <$> traverse h y

  mapM h (InL x) = liftM InL $ mapM h x
  mapM h (InR y) = liftM InR $ mapM h y

--------------------------------------------------------------------------------

instance (Functor f, Functor g) => Functor (f :*: g) where
  fmap h (x :*: y) = fmap h x :*: fmap h y

instance (Foldable f, Foldable g) => Foldable (f :*: g) where
  foldl h a (x :*: y) = let a' = foldl h a x in foldl h a' y
  foldr h a (x :*: y) = let a' = foldr h a y in foldr h a' x

instance (Traversable f, Traversable g) => Traversable (f :*: g) where
  traverse h (x :*: y) = (:*:) <$> traverse h x <*> traverse h y
  mapM h (x :*: y) = do 
    x1 <- mapM h x
    y1 <- mapM h y
    return (x1 :*: y1)

--------------------------------------------------------------------------------

app_prec , mul_prec :: Int
app_prec = 10 
mul_prec = 7 

--------------------------------------------------------------------------------

instance (EqF f, EqF g) => EqF (f :+: g) where 
  equalF (InL x) (InL y) = equalF x y
  equalF (InR x) (InR y) = equalF x y
  equalF _       _       = False

instance (OrdF f, OrdF g) => OrdF (f :+: g) where
  compareF (InL x) (InL y) = compareF x y
  compareF (InR x) (InR y) = compareF x y
  compareF (InL _) (InR _) = LT
  compareF (InR _) (InL _) = GT

instance (ShowF f, ShowF g) => ShowF (f :+: g) where 
  showsPrecF d (InL x) = showParen (d>app_prec) 
    $ showString "InL " 
    . showsPrecF (app_prec+1) x
  showsPrecF d (InR x) = showParen (d>app_prec) 
    $ showString "InR " 
    . showsPrecF (app_prec+1) x

--------------------------------------------------------------------------------

instance (EqF f, EqF g) => EqF (f :*: g) where 
  equalF (x1 :*: x2) (y1 :*: y2) = equalF x1 y1 && equalF x2 y2

instance (OrdF f, OrdF g) => OrdF (f :*: g) where
  compareF (x1 :*: x2) (y1 :*: y2) = case compareF x1 y1 of 
    LT -> LT
    GT -> GT
    EQ -> compareF  x2 y2 

instance (ShowF f, ShowF g) => ShowF (f :*: g) where 
  showsPrecF d (x :*: y) = showParen (d>mul_prec) 
    $ showsPrecF (mul_prec+1) x
    . showString " :*: " 
    . showsPrecF (mul_prec+1) y

--------------------------------------------------------------------------------