effective-aspects (empty) → 0.1.0.0
raw patch · 17 files changed
+1465/−0 lines, 17 filesdep +Cabaldep +HUnitdep +QuickChecksetup-changed
Dependencies added: Cabal, HUnit, QuickCheck, base, ghc-prim, hashtables, mtl, test-framework, test-framework-hunit, test-framework-quickcheck2
Files
- LICENSE +512/−0
- README +0/−0
- Setup.hs +2/−0
- effective-aspects.cabal +59/−0
- src/AOP/Default.hs +19/−0
- src/AOP/Internal/AOPMonad.hs +26/−0
- src/AOP/Internal/AOT.hs +96/−0
- src/AOP/Internal/JoinpointModel.hs +150/−0
- src/AOP/Internal/LessGen.hs +146/−0
- src/AOP/Internal/OpenApp.hs +19/−0
- src/AOP/Internal/PointcutLanguage.hs +93/−0
- src/AOP/Internal/PolyTypeable.hs +205/−0
- src/AOP/Internal/PolyTypeableUtils.hs +42/−0
- src/AOP/Internal/StableNamesEq.hs +12/−0
- src/AOP/Internal/Typeable1Monad.hs +39/−0
- src/AOP/ProtectedPointcuts.hs +34/−0
- tests/TestSuite.hs +11/−0
+ LICENSE view
@@ -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++++++++++
+ README view
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ effective-aspects.cabal view
@@ -0,0 +1,59 @@+-- Initial EffectiveAspects.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: effective-aspects+version: 0.1.0.0+synopsis: A monadic embedding of aspect oriented programming+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++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,+ mtl >=2.1 && <2.2,+ 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,+ mtl >=2.1 && <2.2,+ 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
+ src/AOP/Default.hs view
@@ -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)
+ src/AOP/Internal/AOPMonad.hs view
@@ -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))
+ src/AOP/Internal/AOT.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE FlexibleInstances,+ MultiParamTypeClasses,+ UndecidableInstances,+ ScopedTypeVariables,+ FlexibleContexts,+ GeneralizedNewtypeDeriving+ #-}++module AOP.Internal.AOT (+ AOT,+ mkAOT,+ runAOT,+ wappt,+) 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 []++-- | 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)+
+ src/AOP/Internal/JoinpointModel.hs view
@@ -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
+ src/AOP/Internal/LessGen.hs view
@@ -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
+ src/AOP/Internal/OpenApp.hs view
@@ -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
+ src/AOP/Internal/PointcutLanguage.hs view
@@ -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)+
+ src/AOP/Internal/PolyTypeable.hs view
@@ -0,0 +1,205 @@+{-# 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(..),+ W,+ Analyze,+ TVar,+ TCon0,+ TCon1,+ TCon2,+ TCon3,+ TCon4,+ TCon5,+) 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
+ src/AOP/Internal/PolyTypeableUtils.hs view
@@ -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)
+ src/AOP/Internal/StableNamesEq.hs view
@@ -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)+
+ src/AOP/Internal/Typeable1Monad.hs view
@@ -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 ())]
+ src/AOP/ProtectedPointcuts.hs view
@@ -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
+ tests/TestSuite.hs view
@@ -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 ]+