{-# OPTIONS -fglasgow-exts #-}

module Base where

import Control.Monad

import Representations


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

-- Wrapper for non-monadic combining functions
fzip  :: (Zip f, Monad m) => (a -> b -> c) -> f a -> f b -> m (f c)
fzip f x y = fzipM (\ a b -> return (f a b)) x y

-- Partial version of fzip
fzip' :: Zip f => (a -> b -> c) -> f a -> f b -> f c
fzip' f x y = 
  case fzip f x y of
    Just res -> res
    Nothing  -> error "fzip': structure mismatch"

class Crush f where
  crush :: (a -> b -> b) -> b -> f a -> b

flatten :: Crush f => f a -> [a]
flatten = crush (:) []

-- Generic equality
geq :: (PFView a, Zip (PF a), Crush (PF a)) => a -> a -> Bool
geq a b = case fzip geq (from a) (from b) of
            Nothing  -> False
            Just res -> crush (&&) True res

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 Id where
  fmap f (Id r) = Id (f r)

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

instance Functor Unit where
  fmap _ Unit = Unit

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)

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

instance Functor f => Functor (C f) where
  fmap f (C r) = C (fmap f r)


-- --------------------------------------
-- Zip instances for structure types
-- --------------------------------------
instance Zip Id where
  fzipM f (Id x) (Id y) = liftM Id (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 Zip Unit where
  fzipM _ Unit Unit = return Unit

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 _ _       _       = fail "fzipM: structure mismatch"

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)

instance Zip f => Zip (Con f) where
  fzipM f (Con c1 x) (Con c2 y) = liftM (Con c1) (fzipM f x y)

instance Zip f => Zip (C f) where
  fzipM f (C x) (C y) = liftM C (fzipM f x y)


-- --------------------------------------
-- Flatten instances for structure types
-- --------------------------------------
instance Crush Id where
  crush op e (Id x) = x `op` e

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

instance Crush Unit where
  crush op e _ = e

instance (Crush a, Crush b) => Crush (Sum a b) where
  crush op e (Inl x) = crush op e x
  crush op e (Inr x) = crush op e x

instance (Crush a, Crush b) => Crush (Prod a b) where
  crush op e (Prod x y) = crush op (crush op e y) x

instance Crush f => Crush (Con f) where
  crush op e (Con c x) = crush op e x


-- --------------------------------------
-- GShow instances for structure types
-- --------------------------------------
instance GShow Id where
  gshow f (Id r) = f r

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

instance GShow Unit where
  gshow _ Unit = id

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 Id where
  fmapM f (Id r) = liftM Id (f r)

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

instance GMap Unit where
  fmapM _ Unit = return Unit

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)

instance GMap f => GMap (C f) where
  fmapM f (C x) = liftM 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 LR f where
  leftf  :: a -> f a
  rightf :: a -> f a

class LRBase a where
  leftb  :: a
  rightb :: a


-- --------------------------------------
-- LR instances
-- --------------------------------------
instance LR Id where
  leftf  x = Id x
  rightf x = Id x

instance LRBase a => LR (K a) where
  leftf  _ = K leftb
  rightf _ = K rightb

instance LR Unit where
  leftf  _ = Unit
  rightf _ = Unit

instance (LR f, LR g) => LR (Sum f g)  where
  leftf  x = Inl (leftf x)
  rightf x = Inr (rightf x)

instance (LR f, LR g) => LR (Prod f g)  where
  leftf  x = Prod (leftf x) (leftf x)
  rightf x = Prod (rightf x) (rightf x)

instance LR f => LR (Con f) where
  leftf  x = Con "Zero_Con" (leftf x)
  rightf x = Con "Zero_Con" (rightf x)


-- --------------------------------------
-- LRBase instances
-- --------------------------------------
instance LRBase Int where
  leftb  = 0
  rightb = 1

instance LRBase Bool where
  leftb  = True
  rightb = False

instance LRBase Char where
  leftb  = 'L'
  rightb = 'R'

instance LRBase a => LRBase [a] where
  leftb  = []
  rightb = [rightb]

-- --------------------------------------
-- Helper functions
-- --------------------------------------
left :: (LR (PF a), PFView a) => a
left = to (leftf left)

right :: (LR (PF a), PFView a) => a
right = to (rightf right)