2 -----------------------------------------------------------------------------
4 -- Module : Generics.Pointless.Observe.Functors
5 -- Copyright : (c) 2008 University of Minho
8 -- Maintainer : hpacheco@di.uminho.pt
9 -- Stability : experimental
10 -- Portability : non-portable
13 -- point-free programming with recursion patterns as hylomorphisms
15 -- This module defines generic GHood observations for user-defined data types.
17 -----------------------------------------------------------------------------
19 module Generics.Pointless.Observe.Functors where
21 import Generics.Pointless.Combinators
22 import Generics.Pointless.Functors
25 import Prelude hiding (Functor(..))
26 import Control.Monad hiding (Functor(..))
28 -- * Definition of generic observations
30 instance Typeable One where
31 typeOf _ = mkTyCon "One" `mkTyConApp` []
33 -- | Class for mapping observations over functor representations.
34 class FunctorO f where
35 -- | Derives a type representation for a functor. This is used for showing the functor for reursion trees.
36 functorOf :: Fix f -> String
37 -- | 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.
38 watch :: Fix f -> x -> Rep f x -> String
39 -- | Maps an observation over a functor representation.
40 fmapO :: Fix f -> (x -> ObserverM y) -> Rep f x -> ObserverM (Rep f y)
42 instance FunctorO Id where
47 instance (Typeable a,Observable a) => FunctorO (Const a) where
48 functorOf _ = "Const " ++ show (typeOf (_L::a))
53 instance (FunctorO f, FunctorO g) => FunctorO (f :+: g) where
54 functorOf _ = "(" ++ functorOf (_L::Fix f) ++ ":+:" ++ functorOf (_L::Fix g) ++ ")"
55 watch _ _ (Left _) = "Left"
56 watch _ _ (Right _) = "Right"
57 fmapO _ f (Left x) = liftM Left (fmapO (_L::Fix f) f x)
58 fmapO _ f (Right x) = liftM Right (fmapO (_L::Fix g) f x)
60 instance (FunctorO f, FunctorO g) => FunctorO (f :*: g) where
61 functorOf _ = "(" ++ functorOf (_L::Fix f) ++ ":*:" ++ functorOf (_L::Fix g) ++ ")"
63 fmapO _ f (x,y) = do x' <- fmapO (_L :: Fix f) f x
64 y' <- fmapO (_L::Fix g) f y
67 instance (FunctorO g, FunctorO h) => FunctorO (g :@: h) where
68 functorOf _ = "(" ++ functorOf (_L::Fix g) ++ ":@:" ++ functorOf (_L::Fix h) ++ ")"
69 watch _ (x::x) = watch (_L::Fix g) (_L::Rep h x)
70 fmapO _ = fmapO (_L::Fix g) . fmapO (_L::Fix h)
72 -- | Polytypic mapping of observations.
73 omap :: FunctorO (PF a) => a -> (x -> ObserverM y) -> F a x -> ObserverM (F a y)
74 omap (_::a) = fmapO (_L::Fix (PF a))
76 instance Observable One where
77 observer = observeBase
79 instance Observable I where
80 observer FixId = send "" (fmapO (_L :: Fix Id) thunk FixId)
82 instance (Typeable a,Observable a) => Observable (K a) where
83 observer (FixConst a) = send "" (liftM FixConst (fmapO (_L::Fix (Const a)) thk a))
84 where thk = thunk :: a -> ObserverM a
86 instance (FunctorO (PF a),FunctorO (PF b)) => Observable (a :+!: b) where
87 observer (FixSum f) = send "" (liftM FixSum (fmapO (_L::Fix (PF a :+: PF b)) thk f))
88 where thk = thunk :: a :+!: b -> ObserverM (a :+!: b)
90 instance (FunctorO (PF a), FunctorO (PF b)) => Observable (a :*!: b) where
91 observer (FixProd f) = send "" (liftM FixProd (fmapO (_L::Fix (PF a :*: PF b)) thk f))
92 where thk = thunk :: a :*!: b -> ObserverM (a :*!: b)
94 instance (FunctorO (PF a), FunctorO (PF b)) => Observable (a :@!: b) where
95 observer (FixComp f) = send "" (liftM FixComp (fmapO (_L::Fix (PF a :@: PF b)) thk f))
96 where thk = thunk :: a :@!: b -> ObserverM (a :@!: b)
98 -- NOTE: The following commented instance causes overlapping problems with the specific ones defined for base types (One,Int,etc.).
99 -- The solution is to provide its specific case for each type when needed, or to uncomment the following code
100 -- and using the flag -XIncoherentInstances.
102 --instance (Mu a,FunctorO (PF a)) => Observable a where
103 -- observer x = send "" (omap (_L :: a) thk (out x) >>= return . inn)
104 -- where thk = thunk :: a -> ObserverM a
106 instance (Functor f, FunctorO f) => Observable (Fix f) where
107 observer (Fix x) = send (watch (_L::Fix f) (_L::Fix f) x) (liftM Fix (fmapO (_L :: Fix f) thk x))
108 where thk = thunk :: Fix f -> ObserverM (Fix f)