-----------------------------------------------------------------------------
-- |
-- Module      :  Generics.Pointless.Observe.Functors
-- Copyright   :  (c) 2008 University of Minho
-- License     :  BSD3
--
-- Maintainer  :  hpacheco@di.uminho.pt
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Pointless Haskell:
-- point-free programming with recursion patterns as hylomorphisms
-- 
-- This module defines generic GHood observations for user-defined data types.
--
-----------------------------------------------------------------------------

module Generics.Pointless.Observe.Functors where

import Generics.Pointless.Combinators
import Generics.Pointless.Functors
import Debug.Observe
import Data.Typeable
import Prelude hiding (Functor(..))

-- * Definition of generic observations

instance Typeable One where
   typeOf _ = (mkTyCon "One") `mkTyConApp` []

-- | Class for mapping observations over functor representations.
class FunctorO f where
   -- | Derives a type representation for a functor. This is used for showing the functor for reursion trees.
   functorOf :: Fix f -> String
   -- | Watch values of a functor. Since the fixpoint of a functor recurses over himself, we cannot use the 'Show' instance for functor values applied to their fixpoint.
   watch :: Fix f -> x -> Rep f x -> String
   -- | Maps an observation over a functor representation.
   fmapO :: Fix f -> (x -> ObserverM y) -> Rep f x -> ObserverM (Rep f y)

instance FunctorO Id where
   functorOf _ = "Id"
   watch _ _ _ = ""
   fmapO _ f x = f x

instance (Typeable a,Observable a) => FunctorO (Const a) where
   functorOf _ = "Const " ++ show (typeOf (_L::a))
   watch _ _ _ = ""
   fmapO _ f x = thunk x


instance (FunctorO f, FunctorO g) => FunctorO (f :+: g) where
   functorOf _ = "(" ++ functorOf (_L::Fix f) ++ ":+:" ++ functorOf (_L::Fix g) ++ ")"
   watch _ _ (Left _) = "Left"
   watch _ _ (Right _) = "Right"
   fmapO _ f (Left x) = fmapO (_L::Fix f) f x >>= return . Left
   fmapO _ f (Right x) = fmapO (_L::Fix g) f x >>= return . Right

instance (FunctorO f, FunctorO g) => FunctorO (f :*: g) where
   functorOf _ = "(" ++ functorOf (_L::Fix f) ++ ":*:" ++ functorOf (_L::Fix g) ++ ")"
   watch _ _ _ = ""
   fmapO _ f (x,y) = do x' <- fmapO (_L :: Fix f) f x
			y' <- fmapO (_L::Fix g) f y
			return (x',y')

instance (FunctorO g, FunctorO h) => FunctorO (g :@: h) where
   functorOf _ = "(" ++ functorOf (_L::Fix g) ++ ":@:" ++ functorOf (_L::Fix h) ++ ")"
   watch _ (x::x) a = watch (_L::Fix g) (_L::Rep h x) a
   fmapO _ f x = fmapO (_L::Fix g) (fmapO (_L::Fix h) f) x

--w :: Fix (g:@:h) -> x -> Rep (g:@:h) x -> String
--w (_::Fix (g:@:h)) (r::x) (x) = watch (_L::Fix g) (aux x) x
--   where aux :: Rep (g:@:h) x -> Rep h x
--         aux _ = _L

-- | Polytypic mapping of observations.
omap :: FunctorO (PF a) => a -> (x -> ObserverM y) -> F a x -> ObserverM (F a y)
omap (_::a) f = fmapO (_L::Fix (PF a)) f

instance Observable One where
   observer = observeBase

instance Observable I where
   observer FixId = send "" (fmapO (_L :: Fix Id) thunk FixId)

instance (Typeable a,Observable a) => Observable (K a) where
   observer (FixConst a) = send "" (fmapO (_L::Fix (Const a)) thk a >>= return . FixConst)
      where thk = thunk :: a -> ObserverM a

instance (FunctorO (PF a),FunctorO (PF b)) => Observable (a :+!: b) where
   observer (FixSum f) = send "" (fmapO (_L::Fix (PF a :+: PF b)) thk f >>= return . FixSum)
      where thk = thunk :: a :+!: b -> ObserverM (a :+!: b)

instance (FunctorO (PF a), FunctorO (PF b)) => Observable (a :*!: b) where
   observer (FixProd f) = send "" (fmapO (_L::Fix (PF a :*: PF b)) thk f >>= return . FixProd)
      where thk = thunk :: a :*!: b -> ObserverM (a :*!: b)

instance (FunctorO (PF a), FunctorO (PF b)) => Observable (a :@!: b) where
   observer (FixComp f) = send "" (fmapO (_L::Fix (PF a :@: PF b)) thk f >>= return . FixComp)
      where thk = thunk :: a :@!: b -> ObserverM (a :@!: b)

-- NOTE: The following commented instance causes overlapping problems with the specific ones defined for base types (One,Int,etc.).
-- The solution is to provide its specific case for each type when needed, or to uncomment the following code
-- and using the flag -XIncoherentInstances.

--instance (Mu a,FunctorO (PF a)) => Observable a where
--   observer x = send "" (omap (_L :: a) thk (out x) >>= return . inn)
--      where thk = thunk :: a -> ObserverM a

instance (Functor f, FunctorO f) => Observable (Fix f) where
   observer (Fix x) = send (watch (_L::Fix f) (_L::Fix f) x) (fmapO (_L::Fix f) thk x >>= return . Fix)
      where thk = thunk :: Fix f -> ObserverM (Fix f)