{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types            #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Generics.Regular.Functions
-- Copyright   :  (c) 2008 Universiteit Utrecht
-- License     :  BSD3
--
-- Maintainer  :  generics@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Summary: Generic functionality for regular dataypes: mapM, flatten, zip,
-- equality, show and value generation.
-----------------------------------------------------------------------------

module Generics.Regular.Functions {- (

  -- * Functorial map function.
  Functor (..),
  
  -- * Monadic functorial map function.
  GMap (..), dft_fmapM,
  
  -- * Crush functions.
  Crush (..), dft_crush,
  flatten,

  -- * Zip functions.
  Zip (..), dft_fzipM,
  fzip,
  fzip',

  -- * Equality function.
  geq,

  -- * Show function.
  GShow (..), dft_gshow,
  gshow,
  
  -- * Functions for generating values that are different on top-level.
  LRBase (..),
  LR (..),
  left, dft_leftf,
  right, dft_rightf,
  
  -- * Functions for generating values that are different on top-level.
  Alg, Algebra,
  Fold, alg,
  fold,
  (&)  

) -} where

import Control.Monad

import Generics.Regular.Base


-----------------------------------------------------------------------------
-- Monadic functorial map function.
-----------------------------------------------------------------------------

-- | The @GMap@ class defines a monadic functorial map.
class GMap (f :: (* -> *) -> * -> *) where
  fmapM :: Monad m => (a -> m b) -> f es a -> m (f es b)

instance GMap I where
  fmapM f (I r) = liftM I (f r)

instance GMap (K a) where
  fmapM _ (K x)  = return (K x)

instance GMap (E e) where
  fmapM _ (E x)  = return (E x)

instance GMap U where
  fmapM _ U = return U

instance (GMap f, GMap g) => GMap (f :+: g) where
  fmapM f (L x) = liftM L (fmapM f x)
  fmapM f (R x) = liftM R (fmapM f x)


dft_fmapM :: (Monad m, Regular1 f, GMap (PF1 f))
          => (a -> m b) -> f es a -> m (f es b)
dft_fmapM f = liftM to1 . fmapM f . from1


-----------------------------------------------------------------------------
-- Crush functions.
-----------------------------------------------------------------------------

-- | The @Crush@ class defines a crush on functorial values. In fact,
-- @crush@ is a generalized @foldr@.
class Crush (f :: (* -> *) -> * -> *) where
  crush :: (a -> b -> b) -> b -> f es a -> b

instance Crush I where
  crush op e (I x) = x `op` e

instance Crush (K a) where
  crush _ e _ = e

instance Crush (E e) where
  crush _ e _ = e

instance Crush U where
  crush _ e _ = e

instance (Crush f, Crush g) => Crush (f :+: g) where
  crush op e (L x) = crush op e x
  crush op e (R y) = crush op e y

instance (Crush f, Crush g) => Crush (f :*: g) where
  crush op e (x :*: y) = crush op (crush op e y) x


dft_crush :: (Regular1 f, Crush (PF1 f)) => (a -> b -> b) -> b -> f es a -> b
dft_crush op e = crush op e . from1

-- | Flatten a structure by collecting all the elements present.
flatten :: Crush f => f es a -> [a]
flatten = crush (:) []


-----------------------------------------------------------------------------
-- Zip functions.
-----------------------------------------------------------------------------

-- | The @Zip@ class defines a monadic zip on functorial values.
class Zip (f :: (* -> *) -> * -> *) where
  fzipM :: Monad m => (a -> b -> m c) -> f es a -> f es b -> m (f es c)

instance Zip I where
  fzipM f (I x) (I y) = liftM I (f x y)

instance Eq a => Zip (K a) where
  fzipM _ (K x) (K y) 
    | x == y    = return (K x)
    | otherwise = fail "fzipM: structure mismatch"
{-
instance Eq (es e) => Zip (E e) where
  fzipM _ (E x) (E y) 
    | x == y    = return (E x)
    | otherwise = fail "fzipM: structure mismatch"
-}
instance Zip U where
  fzipM _ U U = return U

instance (Zip f, Zip g) => Zip (f :+: g) where
  fzipM f (L x) (L y) = liftM L (fzipM f x y)
  fzipM f (R x) (R y) = liftM R (fzipM f x y)
  fzipM _ _       _       = fail "fzipM: structure mismatch"

instance (Zip f, Zip g) => Zip (f :*: g) where
  fzipM f (x1 :*: y1) (x2 :*: y2) = 
    liftM2 (:*:) (fzipM f x1 x2)
                 (fzipM f y1 y2)


dft_fzipM :: (Monad m, Regular1 f, Zip (PF1 f)) 
          => (a -> b -> m c) -> f es a -> f es b -> m (f es c)
dft_fzipM f x y = liftM to1 $ fzipM f (from1 x) (from1 y)

-- | Functorial zip with a non-monadic function, resulting in a monadic value.
fzip  :: (Zip f, Monad m) => (a -> b -> c) -> f es a -> f es b -> m (f es c)
fzip f = fzipM (\x y -> return (f x y))

-- | Partial functorial zip with a non-monadic function.
fzip' :: Zip f => (a -> b -> c) -> f es a -> f es b -> f es c
fzip' f x y = maybe (error "fzip': structure mismatch") id (fzip f x y)


-----------------------------------------------------------------------------
-- Equality function.
-----------------------------------------------------------------------------

-- | Equality on values based on their structural representation.
geq :: (b ~ PF a, Regular a, Crush b, Zip b) => a -> a -> Bool
geq x y = maybe False (crush (&&) True) (fzip geq (from x) (from y))


-----------------------------------------------------------------------------
-- Show function.
-----------------------------------------------------------------------------

-- | The @GShow@ class defines a show on values.
class GShow (f :: (* -> *) -> * -> *) where
  gshowf :: (forall n. es n -> ShowS) -> (a -> ShowS) -> f es a -> ShowS

instance GShow I where
  gshowf _ g (I r) = g r

instance Show a => GShow (K a) where
  gshowf _ _ (K x) = shows x

instance Show e => GShow (E e) where
  gshowf f _ (E x) = f x

instance GShow U where
  gshowf _ _ U = id

instance (GShow f, GShow g) => GShow (f :+: g) where
  gshowf f g (L x) = gshowf f g x
  gshowf f g (R x) = gshowf f g x

instance (GShow f, GShow g) => GShow (f :*: g) where
  gshowf f g (x :*: y) = gshowf f g x . showChar ' ' . gshowf f g y


dft_gshow :: (Regular1 f, GShow (PF1 f)) 
          => (forall n. es n -> ShowS) ->  (a -> ShowS) -> f es a -> ShowS
dft_gshow f g = gshowf f g . from1
  
gshow :: (Regular a, GShow (PF a)) => (forall n. Es a n -> ShowS) -> a -> ShowS
gshow f x = gshowf f (gshow f) (from x)

-----------------------------------------------------------------------------
-- Functions for generating values that are different on top-level.
-----------------------------------------------------------------------------

-- | The @LRBase@ class defines two functions, @leftb@ and @rightb@, which 
-- should produce different values.
class LRBase a where
  leftb  :: a
  rightb :: a

instance LRBase Int where
  leftb  = 0
  rightb = 1

instance LRBase Char where
  leftb  = 'L'
  rightb = 'R'
 
instance LRBase a => LRBase [a] where
  leftb  = []
  rightb = [error "Should never be inspected"]

class LREl es where
  lefte  :: NatPrf n -> es n
  righte :: NatPrf n -> es n
  
instance (LRBase a, LREl as) => LREl (a :|: as) where
  lefte PZ     = Z leftb
  lefte (PS p) = S (lefte p)
  righte PZ     = Z rightb
  righte (PS p) = S (righte p)
  
instance LREl Nil where
  lefte  _ = Nil $ error "Nil generated in lefte."
  righte _ = Nil $ error "Nil generated in righte."

-- | The @LR@ class defines two functions, @leftf@ and @rightf@, which should 
-- produce different functorial values.
class LR prf (f :: (* -> *) -> * -> *) where
  leftf  :: (forall n. prf n -> es n) -> a -> f es a
  rightf :: (forall n. prf n -> es n) -> a -> f es a

instance LR prf I where
  leftf  _ x = I x
  rightf _ x = I x

instance (LRBase a) => LR prf (K a) where
  leftf  _ _ = K leftb
  rightf _ _ = K rightb
  
instance (El prf n) => LR prf (E n) where
  leftf  f _ = E (f proof)
  rightf f _ = E (f proof)

instance LR prf U where
  leftf  _ _ = U
  rightf _ _ = U

instance (LR prf f, LR prf g) => LR prf (f :+: g) where
  leftf  f x = L (leftf f x)
  rightf f x = R (rightf f x)

instance (LR prf f, LR prf g) => LR prf (f :*: g) where
  leftf  f x = leftf  f x :*: leftf  f x
  rightf f x = rightf f x :*: rightf f x


dft_leftf :: (Regular1 f, LR prf (PF1 f))
          => (forall n. prf n -> es n) -> a -> f es a
dft_leftf f = to1 . leftf f

dft_rightf :: (Regular1 f, LR prf (PF1 f))
           => (forall n. prf n -> es n) -> a -> f es a
dft_rightf f = to1 . rightf f

-- | Produces a value which should be different from the value returned by 
-- @right@.
left :: (Regular a, LR NatPrf (PF a), LREl (Es a)) => a
left = to $ leftf lefte left

-- | Produces a value which should be different from the value returned by 
-- @left@.
right :: (Regular a, LR NatPrf (PF a), LREl (Es a)) => a
right = to $ rightf righte right

-----------------------------------------------------------------------------
-- Folds
-----------------------------------------------------------------------------
{-
type family Alg (f  :: (* -> *) -> * -> *)
                (es :: * -> *) -- elements
                (r  :: *)      -- result type
                :: *

-- | For a constant, we take the constant value to a result.
type instance Alg (K a) es r = a -> r

-- | For a unit, no arguments are available.
type instance Alg U es r = r

-- | For an identity, we turn the recursive result into a final result.
type instance Alg I es r = r -> r

-- | For a sum, the algebra is a pair of two algebras.
type instance Alg (f :+: g) es r = (Alg f es r, Alg g es r)

-- | For a product where the left hand side is a constant, we
--   take the value as an additional argument.
type instance Alg (K a :*: g) es r = a -> Alg g es r

-- | For a product where the left hand side is an identity, we
--   take the recursive result as an additional argument.
type instance Alg (I :*: g) es r = r -> Alg g es r

type instance Alg (f :.: I) es r = f es r -> r
type instance Alg (f :.: (K a)) es r = f es a -> r


type Algebra a es r = Alg (PF a) es r

-- * The class to turn convenient algebras into standard algebras.

-- | The class fold explains how to convert a convenient algebra
--   'Alg' back into a function from functor to result, as required
--   by the standard fold function.

class Fold (f :: (* -> *) -> * -> *) where
  alg :: Alg f es r -> f es r -> r

instance Fold (K a) where
  alg f (K x) = f x

instance Fold U where
  alg f U     = f

instance Fold I where
  alg f (I x) = f x

instance (Fold f, Fold g) => Fold (f :+: g) where
  alg (f, _) (L x) = alg f x
  alg (_, g) (R x) = alg g x

instance (Fold g) => Fold (K a :*: g) where
  alg f (K x :*: y) = alg (f x) y

instance (Fold g) => Fold (I :*: g) where
  alg f (I x :*: y) = alg (f x) y

instance (Functor (f es)) => Fold (f :.: I) where
  alg f (Comp x) = f (fmap unI x)

instance (Functor (f es)) => Fold (f :.: (K a)) where
  alg f (Comp x) = f (fmap unK x)

-- * Interface

-- | Fold with convenient algebras.
fold :: (Regular a, Fold (PF a), Functor (PF a es))
     => Algebra a es r -> a -> r
fold f = alg f . fmap (\x -> fold f x) . from
-}
-- * Construction of algebras

infixr 5 &

-- | For constructing algebras that are made of nested pairs rather
--   than n-ary tuples, it is helpful to use this pairing combinator.
(&) :: a -> b -> (a, b)
(&) = (,)