{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances #-}

module Base where

import Representations

import Control.Monad


-- --------------------------------------
-- Standard generic functions: (monadic) 
-- zip, flatten, gshow and map
-- --------------------------------------
class Zip f where
  fzip :: (a -> b -> c) -> f a -> f b -> f c
  fzipM :: Monad m => (a -> b -> m c) -> f a -> f b -> m (f c)

  fzip f x y = unId $ fzipM (\ a b -> return (f a b)) x y

class Flatten f where
  flatten :: f a -> [a]

class GShow f where
  gshow :: (a -> ShowS) -> f a -> ShowS

class GMap f where
  fmapM :: Monad m => (a -> m b) -> f a -> m (f b)

instance Monad Id where
  return = Id
  (Id x) >>= f = f x


-- --------------------------------------
-- Functor instances for structure types
-- --------------------------------------
instance Functor Unit where
  fmap _ Unit = Unit

instance Functor Id where
  fmap f (Id r) = Id (f r)

instance Functor f => Functor (Con f) where
  fmap f (Con con r) = Con con (fmap f r)

instance Functor (K a) where
  fmap f (K a) = K a

instance (Functor f, Functor g) => Functor (Sum f g) where
  fmap f (Inl x) = Inl (fmap f x)
  fmap f (Inr y) = Inr (fmap f y)

instance (Functor f, Functor g) => Functor (Prod f g) where
  fmap f (Prod x y) = Prod (fmap f x) (fmap f y)


-- --------------------------------------
-- Zip instances for structure types
-- --------------------------------------
instance Zip Unit where
  fzipM f Unit Unit = return Unit

instance Zip f => Zip (Con f) where
  fzipM f (Con c1 x) (Con c2 y) = return . Con c1 =<< fzipM f x y

instance Zip Id where
  fzipM f (Id x) (Id y) = return . Id =<< f x y

instance Eq a => Zip (K a) where
  fzipM f (K x) (K y) | x == y    = return (K x)
                      | otherwise = fail "Mismatch in K"

instance (Zip a,Zip b) => Zip (Sum a b) where
  fzipM f (Inl x) (Inl y) = liftM Inl (fzipM f x y)
  fzipM f (Inr x) (Inr y) = liftM Inr (fzipM f x y)
  fzipM f _       _       = fail "Mismatch in sum"

instance (Zip a,Zip b) => Zip (Prod a b) where
  fzipM f (Prod x1 y1) (Prod x2 y2) = liftM2 Prod
                                             (fzipM f x1 x2)
                                             (fzipM f y1 y2)

fzipM' f = fzipM (\x y -> return (f x y))


-- --------------------------------------
-- Flatten instances for structure types
-- --------------------------------------
instance Flatten Unit where
  flatten _ = []

instance Flatten f => Flatten (Con f) where
  flatten (Con c x) = flatten x

instance Flatten Id where
  flatten (Id x) = [x]

instance Flatten (K a) where
  flatten _  = []

instance (Flatten a,Flatten b) => Flatten (Sum a b) where
  flatten (Inl x) = flatten x
  flatten (Inr x) = flatten x

instance (Flatten a,Flatten b) => Flatten (Prod a b) where
  flatten (Prod x y) = flatten x ++ flatten y


-- --------------------------------------
-- GShow instances for structure types
-- --------------------------------------
instance GShow Unit where
  gshow _ Unit = id

instance GShow Id where
  gshow f (Id r) = f r

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

instance (GShow f,GShow g) => GShow (Sum f g) where
  gshow f (Inl x) = gshow f x
  gshow f (Inr x) = gshow f x

instance (GShow f,GShow g) => GShow (Prod f g) where
  gshow f (Prod x y) = gshow f x . showChar ' ' . gshow f y

instance GShow f => GShow (Con f) where
  gshow f (Con c x) = showParen True (showString c . showChar ' ' . gshow f x)


-- --------------------------------------
-- GMap instances for structure types
-- --------------------------------------
instance GMap Unit where
  fmapM _ Unit = return Unit

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

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

instance (GMap f,GMap g) => GMap (Sum f g) where
  fmapM f (Inl x) = liftM Inl (fmapM f x)
  fmapM f (Inr x) = liftM Inr (fmapM f x)

instance (GMap f,GMap g) => GMap (Prod f g) where
  fmapM f (Prod x y) = liftM2 Prod (fmapM f x) (fmapM f y)

instance GMap f => GMap (Con f) where
  fmapM f (Con c x) = liftM (Con c) (fmapM f x)


-- --------------------------------------
-- Generic functions to generate two 
-- different values, invariant: the two 
-- values fail when used with fzipM
--
-- Left favours a left choice on the sum.
-- Right chooses Inr
--
-- Zero is used to produce a 'minimal'
-- value
-- --------------------------------------
class Left a where
  left :: a

class Right a where
  right :: a

class Zero a where
  zero :: a


-- --------------------------------------
-- Left instances
-- --------------------------------------
instance Zero (f a) => Left (Sum f g a)  where
  left = Inl zero

instance Left (f (Fix f)) => Left (Fix f) where
  left = In left


-- --------------------------------------
-- Right instances
-- --------------------------------------
instance Zero (g a) => Right (Sum f g a)  where
  right = Inr zero

instance Right (f (Fix f)) => Right (Fix f) where
  right = In right


-- --------------------------------------
-- Zero instances
-- --------------------------------------
instance (Zero (f a),Zero (g a)) => Zero (Prod f g a) where
  zero = Prod zero zero

instance Zero (f a) => Zero (Sum f g a) where
  zero = left

instance Zero a => Zero (K a b) where
  zero = K zero

instance Zero (f a) => Zero (Con f a) where
  zero = Con "Zero_Con" zero

instance Zero a => Zero (Id a) where
  zero = Id zero

instance Zero (f (Fix f)) => Zero (Fix f) where
  zero = In zero

instance Zero Int where
  zero = 0

instance Zero Bool where
  zero = False

instance Zero (Unit a) where
  zero = Unit

instance Zero String where
   zero = ""

-- Forced by Match synonym
instance Zero a => Left (K a b) where
  left = K zero

instance Zero a => Right (K a b) where
  right = K zero