module AOP.Internal.JoinpointModel (
FunctionTag,
defaultFunctionTag,
Jp (..),
newjp,
compareFun,
compareType,
getJpArg,
PC (..),
runPC,
RequirePC (..),
Advice,
applyAdv,
Aspect (..),
aspect,
deleteAsp,
EAspect (..),
AspectEnv,
module X,
) where
import Unsafe.Coerce
import Control.Monad
import Data.Unique
import System.IO.Unsafe
import AOP.Internal.LessGen as X
import AOP.Internal.Typeable1Monad as X
import AOP.Internal.StableNamesEq
import AOP.Internal.PolyTypeableUtils
type FunctionTag = Integer
defaultFunctionTag = 343123
data Jp m a b = (Typeable1Monad m, PolyTypeable (a -> m b)) => Jp (a -> m b) FunctionTag a TypeRep
newjp :: (Typeable1Monad m, PolyTypeable (a -> m b)) => (a -> m b) -> FunctionTag -> a -> Jp m a b
newjp f t a = Jp f t a (polyTypeOf f)
compareFun :: (Typeable1Monad m, PolyTypeable (a -> m b)) => t -> FunctionTag -> Jp m a b -> Bool
compareFun f ft (Jp g t _ _) = if t == defaultFunctionTag then stableNamesEq f g else ft == t
compareType :: (Typeable1Monad m, PolyTypeable (a -> m b)) => TypeRep -> Jp m a b -> Bool
compareType t (Jp _ _ _ ft) = isLessGeneral ft t
getJpArg :: Monad m => Jp m a b -> a
getJpArg (Jp _ _ x _) = x
data PC m a b = PC {mpcond :: forall a' b'. m (Jp m a' b' -> m Bool)}
runPC (PC mpcond) jp = do { pccond <- mpcond; pccond jp}
data RequirePC m a b = Typeable1Monad m => RequirePC {mpcond' :: forall a' b'. m (Jp m a' b' -> m Bool)}
instance (Typeable1 m) => Typeable2 (Jp m) where
typeOf2 _ = mkTyConApp (mkTyCon3 "EffectiveAspects" "AOP.Internal.JoinpointModel" "Jp")
[typeOf1 (undefined :: m ())]
instance (Typeable1 m) => Typeable2 (PC m) where
typeOf2 _ = mkTyConApp (mkTyCon3 "PC" "PC" "PC")
[typeOf1 (undefined :: m ())]
instance (Typeable1 m) => Typeable2 (RequirePC m) where
typeOf2 _ = mkTyConApp (mkTyCon3 "RequirePC" "RequirePC" "RequirePC")
[typeOf1 (undefined :: m ())]
type Advice m a b = (a -> m b) -> a -> m b
applyAdv :: Advice m a b -> t2 -> t2
applyAdv = unsafeCoerce
type AspectHandle = Unique
data Aspect m a b c d = LessGen (a -> b) (c -> m d) => Aspect (PC m a b) (Advice m c d) AspectHandle
newAspectHandle :: AspectHandle
newAspectHandle = unsafePerformIO newUnique
aspect :: (Typeable1Monad m, LessGen (a1 -> b1) (a2 -> m b2)) => PC m a1 b1 -> Advice m a2 b2 -> Aspect m a1 b1 a2 b2
aspect pc adv = Aspect pc adv newAspectHandle
data EAspect m = forall a b c d. LessGen (a -> b) (c -> m d) => EAspect (Aspect m a b c d)
type AspectEnv m = [EAspect m]
instance Show AspectHandle where
show handle = show $ hashUnique handle
instance Show (Aspect m a b c d) where
show (Aspect pc adv handle) = show handle
instance Show (EAspect m) where
show (EAspect (Aspect pc adv handle)) = show handle
deleteAsp :: Typeable1Monad m => EAspect m -> AspectEnv m -> AspectEnv m
deleteAsp asp = filter (\asp' -> asp /= asp')
instance PolyTypeable Unique where
polyTypeOf _ = mkTyConApp (mkTyCon3 "GHC" "Unique" "") []
instance Typeable1Monad m => Eq (EAspect m) where
EAspect (Aspect _ _ u1) == EAspect (Aspect _ _ u2) = u1 == u2