diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,512 @@ + FREE SOFTWARE LICENSING AGREEMENT CeCILL + ======================================== + + +Notice +------ + + +This Agreement is a free software license that is the result of discussions +between its authors in order to ensure compliance with the two main +principles guiding its drafting: + - firstly, its conformity with French law, both as regards the law of + torts and intellectual property law, and the protection that it offers + to authors and the holders of economic rights over software. + - secondly, compliance with the principles for the distribution of free + software: access to source codes, extended user-rights. + +The following bodies are the authors of this license CeCILL (Ce : CEA, C : +CNRS, I : INRIA, LL : Logiciel Libre): + +Commissariat à l'Energie Atomique - CEA, a public scientific, technical and +industrial establishment, having its principal place of business at 31-33 +rue de la Fédération, 75752 PARIS cedex 15, France. + +Centre National de la Recherche Scientifique - CNRS, a public scientific +and technological establishment, having its principal place of business at +3 rue Michel-Ange 75794 Paris cedex 16, France. + +Institut National de Recherche en Informatique et en Automatique - INRIA, a +public scientific and technological establishment, having its principal +place of business at Domaine de Voluceau, Rocquencourt, BP 105, 78153 Le +Chesnay cedex. + + +PREAMBLE +-------- + + +The purpose of this Free Software Licensing Agreement is to grant users the +right to modify and redistribute the software governed by this license +within the framework of an "open source" distribution model. + +The exercising of these rights is conditional upon certain obligations for +users so as to ensure that this status is retained for subsequent +redistribution operations. + +As a counterpart to the access to the source code and rights to copy, modify +and redistribute granted by the license, users are provided only with a +limited warranty and the software's author, the holder of the economic +rights, and the successive licensors only have limited liability. + +In this respect, it is brought to the user's attention that the risks +associated with loading, using, modifying and/or developing or reproducing +the software by the user given its nature of Free Software, that may +mean that it is complicated to manipulate, and that also therefore means +that it is reserved for developers and experienced professionals having +in-depth computer knowledge. Users are therefore encouraged to load and test +the Software's suitability as regards their requirements in conditions +enabling the security of their systems and/or data to be ensured and, more +generally, to use and operate it in the same conditions of security. +This Agreement may be freely reproduced and published, provided it is +not altered, and that no Articles are either added or removed herefrom. + +This Agreement may apply to any or all software for which the holder of the +economic rights decides to submit the operation thereof to its provisions. + + +Article 1 - DEFINITIONS +------------------------ + + +For the purposes of this Agreement, when the following expressions commence +with a capital letter, they shall have the following meaning: + +Agreement: means this Licensing Agreement, and any or all of its subsequent +versions. + +Software: means the software in its Object Code and/or Source Code form +and, where applicable, its documentation, "as is" at the time when the +Licensee accepts the Agreement. + +Initial Software: means the Software in its Source Code and/or Object Code +form and, where applicable, its documentation, "as is" at the time when it +is distributed for the first time under the terms and conditions of the +Agreement. + +Modified Software: means the Software modified by at least one +Contribution. + +Source Code: means all the Software's instructions and program lines to +which access is required so as to modify the Software. + +Object Code: means the binary files originating from the compilation of the +Source Code. + +Holder: means the holder of the economic rights over the Initial +Software. + +Licensee(s): mean(s) the Software user(s) having accepted the Agreement. + +Contributor: means a Licensee having made at least one Contribution. + +Licensor: means the Holder, or any or all other individual or legal entity, +that distributes the Software under the Agreement. + +Contributions: mean any or all modifications, corrections, translations, +adaptations and/or new functionalities integrated into the Software by any +or all Contributor, and the Static Modules. + +Module: means a set of sources files including their documentation that, +once compiled in executable form, enables supplementary functionalities or +services to be developed in addition to those offered by the Software. + +Dynamic Module: means any or all module, created by the Contributor, that +is independent of the Software, so that this module and the Software are in +two different executable forms that are run in separate address spaces, +with one calling the other when they are run. + +Static Module: means any or all module, created by the Contributor and +connected to the Software by a static link that makes their object codes +interdependent. This module and the Software to which it is connected, are +combined in a single executable. + +Parties: mean both the Licensee and the Licensor. + +These expressions may be used both in singular and plural form. + + +Article 2 - PURPOSE +------------------- + + +The purpose of the Agreement is to enable the Licensor to grant the +Licensee a free, non-exclusive, transferable and worldwide License for the +Software as set forth in Article 5 hereinafter for the whole term of +protection of the rights over said Software. + + +Article 3 - ACCEPTANCE +---------------------- + + +3.1. The Licensee shall be deemed as having accepted the terms and +conditions of this Agreement by the occurrence of the first of the +following events: +- (i) loading the Software by any or all means, notably, by downloading + from a remote server, or by loading from a physical medium; +- (ii) the first time the Licensee exercises any of the rights granted + hereunder. + +3.2. One copy of the Agreement, containing a notice relating to the +specific nature of the Software, to the limited warranty, and to the +limitation to use by experienced users has been provided to the Licensee +prior to its acceptance as set forth in Article 3.1 hereinabove, and the +Licensee hereby acknowledges that it is aware thereof. + + +Article 4 - EFFECTIVE DATE AND TERM +----------------------------------- + + +4.1. EFFECTIVE DATE + +The Agreement shall become effective on the date when it is accepted by the +Licensee as set forth in Article 3.1. + +4.2. TERM + +The Agreement shall remain in force during the whole legal term of +protection of the economic rights over the Software. + + +Article 5 - SCOPE OF THE RIGHTS GRANTED +--------------------------------------- + + +The Licensor hereby grants to the Licensee, that accepts such, the +following rights as regards the Software for any or all use, and for the +term of the Agreement, on the basis of the terms and conditions set forth +hereinafter. + +Otherwise, the Licensor grants to the Licensee free of charge exploitation +rights on the patents he holds on whole or part of the inventions +implemented in the Software. + +5.1. RIGHTS OF USE + +The Licensee is authorized to use the Software, unrestrictedly, as regards +the fields of application, with it being hereinafter specified that this +relates to: +- permanent or temporary reproduction of all or part of the Software by + any or all means and in any or all form. +- loading, displaying, running, or storing the Software on any or all + medium. +- entitlement to observe, study or test the operation thereof so as to + establish the ideas and principles that form the basis for any or all + constituent elements of said Software. This shall apply when the + Licensee carries out any or all loading, displaying, running, + transmission or storage operation as regards the Software, that it is + entitled to carry out hereunder. + +5.2. entitlement to make CONTRIBUTIONS + +The right to make Contributions includes the right to translate, adapt, +arrange, or make any or all modification to the Software, and the right to +reproduce the resulting Software. + +The Licensee is authorized to make any or all Contribution to the Software +provided that it explicitly mentions its name as the author of said +Contribution and the date of the development thereof. + +5.3. DISTRIBUTION AND PUBLICATION RIGHTS + +In particular, the right of distribution and publication includes the right +to transmit and communicate the Software to the general public on any or +all medium, and by any or all means, and the right to market, either in +consideration of a fee, or free of charge, a copy or copies of the Software +by means of any or all process. +The Licensee is further authorized to redistribute copies of the modified +or unmodified Software to third parties according to the terms and +conditions set forth hereinafter. + +5.3.1. REDISTRIBUTION OF SOFTWARE WITHOUT MODIFICATION + +The Licensee is authorized to redistribute true copies of the Software in +Source Code or Object Code form, provided that said redistribution complies +with all the provisions of the Agreement and is accompanied by: +- a copy of the Agreement, +- a notice relating to the limitation of both the Licensor's warranty + and liability as set forth in Articles 8 and 9, +and that, in the event that only the Software's Object Code is +redistributed, the Licensee allows future Licensees unhindered access to +the Software's full Source Code by providing them with the terms and +conditions for access thereto, it being understood that the additional cost +of acquiring the Source Code shall not exceed the cost of transferring the +data. + +5.3.2. REDISTRIBUTION OF MODIFIED SOFTWARE + +When the Licensee makes a Contribution to the Software, the terms and +conditions for the redistribution of the Modified Software shall then be +subject to all the provisions hereof. + +The Licensee is authorized to redistribute the Modified Software, in Source +Code or Object Code form, provided that said redistribution complies with +all the provisions of the Agreement and is accompanied by: +- a copy of the Agreement, +- a notice relating to the limitation of both the Licensor's warranty + and liability as set forth in Articles 8 and 9, +and that, in the event that only the Modified Software's Object Code is +redistributed, the Licensee allows future Licensees unhindered access to +the Modified Software's full Source Code by providing them with the terms +and conditions for access thereto, it being understood that the additional +cost of acquiring the Source Code shall not exceed the cost of transferring +the data. + + +5.3.3. redistribution OF DYNAMIC MODULES + +When the Licensee has developed a Dynamic Module, the terms and conditions +hereof do not apply to said Dynamic Module, that may be distributed under +a separate Licensing Agreement. + +5.3.4. COMPATIBILITY WITH THE GPL LICENSE + +In the event that the Modified or unmodified Software is included in a code +that is subject to the provisions of the GPL License, the Licensee is +authorized to redistribute the whole under the GPL License. + +In the event that the Modified Software includes a code that is subject to +the provisions of the GPL License, the Licensee is authorized to +redistribute the Modified Software under the GPL License. + + +Article 6 - INTELLECTUAL PROPERTY +---------------------------------- + + +6.1. OVER THE INITIAL SOFTWARE + +The Holder owns the economic rights over the Initial Software. Any or all +use of the Initial Software is subject to compliance with the terms and +conditions under which the Holder has elected to distribute its work and no +one shall be entitled to and it shall have sole entitlement to modify the +terms and conditions for the distribution of said Initial Software. + +The Holder undertakes to maintain the distribution of the Initial Software +under the conditions of the Agreement, for the duration set forth in +article 4.2.. + +6.2. OVER THE CONTRIBUTIONS + +The intellectual property rights over the Contributions belong to the +holder of the economic rights as designated by effective legislation. + +6.3. OVER THE DYNAMIC MODULES + +The Licensee having developed a Dynamic Module is the holder of the +intellectual property rights over said Dynamic Module and is free to choose +the agreement that shall govern its distribution. + +6.4. JOINT PROVISIONS + +6.4.1. The Licensee expressly undertakes: +- not to remove, or modify, in any or all manner, the intellectual + property notices affixed to the Software; +- to reproduce said notices, in an identical manner, in the copies of + the Software. + +6.4.2. The Licensee undertakes not to directly or indirectly infringe the +intellectual property rights of the Holder and/or Contributors and to take, +where applicable, vis-à-vis its staff, any or all measures required to +ensure respect for said intellectual property rights of the Holder and/or +Contributors. + + +Article 7 - RELATED SERVICES +----------------------------- + + +7.1. Under no circumstances shall the Agreement oblige the Licensor to +provide technical assistance or maintenance services for the Software. + +However, the Licensor is entitled to offer this type of service. The +terms and conditions of such technical assistance, and/or such +maintenance, shall then be set forth in a separate instrument. Only the +Licensor offering said maintenance and/or technical assistance services +shall incur liability therefor. + +7.2. Similarly, any or all Licensor shall be entitled to offer to its +Licensees, under its own responsibility, a warranty, that shall only be +binding upon itself, for the redistribution of the Software and/or the +Modified Software, under terms and conditions that it shall decide upon +itself. Said warranty, and the financial terms and conditions of its +application, shall be subject to a separate instrument executed between the +Licensor and the Licensee. + + +Article 8 - LIABILITY +---------------------- + + +8.1. Subject to the provisions of Article 8.2, should the Licensor fail to +fulfill all or part of its obligations hereunder, the Licensee shall be +entitled to claim compensation for the direct loss suffered as a result of +a fault on the part of the Licensor, subject to providing evidence of it. + +8.2. The Licensor's liability is limited to the commitments made under this +Licensing Agreement and shall not be incurred as a result , in particular: +(i) of loss due the Licensee's total or partial failure to fulfill its +obligations, (ii) direct or consequential loss due to the Software's use or +performance that is suffered by the Licensee, when the latter is a +professional using said Software for professional purposes and (iii) +consequential loss due to the Software's use or performance. The Parties +expressly agree that any or all pecuniary or business loss (i.e. loss of +data, loss of profits, operating loss, loss of customers or orders, +opportunity cost, any disturbance to business activities) or any or all +legal proceedings instituted against the Licensee by a third party, shall +constitute consequential loss and shall not provide entitlement to any or +all compensation from the Licensor. + + +Article 9 - WARRANTY +--------------------- + + +9.1. The Licensee acknowledges that the current situation as regards +scientific and technical know-how at the time when the Software was +distributed did not enable all possible uses to be tested and verified, nor +for the presence of any or all faults to be detected. In this respect, the +Licensee's attention has been drawn to the risks associated with loading, +using, modifying and/or developing and reproducing the Software that are +reserved for experienced users. + +The Licensee shall be responsible for verifying, by any or all means, the +product's suitability for its requirements, its due and proper functioning, +and for ensuring that it shall not cause damage to either persons or +property. + +9.2. The Licensor hereby represents, in good faith, that it is entitled to +grant all the rights on the Software (including in particular the rights +set forth in Article 5 hereof over the Software). + +9.3. The Licensee acknowledges that the Software is supplied "as is" by the +Licensor without any or all other express or tacit warranty, other than +that provided for in Article 9.2 and, in particular, without any or all +warranty as to its market value, its secured, innovative or relevant +nature. + +Specifically, the Licensor does not warrant that the Software is free from +any or all error, that it shall operate continuously, that it shall be +compatible with the Licensee's own equipment and its software +configuration, nor that it shall meet the Licensee's requirements. + +9.4. The Licensor does not either expressly or tacitly warrant that the +Software does not infringe any or all third party intellectual right +relating to a patent, software or to any or all other property right. +Moreover, the Licensor shall not hold the Licensee harmless against any or +all proceedings for infringement that may be instituted in respect of the +use, modification and redistribution of the Software. Nevertheless, should +such proceedings be instituted against the Licensee, the Licensor shall +provide it with technical and legal assistance for its defense. Such +technical and legal assistance shall be decided upon on a case-by-case +basis between the relevant Licensor and the Licensee pursuant to a +memorandum of understanding. The Licensor disclaims any or all liability as +regards the Licensee's use of the Software's name. No warranty shall be +provided as regards the existence of prior rights over the name of the +Software and as regards the existence of a trademark. + + +Article 10 - TERMINATION +------------------------- + + +10.1. In the event of a breach by the Licensee of its obligations +hereunder, the Licensor may automatically terminate this Agreement thirty +(30) days after notice has been sent to the Licensee and has remained +ineffective. + +10.2. The Licensee whose Agreement is terminated shall no longer be +authorized to use, modify or distribute the Software. However, any or all +licenses that it may have granted prior to termination of the Agreement +shall remain valid subject to their having been granted in compliance with +the terms and conditions hereof. + + +Article 11 - MISCELLANEOUS PROVISIONS +-------------------------------------- + + +11.1. EXCUSABLE EVENTS + +Neither Party shall be liable for any or all delay, or failure to perform +the Agreement, that may be attributable to an event of force majeure, an +act of God or an outside cause, such as, notably, defective functioning, or +interruptions affecting the electricity or telecommunications networks, +blocking of the network following a virus attack, the intervention of the +government authorities, natural disasters, water damage, earthquakes, fire, +explosions, strikes and labor unrest, war, etc. + +11.2. The fact that either Party may fail, on one or several occasions, to +invoke one or several of the provisions hereof, shall under no +circumstances be interpreted as being a waiver by the interested Party of +its entitlement to invoke said provision(s) subsequently. + +11.3. The Agreement cancels and replaces any or all previous agreement, +whether written or oral, between the Parties and having the same purpose, +and constitutes the entirety of the agreement between said Parties +concerning said purpose. No supplement or modification to the terms and +conditions hereof shall be effective as regards the Parties unless it is +made in writing and signed by their duly authorized representatives. + +11.4. In the event that one or several of the provisions hereof were to +conflict with a current or future applicable act or legislative text, said +act or legislative text shall take precedence, and the Parties shall make +the necessary amendments so as to be in compliance with said act or +legislative text. All the other provisions shall remain effective. +Similarly, the fact that a provision of the Agreement may be null and +void, for any reason whatsoever, shall not cause the Agreement as a whole +to be null and void. + +11.5. LANGUAGE + +The Agreement is drafted in both French and English. In the event of a +conflict as regards construction, the French version shall be deemed +authentic. + + +Article 12 - NEW VERSIONS OF THE AGREEMENT +------------------------------------------- + + +12.1. Any or all person is authorized to duplicate and distribute copies of +this Agreement. + +12.2. So as to ensure coherence, the wording of this Agreement is protected +and may only be modified by the authors of the License, that reserve the +right to periodically publish updates or new versions of the Agreement, +each with a separate number. These subsequent versions may address new issues +encountered by Free Software. + +12.3. Any or all Software distributed under a given version of the +Agreement may only be subsequently distributed under the same version of +the Agreement, or a subsequent version, subject to the provisions of +article 5.3.4. + + +Article 13 - GOVERNING LAW AND JURISDICTION +------------------------------------------- + + +13.1. The Agreement is governed by French law. The Parties agree to +endeavor to settle the disagreements or disputes that may arise during the +performance of the Agreement out-of-court. + +13.2. In the absence of an out-of-court settlement within two (2) months as +from their occurrence, and unless emergency proceedings are necessary, the +disagreements or disputes shall be referred to the Paris Courts having +jurisdiction, by the first Party to take action. + + + Version 1.1 of 10/26/2004 + + + + + + + + + + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/effective-aspects-mzv.cabal b/effective-aspects-mzv.cabal new file mode 100644 --- /dev/null +++ b/effective-aspects-mzv.cabal @@ -0,0 +1,60 @@ +-- Initial EffectiveAspects.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: effective-aspects-mzv +version: 0.1.0.0 +synopsis: A monadic embedding of aspect oriented programming, using "Monads, Zippers and Views" instead of mtl. +description: A monadic embedding of aspect oriented programming, similar to AspectJ +homepage: http://pleiad.cl/EffectiveAspects +license: OtherLicense +license-file: LICENSE +author: Ismael Figueroa, Nicolas Tabareau and Éric Tanter +maintainer: ifigueroap@gmail.com +copyright: Ismael FIgueroa, Nicolas Tabareau and Éric Tanter +category: Language, AOP, Monads, Aspect Oriented Programming +build-type: Simple +extra-source-files: README +cabal-version: >=1.10 + +source-repository head + type: git + location: git://github.com/ifigueroap/effective-aspects.git + branch: mzv + +library + exposed-modules: AOP.Default, AOP.ProtectedPointcuts, + AOP.Internal.AOPMonad, AOP.Internal.AOT, AOP.Internal.JoinpointModel, + AOP.Internal.LessGen, AOP.Internal.OpenApp, AOP.Internal.PointcutLanguage, AOP.Internal.PolyTypeable, + AOP.Internal.PolyTypeableUtils, AOP.Internal.StableNamesEq, AOP.Internal.Typeable1Monad + -- other-modules: + other-extensions: ExistentialQuantification, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, + UndecidableInstances, FlexibleContexts, GeneralizedNewtypeDeriving, RankNTypes, + TypeSynonymInstances, TypeFamilies, FunctionalDependencies, EmptyDataDecls, + OverlappingInstances, IncoherentInstances, KindSignatures, ConstraintKinds + build-depends: + base >=4.6 && <4.7, + hashtables >=1.1 && <1.2, + mzv >=0.1.0.0, + QuickCheck >=2.6 && <2.7, + HUnit >=1.2 && <1.3, + ghc-prim + hs-source-dirs: src + default-language: Haskell98 + +Test-Suite Main + type: exitcode-stdio-1.0 + hs-source-dirs: src, tests + build-depends: base >=4.6 && <4.7, + hashtables >=1.1 && <1.2, + mzv >=0.1.0.0, + QuickCheck >=2.6 && <2.7, + HUnit >=1.2 && <1.3, + ghc-prim, + Cabal >= 1.9.2, + HUnit >= 1.2, + QuickCheck >= 2.4, + test-framework >= 0.8.0.3 && < 0.9, + test-framework-quickcheck2, + test-framework-hunit + ghc-options: -Wall + main-is: TestSuite.hs diff --git a/src/AOP/Default.hs b/src/AOP/Default.hs new file mode 100644 --- /dev/null +++ b/src/AOP/Default.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleInstances, + UndecidableInstances, + ScopedTypeVariables, + MultiParamTypeClasses + #-} + +-- | Default aspect semantics, aspects are deployed and undeployed at the top level. +module AOP.Default (module X) where + +import AOP.Internal.JoinpointModel as X +import AOP.Internal.AOPMonad as X +import AOP.Internal.OpenApp as X +import AOP.Internal.PointcutLanguage as X +import AOP.Internal.AOT as X + +-- | Default aspect semantics, aspects are deployed and undeployed at the top level. +instance (Typeable1Monad m, Typeable1Monad (t m)) => MonadDeploy t m where + deployInEnv asp aenv = return (EAspect asp:aenv) + undeployInEnv asp@(Aspect (pc::PC (t m) a b) adv hnd) aenv = return (deleteAsp (EAspect asp) aenv) diff --git a/src/AOP/Internal/AOPMonad.hs b/src/AOP/Internal/AOPMonad.hs new file mode 100644 --- /dev/null +++ b/src/AOP/Internal/AOPMonad.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE MultiParamTypeClasses, + FlexibleContexts + #-} + +module AOP.Internal.AOPMonad ( +AOPMonad(..), +MonadDeploy(..), +) where + +import AOP.Internal.JoinpointModel +import AOP.Internal.OpenApp + +-- A monad that does top-level deploy/undeploy +class (Typeable1Monad m, OpenApp m) => AOPMonad m where + deploy :: LessGen (a -> b) (c -> m d) => Aspect m a b c d -> m () + undeploy :: LessGen (a -> b) (c -> m d) => Aspect m a b c d -> m () + + +-- A MonadDeploy monad defines how to deploy and undeploy aspects +class (Typeable1Monad m, Typeable1Monad (t m)) => MonadDeploy t m where + deployInEnv :: LessGen (a -> b) (c -> t m d) => + Aspect (t m) a b c d -> + AspectEnv (t m) -> m (AspectEnv (t m)) + undeployInEnv :: LessGen (a -> b) (c -> t m d) => + Aspect (t m) a b c d -> + AspectEnv (t m) -> m (AspectEnv (t m)) diff --git a/src/AOP/Internal/AOT.hs b/src/AOP/Internal/AOT.hs new file mode 100644 --- /dev/null +++ b/src/AOP/Internal/AOT.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE FlexibleInstances, + MultiParamTypeClasses, + UndecidableInstances, + ScopedTypeVariables, + FlexibleContexts, + GeneralizedNewtypeDeriving + #-} + +module AOP.Internal.AOT ( + AOT, + mkAOT, + runAOT, + wappt, + run, + mapAOT +) where + +import AOP.Internal.JoinpointModel +import AOP.Internal.AOPMonad +import AOP.Internal.OpenApp + +import Debug.Trace + + +newtype AOT m a = AOT { unAOT :: StateT (AspectEnv (AOT m)) m a } + deriving (Functor, Monad, MonadPlus, MonadCont, MonadIO) + +run = runStateT . unAOT + +mkAOT = AOT . StateT + +-- | Runs an AOT computation to obtain a computation in the underlying monad +runAOT :: Typeable1Monad m => AOT m a -> m a +runAOT c = liftM fst $ run c [] + +-- | Like mapStateT, but specialized to work on the same monad. +mapAOT :: (m (a, AspectEnv (AOT m)) -> m (b, AspectEnv (AOT m))) -> AOT m a -> AOT m b +mapAOT f m = mkAOT $ f . run m + +-- | Monadic weaver +weavet :: (Typeable1Monad m, PolyTypeable (a -> AOT m b)) => + (a -> AOT m b) -> AspectEnv (AOT m) -> AspectEnv (AOT m) -> + Jp (AOT m) a b -> m (a -> AOT m b, AspectEnv (AOT m)) +weavet f [] fenv _ = return (f,fenv) +weavet f (asp:asps) fenv jp = + case asp of EAspect (Aspect pc adv _) -> do + (match, fenv') <- run (runPC pc jp) fenv + weavet (if match then applyAdv adv f else f) asps fenv' jp + +-- | Implementation of woven application for AOT, used in the overloading of #. +wappt :: (Typeable1Monad m, PolyTypeable (a -> AOT m b)) => FunctionTag -> (a -> AOT m b) -> a -> AOT m b +wappt t f a = mkAOT $ \ aenv -> do + (woven_f, fenv) <- weavet f aenv aenv (newjp f t a) + run (woven_f a) fenv + +-- | Every regular functions is tagged with the same default tag. +instance Typeable1Monad m => OpenApp (AOT m) where + f # a = wappt defaultFunctionTag f a + +instance Typeable1Monad m => TaggedApp (AOT m) where + taggedApp t f a = wappt t f a + +-- | Typeable instance so types of computations in AOT can be compared (like in pcCall and pcType) +instance Typeable1Monad m => Typeable1 (AOT m) where + typeOf1 _ = mkTyConApp (mkTyCon3 "EffectiveAspects" "AOP.Internal.AOT" "AOT") [typeOf1 (undefined :: m ())] + +-- | The semantics of aspect deployment are defined in the +-- MonadDeploy typeclass. AOT assumes it is on top of an MonadDeploy +-- instance, and uses that functions for aspect deployment. +instance (Typeable1Monad m, MonadDeploy AOT m) => AOPMonad (AOT m) where + deploy asp = mkAOT $ \aenv -> + do aenv' <- deployInEnv asp aenv + return ((), aenv') + undeploy asp = mkAOT $ \aenv -> + do aenv' <- undeployInEnv asp aenv + return ((), deleteAsp (EAspect asp) aenv') + +instance MonadTrans AOT where + lift ma = mkAOT $ \aenv -> do { a <- ma; return (a, aenv)} + +instance MonadState s m => MonadState s (AOT m) where + get = lift get + put = lift . put + +instance (Typeable1Monad m, MonadError s m) => MonadError s (AOT m) where + throwError = lift . throwError + ma `catchError` h = mkAOT $ \aenv -> + run ma aenv `catchError` \e -> run (h e) aenv + +instance (Typeable1Monad m, MonadWriter w m) => MonadWriter w (AOT m) where + tell = lift . tell + listen m = mkAOT $ \aenv -> do + ((a, aenv'), w) <- listen (run m aenv) + return ((a, w), aenv') + pass m = mkAOT $ \aenv -> pass $ do + ((a, f), aenv') <- run m aenv + return ((a, aenv'), f) + +instance (Typeable1Monad m, MonadReader r m) => MonadReader r (AOT m) where + ask = lift ask + local f m = mkAOT $ \s -> local f (run m s) + diff --git a/src/AOP/Internal/JoinpointModel.hs b/src/AOP/Internal/JoinpointModel.hs new file mode 100644 --- /dev/null +++ b/src/AOP/Internal/JoinpointModel.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE FlexibleContexts, + ExistentialQuantification, + ScopedTypeVariables, + RankNTypes, + TypeSynonymInstances, + DeriveDataTypeable + #-} + +module AOP.Internal.JoinpointModel ( + -- | Join points + FunctionTag, + defaultFunctionTag, + Jp (..), + newjp, + compareFun, + compareType, + getJpArg, + + -- Pointcuts + PC (..), + runPC, + RequirePC (..), + + -- Advice + Advice, + applyAdv, + + -- Aspects + Aspect (..), + aspect, + deleteAsp, + EAspect (..), + AspectEnv, + + -- Other modules + 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 + +-- JOIN POINTS + +type FunctionTag = Integer + +defaultFunctionTag = 343123 + +-- | Join points are function applications. We store the function and the argument, and the function type representation. +-- | We add a FunctionTag value to use for quantification. +data Jp m a b = (Typeable1Monad m, PolyTypeable (a -> m b)) => Jp (a -> m b) FunctionTag a TypeRep + +-- | Creates a join point with given function, tag, and argument +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) + +-- | Comparing identity of functions: +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 + +-- | Compare types to see if type representation t is less general +-- | than the type of the function associated to the join point +compareType :: (Typeable1Monad m, PolyTypeable (a -> m b)) => TypeRep -> Jp m a b -> Bool +compareType t (Jp _ _ _ ft) = isLessGeneral ft t + +-- | Gets the argument bound to the join point +getJpArg :: Monad m => Jp m a b -> a +getJpArg (Jp _ _ x _) = x + +-- POINTCUTS + +-- | A pointcut is a predicate on the current join point. It is used to identify join points of interest. +data PC m a b = PC {mpcond :: forall a' b'. m (Jp m a' b' -> m Bool)} + +-- | Extracts the computation resulting of applying a join point to the pointcut +runPC (PC mpcond) jp = do { pccond <- mpcond; pccond jp} + +-- | A RequirePC is not a valid standalone pointcut, it reflects a type requirement and must be combined with a standard PC. +data RequirePC m a b = Typeable1Monad m => RequirePC {mpcond' :: forall a' b'. m (Jp m a' b' -> m Bool)} + +-- | Support for PolyTypeable + +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 ())] + +-- ADVICE + +type Advice m a b = (a -> m b) -> a -> m b + +-- | Coerces t2 to be compatible with the advice. It passes t1 as a the proceed argument of the advice. +-- This coercion is safe, as described in the paper. +applyAdv :: Advice m a b -> t2 -> t2 +applyAdv = unsafeCoerce + + +-- ASPECTS + +type AspectHandle = Unique + +-- | Typed first-class aspect. An aspect is tagged with a Unique value, used for identity +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 + +-- | Constructs a well-typed aspect +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 + +-- | Aspect with hidden types, to be used in the aspect environment +data EAspect m = forall a b c d. LessGen (a -> b) (c -> m d) => EAspect (Aspect m a b c d) + +-- | Aspect environment +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 + +-- | Deletes asp from the aspect environment, used in undeploy +deleteAsp :: Typeable1Monad m => EAspect m -> AspectEnv m -> AspectEnv m +deleteAsp asp = filter (\asp' -> asp /= asp') + +-- | Support for PolyTypeable +instance PolyTypeable Unique where + polyTypeOf _ = mkTyConApp (mkTyCon3 "GHC" "Unique" "") [] + +-- | Notion of aspect equality to delete aspects from the aspect environment +instance Typeable1Monad m => Eq (EAspect m) where + EAspect (Aspect _ _ u1) == EAspect (Aspect _ _ u2) = u1 == u2 diff --git a/src/AOP/Internal/LessGen.hs b/src/AOP/Internal/LessGen.hs new file mode 100644 --- /dev/null +++ b/src/AOP/Internal/LessGen.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE EmptyDataDecls, + MultiParamTypeClasses, + TypeFamilies, + FunctionalDependencies, + UndecidableInstances, + FlexibleInstances, + OverlappingInstances, + IncoherentInstances + #-} + +module AOP.Internal.LessGen (LessGen, LeastGen, Analyze, LeastGen', SubstEmpty) where + +import AOP.Internal.PolyTypeable + +-- Check if two analysed types can be matchedd. +-- The tricky part is to construct a substitution using type classes. + +-- | If LeastGen a b c holds then there exists a substitution s and type c such that (s c = (a, b)). +class LeastGen a b c + +-- LeastGen is defined in terms of LeastGen'. We discard the constructed substitution sout. +instance (Analyze a _a, Analyze b _b, LeastGen' _a _b c SubstEmpty sout) => LeastGen a b c + +-- | If LessGen a b, then b is less general than a. That is, there exists substitution s such that (s b = a). +class LessGen a b + +-- | It unifies a with b after checking the substitution s. +-- | We use this to delay unification in the following instance declaration for LessGen. +-- | If we just use typical unification, this will be done *before* constructing/checking the substitution. +-- | The idea is that if the substitution exists, then the unification is one-way and is performed. +class Unifies s a b +instance a ~ b => Unifies SubstEmpty a b +instance a ~ b => Unifies (SubstCons x y s) a b + + -- LessGen is also defined in terms of LeastGen' +instance (Analyze a _a, Analyze b _b, LeastGen' _a _b b SubstEmpty sout, Unifies sout a b) => LessGen a b + + +-- LeastGen' extends the substitution s0 to sout +-- such that (sout b = a). +class (Substitution sin, Substitution sout) => LeastGen' a b c sin sout | sin a b c -> sout + +-- Constant types we check if they are both the same +instance (Substitution s0, a ~ c) => LeastGen' (TCon0 a) (TCon0 a) c s0 s0 + +-- for n-ary constructors, the substitution is extended for each argument +-- and chained from left to right +instance (LeastGen' a1 b1 c1 s0 s1, + d ~ d', d c1 ~ c) + => LeastGen' (TCon1 (d ()) a1) (TCon1 (d' ()) b1) c s0 s1 + +instance (LeastGen' a1 b1 c1 s0 s1, + LeastGen' a2 b2 c2 s1 s2, + d ~ d', d c1 c2 ~ c) + => LeastGen' (TCon2 (d () () ) a1 a2) (TCon2 (d' () ()) b1 b2) c s0 s2 + +instance (LeastGen' a1 b1 c1 s0 s1, + LeastGen' a2 b2 c2 s1 s2, + LeastGen' a3 b3 c3 s2 s3, + d ~ d', d c1 c2 c3 ~ c) + => LeastGen' (TCon3 (d () () ()) a1 a2 a3) (TCon3 (d' () () ()) b1 b2 b3) c s0 s3 + +instance (LeastGen' a1 b1 c1 s0 s1, + LeastGen' a2 b2 c2 s1 s2, + LeastGen' a3 b3 c3 s2 s3, + LeastGen' a4 b4 c4 s3 s4, + d ~ d', d c1 c2 c3 c4 ~ c) + => LeastGen' (TCon4 (d () () () ()) a1 a2 a3 a4) (TCon4 (d' () () () ()) b1 b2 b3 b4) c s0 s4 + +instance (LeastGen' a1 b1 c1 s0 s1, + LeastGen' a2 b2 c2 s1 s2, + LeastGen' a3 b3 c3 s2 s3, + LeastGen' a4 b4 c4 s3 s4, + LeastGen' a5 b5 c5 s4 s5, + d ~ d', d c1 c2 c3 c4 c5 ~ c) + => LeastGen' (TCon5 (d () () () () ()) a1 a2 a3 a4 a5) (TCon5 (d' () () () () ()) b1 b2 b3 b4 b5) c s0 s5 + +-- default case when a and b doesn't share the same constructor +instance (Substitution sin, Substitution sout, + MapsTo sin (a, b) c', + VarCase c' (a, b) c sin sout, + Analyze (W c) (TVar c) + ) => LeastGen' a b c sin sout + +-- extends the substitution if required +class (MaybeType v, Substitution sin, Substitution sout) => VarCase v ab c sin sout | v ab sin -> sout c +instance Substitution sin => VarCase None ab c sin (SubstCons ab c sin) +instance Substitution sin => VarCase (Some c) ab c sin sin -- check that s(b) = a + +---------------------------------- + +-- | Encoding of substitutions as partial maps + +data SubstEmpty +data SubstCons x sx s + +class Substitution s +instance Substitution SubstEmpty +instance Substitution s => Substitution (SubstCons x sx s) + +data None +data Some a + +class MaybeType a +instance MaybeType None +instance MaybeType (Some a) + +-- | Examines substitution s and binds sx the variable that maps to x in s, or None. +class (Substitution s, MaybeType sx) => MapsTo s x sx | s x -> sx + +instance MapsTo SubstEmpty x None +instance Substitution s => MapsTo (SubstCons x sx s) x (Some sx) +instance (Substitution s, MapsTo s x sx) => MapsTo (SubstCons x' sx' s) x sx + + + + + +-- | Plotkin's example of the bit of iron + +-- To make Analyze work on I419, could be made more pretty using TemplateHaskell +-- instance (r ~ TCon0 I419) => Analyze I419 r +instance (r ~ TCon0 I419) => Analyze I419 r; instance (r ~ TCon0 I419) => Analyze (W I419) r + +instance (r ~ TCon0 Bit1) => Analyze Bit1 r; instance (r ~ TCon0 Bit1) => Analyze (W Bit1) r +instance (r ~ TCon0 Bit2) => Analyze Bit2 r; instance (r ~ TCon0 Bit2) => Analyze (W Bit2) r + + +data Bitofiron a = Bitofiron a +data Heated a b = Heated a b +data Melted a = Melted a + +data Bit1 +data Bit2 +data I419 + +bit1 :: Bitofiron Bit1 -> Heated Bit1 I419 -> Melted Bit1 +bit1 = undefined + +bit2 :: Bitofiron Bit2 -> Heated Bit2 I419 -> Melted Bit2 +bit2 = undefined + +generalize :: LeastGen t1 t2 t3 => t1 -> t2 -> t3 +generalize = undefined + +genBit = generalize bit1 bit2 diff --git a/src/AOP/Internal/OpenApp.hs b/src/AOP/Internal/OpenApp.hs new file mode 100644 --- /dev/null +++ b/src/AOP/Internal/OpenApp.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE FlexibleContexts, + KindSignatures, + MultiParamTypeClasses, + ImplicitParams + #-} + +module AOP.Internal.OpenApp ( + OpenApp (..), + TaggedApp (..), +) where + +import AOP.Internal.Typeable1Monad +import AOP.Internal.JoinpointModel (FunctionTag) + +class Typeable1Monad m => OpenApp m where + (#) :: (PolyTypeable (a -> m b)) => (a -> m b) -> a -> m b + +class Typeable1Monad m => TaggedApp m where + taggedApp :: (PolyTypeable (a -> m b)) => FunctionTag -> (a -> m b) -> a -> m b diff --git a/src/AOP/Internal/PointcutLanguage.hs b/src/AOP/Internal/PointcutLanguage.hs new file mode 100644 --- /dev/null +++ b/src/AOP/Internal/PointcutLanguage.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE FlexibleContexts, + ConstraintKinds, + TypeFamilies, + MultiParamTypeClasses, + FlexibleInstances + #-} + + +module AOP.Internal.PointcutLanguage ( + pcCall, + pcType, + pcAnd, + pcTag, + pcOr, + pcNot, +) where + +import GHC.Prim (Constraint) +import AOP.Internal.JoinpointModel + +import Debug.Trace + +{- | +Built-in pointcuts pcCall and pcType, and pointcut combinators pcAnd, pcOr and pcNot. +Using typeclasses, pointcuts are open for new definitions of functions, like the Function wrapper. +We also define pcSeq, that matches a sequence of two join points. +-} + +pcCall :: (Typeable1Monad m, PolyTypeable (a -> b)) => (a -> b) -> PC m a b +pcCall f = let typRefF = polyTypeOf f in PC (pcCallPred f typRefF defaultFunctionTag) + where pcCallPred fun t tag = return $ \ jp -> return (compareFun fun tag jp && compareType t jp) + +pcTag :: (Typeable1Monad m, PolyTypeable (a -> b)) => FunctionTag -> PC m a' b' +pcTag t = PC (pcTagPred t) + where pcTagPred t = return $ \ (Jp _ tag _ _) -> return (tag == t) + +pcType :: (Typeable1Monad m, PolyTypeable (a -> b)) => (a -> b) -> PC m a b +pcType f = let typRefF = polyTypeOf f in PC (pcTypePred typRefF) + where pcTypePred t = (return (\jp -> return (compareType t jp))) + +-- | And pointcut combinator, overloaded to support PC and RequirePC +class Typeable1Monad m => PCAnd m a1 b1 a2 b2 pct where + type PCAndCtx m a1 b1 a2 b2 pct :: Constraint + pcAnd :: PCAndCtx m a1 b1 a2 b2 pct => PC m a1 b1 -> pct m a2 b2 -> PC m a1 b1 + +-- | When combining two PC pointcuts, the matched types t1 and t2 must be the same +-- | This expressed in the constraint t1 ~ t2 +instance Typeable1Monad m => PCAnd m a1 b1 a2 b2 PC where + type PCAndCtx m a1 b1 a2 b2 PC = ((a1 -> b1) ~ (a2 -> b2)) + pcAnd (PC mpc1) (PC mpc2) = PC (_pcAndImpl mpc1 mpc2) + +-- | When combining a PC with a RequirePC we constraint t1 to be LessGen than t2 +instance Typeable1Monad m => PCAnd m a1 b1 a2 b2 RequirePC where + type PCAndCtx m a1 b1 a2 b2 RequirePC = (LessGen (a1 -> b1) (a2 -> b2)) + pcAnd (PC mpc1) (RequirePC mpc2) = PC (_pcAndImpl mpc1 mpc2) + +-- | Logical Or pointcut combinator. +pcOr :: (Typeable1Monad m, LeastGen (a1 -> b1) (a2 -> b2) (agen -> bgen)) => PC m a1 b1 -> PC m a2 b2 -> PC m agen bgen +pcOr (PC mpc1) (PC mpc2) = PC (_pcOrImpl mpc1 mpc2) + +-- | Logical Not pointcut combinator. +pcNot :: Typeable1Monad m => PC m a1 b1 -> PC m a2 b2 +pcNot (PC mpc) = PC (_pcNotImpl mpc) + + +-- Implementations + +_pcAndImpl mpc1 mpc2 = do + pc1 <- mpc1 + pc2 <- mpc2 + return $ \ jp -> do + res1 <- pc1 jp + if res1 + then do res2 <- pc2 jp + return res2 + else return False + +_pcOrImpl mpc1 mpc2 = do + pc1 <- mpc1 + pc2 <- mpc2 + return $ \ jp -> do + res1 <- pc1 jp + if res1 + then return True + else do res2 <- pc2 jp + return res2 + +_pcNotImpl mpc1 = do + pc1 <- mpc1 + return $ \ jp -> do + res1 <- pc1 jp + return (not res1) + diff --git a/src/AOP/Internal/PolyTypeable.hs b/src/AOP/Internal/PolyTypeable.hs new file mode 100644 --- /dev/null +++ b/src/AOP/Internal/PolyTypeable.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE CPP, EmptyDataDecls, ScopedTypeVariables, FlexibleInstances, OverlappingInstances, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts, UndecidableInstances, TypeFamilies #-} +{-# LANGUAGE IncoherentInstances #-} +-- +-- This amazing piece of code does that Data.Typeable.typeOf does, +-- but also does it for polymorphic functions. +-- This is Oleg type magic at its best. +module AOP.Internal.PolyTypeable( + PolyTypeable(..) + , Analyze (..) + , W (..) + , TCon0, TCon1, TCon2, TCon3, TCon4, TCon5, TVar + +) where +import Data.Typeable +import Data.Int +import Data.Word + +---------------------------------- +-- Type analysis, classifies each type constructor and type variables. + +data TVar a +data TCon0 c +data TCon1 c a1 +data TCon2 c a1 a2 +data TCon3 c a1 a2 a3 +data TCon4 c a1 a2 a3 a4 +data TCon5 c a1 a2 a3 a4 a5 + +class Analyze a b | a -> b + +analyze :: Analyze a b => a -> b +analyze = undefined + +data W a + +#define BASE(t) instance (r ~ TCon0 t) => Analyze t r; instance (r ~ TCon0 t) => Analyze (W t) r +BASE(()) +BASE(Bool) +BASE(Char) +BASE(Ordering) +BASE(Int) +BASE(Integer) +BASE(Float) +BASE(Double) +BASE(Int8) +BASE(Int16) +BASE(Int32) +BASE(Int64) +BASE(Word8) +BASE(Word16) +BASE(Word32) +BASE(Word64) + +instance (Analyze (W a1) ra1, r ~ TCon1 (c ()) ra1) => Analyze (W (c a1)) r +instance (Analyze (W a1) ra1, r ~ TCon1 (c ()) ra1) => Analyze (c a1) r + +instance (Analyze (W a1) ra1, Analyze (W a2) ra2, r ~ TCon2 (c () ()) ra1 ra2) => Analyze (W (c a1 a2)) r +instance (Analyze (W a1) ra1, Analyze (W a2) ra2, r ~ TCon2 (c () ()) ra1 ra2) => Analyze (c a1 a2) r + +instance (Analyze (W a1) ra1, Analyze (W a2) ra2, Analyze (W a3) ra3, r ~ TCon3 (c () () ()) ra1 ra2 ra3) => Analyze (W (c a1 a2 a3)) r +instance (Analyze (W a1) ra1, Analyze (W a2) ra2, Analyze (W a3) ra3, r ~ TCon3 (c () () ())ra1 ra2 ra3) => Analyze (c a1 a2 a3) r + +instance (Analyze (W a1) ra1, Analyze (W a2) ra2, Analyze (W a3) ra3, Analyze (W a4) ra4, r ~ TCon4 (c () () () ()) ra1 ra2 ra3 ra4) => + Analyze (W (c a1 a2 a3 a4)) r +instance (Analyze (W a1) ra1, Analyze (W a2) ra2, Analyze (W a3) ra3, Analyze (W a4) ra4, r ~ TCon4 (c () () () ()) ra1 ra2 ra3 ra4) => + Analyze (c a1 a2 a3 a4) r + +instance (Analyze (W a1) ra1, Analyze (W a2) ra2, Analyze (W a3) ra3, Analyze (W a4) ra4, Analyze (W a5) ra5, r ~ TCon5 (c () () () () ()) ra1 ra2 ra3 ra4 ra5) => + Analyze (W (c a1 a2 a3 a4 a5)) r +instance (Analyze (W a1) ra1, Analyze (W a2) ra2, Analyze (W a3) ra3, Analyze (W a4) ra4, Analyze (W a5) ra5, r ~ TCon5 (c () () () () ()) ra1 ra2 ra3 ra4 ra5) => + Analyze (c a1 a2 a3 a4 a5) r + +instance (r ~ TVar a) => Analyze (W a) r + +---------------------------------- +-- Convert an analysed type to a TypeRep. +-- The tricky part is to assign a fresh type variable to each Haskell type variable. + +-- Return a 'TypeRep' for a type. Type variables look like type constructors, +-- but start with a lower case letter. +class PolyTypeable a where + polyTypeOf :: a -> TypeRep + +instance (Analyze a result, MyTypeable' HNil gout result) => + PolyTypeable a where + polyTypeOf a = fst $ mytypof' HNil (analyze a) + +class MyTypeable' g0 gout classification | g0 classification -> gout where + mytypof' :: g0 -> classification -> (TypeRep, gout) + +instance (Typeable a) => MyTypeable' g0 g0 (TCon0 a) where + mytypof' g0 _ = (typeOf (undefined::a), g0) + +instance (Typeable c, MyTypeable' g0 g1 a1) => + MyTypeable' g0 g1 (TCon1 c a1) where + mytypof' g0 _ = let (c, _) = splitTyConApp $ typeOf (undefined :: c) + (tr1,g1) = mytypof' g0 (undefined::a1) + in (mkTyConApp c [tr1], g1) + +instance (Typeable c, MyTypeable' g0 g a1, MyTypeable' g g2 a2) => + MyTypeable' g0 g2 (TCon2 c a1 a2) where + mytypof' g0 _ = let (c, _) = splitTyConApp $ typeOf (undefined :: c) + (tr1,g1) = mytypof' g0 (undefined::a1) + (tr2,g2) = mytypof' g1 (undefined::a2) + in (mkTyConApp c [tr1, tr2], g2) + +instance (Typeable c, MyTypeable' g0 g1 a1, MyTypeable' g1 g2 a2, MyTypeable' g2 g3 a3) => + MyTypeable' g0 g3 (TCon3 c a1 a2 a3) where + mytypof' g0 _ = let (c, _) = splitTyConApp $ typeOf (undefined :: c) + (tr1,g1) = mytypof' g0 (undefined::a1) + (tr2,g2) = mytypof' g1 (undefined::a2) + (tr3,g3) = mytypof' g2 (undefined::a3) + in (mkTyConApp c [tr1, tr2, tr3], g3) + +instance (Typeable c, MyTypeable' g0 g1 a1, MyTypeable' g1 g2 a2, MyTypeable' g2 g3 a3, MyTypeable' g3 g4 a4) => + MyTypeable' g0 g4 (TCon4 c a1 a2 a3 a4) where + mytypof' g0 _ = let (c, _) = splitTyConApp $ typeOf (undefined :: c) + (tr1,g1) = mytypof' g0 (undefined::a1) + (tr2,g2) = mytypof' g1 (undefined::a2) + (tr3,g3) = mytypof' g2 (undefined::a3) + (tr4,g4) = mytypof' g3 (undefined::a4) + in (mkTyConApp c [tr1, tr2, tr3, tr4], g4) + +instance (Typeable c, MyTypeable' g0 g1 a1, MyTypeable' g1 g2 a2, MyTypeable' g2 g3 a3, MyTypeable' g3 g4 a4, MyTypeable' g4 g5 a5) => + MyTypeable' g0 g5 (TCon5 c a1 a2 a3 a4 a5) where + mytypof' g0 _ = let (c, _) = splitTyConApp $ typeOf (undefined :: c) + (tr1,g1) = mytypof' g0 (undefined::a1) + (tr2,g2) = mytypof' g1 (undefined::a2) + (tr3,g3) = mytypof' g2 (undefined::a3) + (tr4,g4) = mytypof' g3 (undefined::a4) + (tr5,g5) = mytypof' g4 (undefined::a5) + in (mkTyConApp c [tr1, tr2, tr3, tr4, tr5], g5) + +instance (HIndex a g0 n, MyTypeable'' n g0 gout (TVar a)) => + MyTypeable' g0 gout (TVar a) where + mytypof' = mytypof'' (undefined::n) + + +class MyTypeable'' n g0 gout classification | n g0 classification -> gout where + mytypof'' :: n -> g0 -> classification -> (TypeRep, gout) + +instance HLen g0 n1 => MyTypeable'' Z g0 (HCons a g0) (TVar a) where + mytypof'' _ g0 _ = (mkany (undefined::S n1), HCons (undefined::a) g0) + +instance Nat n => MyTypeable'' (S n) g0 g0 (TVar a) where + mytypof'' _ g0 _ = (mkany (undefined::S n), g0) + + +mkany :: Nat n => n -> TypeRep +mkany n = mkTyConApp (mkTyCon ts) [] + where ts = "a" ++ show (nat n) + +---------------------------------- +-- Bits and pieces from HList. + +-- Lookup the index of an item x in the list l +-- The index is 1-based. If not found, return 0 +class Nat n => HIndex x l n | x l -> n + +instance HIndex x HNil Z + +instance (Nat n, TypeEq x a f, HIndex' f x (HCons a l) n) + => HIndex x (HCons a l) n + +class HIndex' f x l n | f x l -> n + +instance HLen l n => HIndex' HTrue x l n +instance HIndex x l n => HIndex' HFalse x (HCons a l) n + +class Nat n => HLen l n | l -> n +instance HLen HNil Z +instance HLen l n => HLen (HCons a l) (S n) + +data Z +data S a + +class Nat a where nat :: a -> Int +instance Nat Z where nat _ = 0 +instance Nat a => Nat (S a) where nat _ = succ (nat (undefined::a)) + + +data HTrue +data HFalse + +data HNil = HNil +data HCons a b = HCons a b + + +class TypeEq' () x y b => TypeEq x y b | x y -> b + where type'eq :: x -> y -> b + type'eq _ _ = undefined::b +class TypeEq' q x y b | q x y -> b +class TypeEq'' q x y b | q x y -> b +instance TypeEq' () x y b => TypeEq x y b +instance b ~ HTrue => TypeEq' () x x b +instance TypeEq'' q x y b => TypeEq' q x y b +instance TypeEq'' () x y HFalse diff --git a/src/AOP/Internal/PolyTypeableUtils.hs b/src/AOP/Internal/PolyTypeableUtils.hs new file mode 100644 --- /dev/null +++ b/src/AOP/Internal/PolyTypeableUtils.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleInstances #-} + +module AOP.Internal.PolyTypeableUtils where + +import AOP.Internal.PolyTypeable +import Data.Typeable.Internal +import System.IO.Unsafe +import Data.HashTable +import Data.Char + +import Debug.Trace + +-- | Monad andmap +mmap :: Monad m => (a -> a' -> m Bool) -> [a] -> [a'] -> m Bool +mmap _ [] [] = return True +mmap _ [] _ = return False +mmap _ _ [] = return False +mmap f (h:t) (h':t') = do x <- f h h' + y <- mmap f t t' + return (x && y) + +-- | Applies a function on the first component of a pair +first :: (a -> a') -> (a,b) -> (a',b) +first f (a,b) = (f a, b) + +-- | Returns True iff t1 is less general than t2 +-- | We use a hashmap to compute a substitution from t2 to t1 +isLessGeneral :: TypeRep -> TypeRep -> Bool +isLessGeneral t1 t2 = unsafePerformIO $ do { hash <- new (==) hashInt; findSubstitution hash t2 t1} + where findSubstitution hash t1 t2 = + case first tyConName (splitTyConApp t1) of + (tc1, []) -> if head tc1 == 'a' + then do let int_tc1 = digitToInt (last tc1) + is_registered <- Data.HashTable.lookup hash int_tc1 + case is_registered of + Nothing -> do insert hash int_tc1 t2 + return True + Just t2' -> return (t2 == t2') + else return (t1 == t2) + (tc1, l1) -> case first tyConName (splitTyConApp t2) of + (tc2, l2) -> do b <- mmap (findSubstitution hash) l1 l2 + return (tc1 == tc2 && b) diff --git a/src/AOP/Internal/StableNamesEq.hs b/src/AOP/Internal/StableNamesEq.hs new file mode 100644 --- /dev/null +++ b/src/AOP/Internal/StableNamesEq.hs @@ -0,0 +1,12 @@ +module AOP.Internal.StableNamesEq where + +import System.Mem.StableName +import System.IO.Unsafe + +-- | Equality of functions based on the StableName API +stableNamesEq :: a -> b -> Bool +stableNamesEq a b = unsafePerformIO $ do + pa <- makeStableName a + pb <- makeStableName b + return (hashStableName pa == hashStableName pb) + diff --git a/src/AOP/Internal/Typeable1Monad.hs b/src/AOP/Internal/Typeable1Monad.hs new file mode 100644 --- /dev/null +++ b/src/AOP/Internal/Typeable1Monad.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE FlexibleInstances, + UndecidableInstances, + ScopedTypeVariables + #-} + +module AOP.Internal.Typeable1Monad ( + Typeable1Monad (..), + module X, +) where + +import Data.Typeable as X +import AOP.Internal.PolyTypeable as X +import Control.Monad as X +import Control.Monad.Identity as X +import Control.Monad.Trans as X +import Control.Monad.State as X +import Control.Monad.Writer as X +import Control.Monad.Reader as X +import Control.Monad.Cont as X +import Control.Monad.Error as X + +{- | Support for PolyTypeable when using monads and monad transformers -} + +class (Typeable1 m, Monad m) => Typeable1Monad m + +instance (Typeable1 m, Monad m) => Typeable1Monad m + +instance Typeable1 Identity where + typeOf1 _ = mkTyConApp (mkTyCon3 "Control" "Monad" "Identity") [] + +instance (Typeable1Monad m, Typeable s) => Typeable1 (StateT s m) where + typeOf1 _ = mkTyConApp (mkTyCon3 "Control" "Monad" "StateT") [typeOf (undefined :: s), typeOf1 (undefined :: m ())] + +instance (Typeable1Monad m, Typeable s) => Typeable1 (WriterT s m) where + typeOf1 _ = mkTyConApp (mkTyCon3 "Control" "Monad" "WriterT") [typeOf (undefined :: s), typeOf1 (undefined :: m ())] + +instance (Typeable1Monad m, Typeable s) => Typeable1 (ErrorT s m) where + typeOf1 _ = mkTyConApp (mkTyCon3 "Control" "Monad" "ErrorT") + [typeOf (undefined :: s), typeOf1 (undefined :: m ())] diff --git a/src/AOP/ProtectedPointcuts.hs b/src/AOP/ProtectedPointcuts.hs new file mode 100644 --- /dev/null +++ b/src/AOP/ProtectedPointcuts.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE ExistentialQuantification, + FlexibleContexts + #-} + +module AOP.ProtectedPointcuts ( + ProtectedPC, + protectPC, + pAspect, + ppcAnd, + ppcOr +) where + +import AOP.Internal.JoinpointModel +import AOP.Internal.PointcutLanguage (pcAnd, pcOr) + +type Combinator t m a b = t -> Advice m a b + +data ProtectedPC m a b t c d = (Typeable1Monad m, LessGen (a -> b) (c -> m d)) => PPC (PC m a b) (Combinator t m c d) + +protectPC :: (Typeable1Monad m, LessGen (a -> b) (c -> m d)) => PC m a b -> Combinator t m c d -> ProtectedPC m a b t c d +protectPC = PPC + +-- | Creates a protected aspect based on a given protected pc +pAspect :: (Monad m, LessGen (a -> b) (c -> m d)) => ProtectedPC m a b t c d -> t -> Aspect m a b c d +pAspect (PPC pc comb) as = aspect pc (comb as) + +-- | Logical and combinator for protected pointcuts +ppcAnd :: (Typeable1Monad m) => ProtectedPC m a b t c d -> ProtectedPC m a b t c d -> ProtectedPC m a b t c d +ppcAnd (PPC pc1 comb) (PPC pc2 comd) = PPC (pcAnd pc1 pc2) comb + +-- | Logical or combinator for protected pointcuts +ppcOr :: (Typeable1Monad m, LeastGen (a -> b) (c -> d) (agen -> bgen), LessGen (agen -> bgen) (a' -> m b')) + => ProtectedPC m a b t a' b' -> ProtectedPC m c d t a' b' -> ProtectedPC m agen bgen t a' b' +ppcOr (PPC pc1 comb) (PPC pc2 comd) = PPC (pcOr pc1 pc2) comb diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs new file mode 100644 --- /dev/null +++ b/tests/TestSuite.hs @@ -0,0 +1,11 @@ +module Main where + +import Test.Framework (defaultMain) +import AOP.Test.AOT as AOT +-- import AOP.Test.Cflow as Cflow + +main :: IO () +main = defaultMain testSuite + +testSuite = [ AOT.tests ] +