classy-effects-th (empty) → 0.1.0.0
raw patch · 15 files changed
+1758/−0 lines, 15 filesdep +basedep +classy-effects-basedep +classy-effects-th
Dependencies added: base, classy-effects-base, classy-effects-th, extra, lens, mtl, tasty, tasty-hunit, template-haskell, th-abstraction
Files
- ChangeLog.md +5/−0
- Example/DeriveHFunctor.hs +19/−0
- Example/Driver.hs +5/−0
- LICENSE +373/−0
- NOTICE +7/−0
- README.md +25/−0
- classy-effects-th.cabal +120/−0
- src/Control/Effect/Class/Machinery/TH.hs +153/−0
- src/Control/Effect/Class/Machinery/TH/Internal.hs +130/−0
- src/Control/Effect/Class/Machinery/TH/Send.hs +107/−0
- src/Control/Effect/Class/Machinery/TH/Send/Internal.hs +72/−0
- src/Data/Effect/Class/TH.hs +75/−0
- src/Data/Effect/Class/TH/HFunctor.hs +30/−0
- src/Data/Effect/Class/TH/HFunctor/Internal.hs +179/−0
- src/Data/Effect/Class/TH/Internal.hs +458/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for classy-effects-th++## 0.1.0.0 -- 2023-09-18++* Initial public release.
+ Example/DeriveHFunctor.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}++-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at https://mozilla.org/MPL/2.0/.++module DeriveHFunctor where++import Control.Effect.Class.Machinery.TH (makeEffect)++class Except e f where+ throw :: e -> f a+ catch :: f a -> (e -> f a) -> f a++makeEffect ''Except++unit_exception :: IO ()+unit_exception = undefined
+ Example/Driver.hs view
@@ -0,0 +1,5 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}++-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at https://mozilla.org/MPL/2.0/.
+ LICENSE view
@@ -0,0 +1,373 @@+Mozilla Public License Version 2.0+==================================++1. Definitions+--------------++1.1. "Contributor"+ means each individual or legal entity that creates, contributes to+ the creation of, or owns Covered Software.++1.2. "Contributor Version"+ means the combination of the Contributions of others (if any) used+ by a Contributor and that particular Contributor's Contribution.++1.3. "Contribution"+ means Covered Software of a particular Contributor.++1.4. "Covered Software"+ means Source Code Form to which the initial Contributor has attached+ the notice in Exhibit A, the Executable Form of such Source Code+ Form, and Modifications of such Source Code Form, in each case+ including portions thereof.++1.5. "Incompatible With Secondary Licenses"+ means++ (a) that the initial Contributor has attached the notice described+ in Exhibit B to the Covered Software; or++ (b) that the Covered Software was made available under the terms of+ version 1.1 or earlier of the License, but not also under the+ terms of a Secondary License.++1.6. "Executable Form"+ means any form of the work other than Source Code Form.++1.7. "Larger Work"+ means a work that combines Covered Software with other material, in+ a separate file or files, that is not Covered Software.++1.8. "License"+ means this document.++1.9. "Licensable"+ means having the right to grant, to the maximum extent possible,+ whether at the time of the initial grant or subsequently, any and+ all of the rights conveyed by this License.++1.10. "Modifications"+ means any of the following:++ (a) any file in Source Code Form that results from an addition to,+ deletion from, or modification of the contents of Covered+ Software; or++ (b) any new file in Source Code Form that contains any Covered+ Software.++1.11. "Patent Claims" of a Contributor+ means any patent claim(s), including without limitation, method,+ process, and apparatus claims, in any patent Licensable by such+ Contributor that would be infringed, but for the grant of the+ License, by the making, using, selling, offering for sale, having+ made, import, or transfer of either its Contributions or its+ Contributor Version.++1.12. "Secondary License"+ means either the GNU General Public License, Version 2.0, the GNU+ Lesser General Public License, Version 2.1, the GNU Affero General+ Public License, Version 3.0, or any later versions of those+ licenses.++1.13. "Source Code Form"+ means the form of the work preferred for making modifications.++1.14. "You" (or "Your")+ means an individual or a legal entity exercising rights under this+ License. For legal entities, "You" includes any entity that+ controls, is controlled by, or is under common control with You. For+ purposes of this definition, "control" means (a) the power, direct+ or indirect, to cause the direction or management of such entity,+ whether by contract or otherwise, or (b) ownership of more than+ fifty percent (50%) of the outstanding shares or beneficial+ ownership of such entity.++2. License Grants and Conditions+--------------------------------++2.1. Grants++Each Contributor hereby grants You a world-wide, royalty-free,+non-exclusive license:++(a) under intellectual property rights (other than patent or trademark)+ Licensable by such Contributor to use, reproduce, make available,+ modify, display, perform, distribute, and otherwise exploit its+ Contributions, either on an unmodified basis, with Modifications, or+ as part of a Larger Work; and++(b) under Patent Claims of such Contributor to make, use, sell, offer+ for sale, have made, import, and otherwise transfer either its+ Contributions or its Contributor Version.++2.2. Effective Date++The licenses granted in Section 2.1 with respect to any Contribution+become effective for each Contribution on the date the Contributor first+distributes such Contribution.++2.3. Limitations on Grant Scope++The licenses granted in this Section 2 are the only rights granted under+this License. No additional rights or licenses will be implied from the+distribution or licensing of Covered Software under this License.+Notwithstanding Section 2.1(b) above, no patent license is granted by a+Contributor:++(a) for any code that a Contributor has removed from Covered Software;+ or++(b) for infringements caused by: (i) Your and any other third party's+ modifications of Covered Software, or (ii) the combination of its+ Contributions with other software (except as part of its Contributor+ Version); or++(c) under Patent Claims infringed by Covered Software in the absence of+ its Contributions.++This License does not grant any rights in the trademarks, service marks,+or logos of any Contributor (except as may be necessary to comply with+the notice requirements in Section 3.4).++2.4. Subsequent Licenses++No Contributor makes additional grants as a result of Your choice to+distribute the Covered Software under a subsequent version of this+License (see Section 10.2) or under the terms of a Secondary License (if+permitted under the terms of Section 3.3).++2.5. Representation++Each Contributor represents that the Contributor believes its+Contributions are its original creation(s) or it has sufficient rights+to grant the rights to its Contributions conveyed by this License.++2.6. Fair Use++This License is not intended to limit any rights You have under+applicable copyright doctrines of fair use, fair dealing, or other+equivalents.++2.7. Conditions++Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted+in Section 2.1.++3. Responsibilities+-------------------++3.1. Distribution of Source Form++All distribution of Covered Software in Source Code Form, including any+Modifications that You create or to which You contribute, must be under+the terms of this License. You must inform recipients that the Source+Code Form of the Covered Software is governed by the terms of this+License, and how they can obtain a copy of this License. You may not+attempt to alter or restrict the recipients' rights in the Source Code+Form.++3.2. Distribution of Executable Form++If You distribute Covered Software in Executable Form then:++(a) such Covered Software must also be made available in Source Code+ Form, as described in Section 3.1, and You must inform recipients of+ the Executable Form how they can obtain a copy of such Source Code+ Form by reasonable means in a timely manner, at a charge no more+ than the cost of distribution to the recipient; and++(b) You may distribute such Executable Form under the terms of this+ License, or sublicense it under different terms, provided that the+ license for the Executable Form does not attempt to limit or alter+ the recipients' rights in the Source Code Form under this License.++3.3. Distribution of a Larger Work++You may create and distribute a Larger Work under terms of Your choice,+provided that You also comply with the requirements of this License for+the Covered Software. If the Larger Work is a combination of Covered+Software with a work governed by one or more Secondary Licenses, and the+Covered Software is not Incompatible With Secondary Licenses, this+License permits You to additionally distribute such Covered Software+under the terms of such Secondary License(s), so that the recipient of+the Larger Work may, at their option, further distribute the Covered+Software under the terms of either this License or such Secondary+License(s).++3.4. Notices++You may not remove or alter the substance of any license notices+(including copyright notices, patent notices, disclaimers of warranty,+or limitations of liability) contained within the Source Code Form of+the Covered Software, except that You may alter any license notices to+the extent required to remedy known factual inaccuracies.++3.5. Application of Additional Terms++You may choose to offer, and to charge a fee for, warranty, support,+indemnity or liability obligations to one or more recipients of Covered+Software. However, You may do so only on Your own behalf, and not on+behalf of any Contributor. You must make it absolutely clear that any+such warranty, support, indemnity, or liability obligation is offered by+You alone, and You hereby agree to indemnify every Contributor for any+liability incurred by such Contributor as a result of warranty, support,+indemnity or liability terms You offer. You may include additional+disclaimers of warranty and limitations of liability specific to any+jurisdiction.++4. Inability to Comply Due to Statute or Regulation+---------------------------------------------------++If it is impossible for You to comply with any of the terms of this+License with respect to some or all of the Covered Software due to+statute, judicial order, or regulation then You must: (a) comply with+the terms of this License to the maximum extent possible; and (b)+describe the limitations and the code they affect. Such description must+be placed in a text file included with all distributions of the Covered+Software under this License. Except to the extent prohibited by statute+or regulation, such description must be sufficiently detailed for a+recipient of ordinary skill to be able to understand it.++5. Termination+--------------++5.1. The rights granted under this License will terminate automatically+if You fail to comply with any of its terms. However, if You become+compliant, then the rights granted under this License from a particular+Contributor are reinstated (a) provisionally, unless and until such+Contributor explicitly and finally terminates Your grants, and (b) on an+ongoing basis, if such Contributor fails to notify You of the+non-compliance by some reasonable means prior to 60 days after You have+come back into compliance. Moreover, Your grants from a particular+Contributor are reinstated on an ongoing basis if such Contributor+notifies You of the non-compliance by some reasonable means, this is the+first time You have received notice of non-compliance with this License+from such Contributor, and You become compliant prior to 30 days after+Your receipt of the notice.++5.2. If You initiate litigation against any entity by asserting a patent+infringement claim (excluding declaratory judgment actions,+counter-claims, and cross-claims) alleging that a Contributor Version+directly or indirectly infringes any patent, then the rights granted to+You by any and all Contributors for the Covered Software under Section+2.1 of this License shall terminate.++5.3. In the event of termination under Sections 5.1 or 5.2 above, all+end user license agreements (excluding distributors and resellers) which+have been validly granted by You or Your distributors under this License+prior to termination shall survive termination.++************************************************************************+* *+* 6. Disclaimer of Warranty *+* ------------------------- *+* *+* Covered Software is provided under this License on an "as is" *+* basis, without warranty of any kind, either expressed, implied, or *+* statutory, including, without limitation, warranties that the *+* Covered Software is free of defects, merchantable, fit for a *+* particular purpose or non-infringing. The entire risk as to the *+* quality and performance of the Covered Software is with You. *+* Should any Covered Software prove defective in any respect, You *+* (not any Contributor) assume the cost of any necessary servicing, *+* repair, or correction. This disclaimer of warranty constitutes an *+* essential part of this License. No use of any Covered Software is *+* authorized under this License except under this disclaimer. *+* *+************************************************************************++************************************************************************+* *+* 7. Limitation of Liability *+* -------------------------- *+* *+* Under no circumstances and under no legal theory, whether tort *+* (including negligence), contract, or otherwise, shall any *+* Contributor, or anyone who distributes Covered Software as *+* permitted above, be liable to You for any direct, indirect, *+* special, incidental, or consequential damages of any character *+* including, without limitation, damages for lost profits, loss of *+* goodwill, work stoppage, computer failure or malfunction, or any *+* and all other commercial damages or losses, even if such party *+* shall have been informed of the possibility of such damages. This *+* limitation of liability shall not apply to liability for death or *+* personal injury resulting from such party's negligence to the *+* extent applicable law prohibits such limitation. Some *+* jurisdictions do not allow the exclusion or limitation of *+* incidental or consequential damages, so this exclusion and *+* limitation may not apply to You. *+* *+************************************************************************++8. Litigation+-------------++Any litigation relating to this License may be brought only in the+courts of a jurisdiction where the defendant maintains its principal+place of business and such litigation shall be governed by laws of that+jurisdiction, without reference to its conflict-of-law provisions.+Nothing in this Section shall prevent a party's ability to bring+cross-claims or counter-claims.++9. Miscellaneous+----------------++This License represents the complete agreement concerning the subject+matter hereof. If any provision of this License is held to be+unenforceable, such provision shall be reformed only to the extent+necessary to make it enforceable. Any law or regulation which provides+that the language of a contract shall be construed against the drafter+shall not be used to construe this License against a Contributor.++10. Versions of the License+---------------------------++10.1. New Versions++Mozilla Foundation is the license steward. Except as provided in Section+10.3, no one other than the license steward has the right to modify or+publish new versions of this License. Each version will be given a+distinguishing version number.++10.2. Effect of New Versions++You may distribute the Covered Software under the terms of the version+of the License under which You originally received the Covered Software,+or under the terms of any subsequent version published by the license+steward.++10.3. Modified Versions++If you create software not governed by this License, and you want to+create a new license for such software, you may create and use a+modified version of this License if you rename the license and remove+any references to the name of the license steward (except to note that+such modified license differs from this License).++10.4. Distributing Source Code Form that is Incompatible With Secondary+Licenses++If You choose to distribute Source Code Form that is Incompatible With+Secondary Licenses under the terms of this version of the License, the+notice described in Exhibit B of this License must be attached.++Exhibit A - Source Code Form License Notice+-------------------------------------------++ This Source Code Form is subject to the terms of the Mozilla Public+ License, v. 2.0. If a copy of the MPL was not distributed with this+ file, You can obtain one at https://mozilla.org/MPL/2.0/.++If it is not possible or desirable to put the notice in a particular+file, then You may include the notice in a location (such as a LICENSE+file in a relevant directory) where a recipient would be likely to look+for such a notice.++You may add additional accurate notices of copyright ownership.++Exhibit B - "Incompatible With Secondary Licenses" Notice+---------------------------------------------------------++ This Source Code Form is "Incompatible With Secondary Licenses", as+ defined by the Mozilla Public License, v. 2.0.
+ NOTICE view
@@ -0,0 +1,7 @@+NOTICE+======++Unless explicitly stated otherwise, all Source Code Forms+(recursively, including under subdirectories) contained in the directory+where this NOTICE file is located are subject to the terms of the+Mozilla Public License, v. 2.0.
+ README.md view
@@ -0,0 +1,25 @@+# classy-effects++This repository is for **CEPs** and its associated Haskell library.++CEPs (Classy-Effects Protocols) are a collection of protocols for expressing and defining effects in Haskell, aimed at the fist objective in the [Sayo Project](https://github.com/sayo-hs):++> Exploring ways to improve interoperability among the myriad Haskell effect system libraries++For more details, please refer to [CEPs/README.md](https://github.com/sayo-hs/classy-effects/blob/master/CEPs/README.md).++## Background+In Haskell, there are numerous libraries to realize an effect system. The issue here is interoperability between these libraries. For instance, the [Reader effect in `fused-effects`](https://hackage.haskell.org/package/fused-effects-1.1.2.2/docs/Control-Effect-Reader.html#t:Reader) and the [Reader effect in `polysemy`](https://hackage.haskell.org/package/polysemy-1.9.1.1/docs/Polysemy-Reader.html) have completely identical definitions. If we could extract and define effects purely as interfaces, eliminating this redundancy in effect definitions, then an effectful program could be handled by both effect system library A and effect system library B. The specific mechanisms for handling effects vary from one library to another, and unifying them isn't the goal. We're specifically looking to unify the overlapping and common definitions of effects as interfaces.++Based on this idea, CEPs (classy-effects protocols) were developed. CEPs propose a convention (protocol) for unified effect definitions in Haskell. It's expected that effects defined in accordance with CEPs will be usable across various effect systems and backends.++## Encoding of Effect+First, for the representation of effects, there is the GADTs encoding typical in Extensible Effects and the type-class encoding typical in the monad transformer approach. In principle, if the type class representing the effect is decided, GADTs can be automatically generated, and the reverse is probably also possible. There's a kind of symmetry here. However, type classes have the advantage of expressing inclusion relationships of effects naturally by specifying superclasses. From this perspective, CEPs primarily adopt type class representation for effects. Moreover, a mechanism has been implemented to derive GADTs from type classes[^1], and from GADTs and the type classes that cast them to monads ([`SendIns`](https://hackage.haskell.org/package/classy-effects-base-0.1.0.0/docs/Control-Effect-Class.html#t:SendIns), [`SendSig`](https://hackage.haskell.org/package/classy-effects-base-0.1.0.0/docs/Control-Effect-Class.html#t:SendSig)), to automatically derive instances of the effect's type class ([`classy-effects-th`](https://hackage.haskell.org/package/classy-effects-th)). This allows compliance with CEPs automatically by just writing the type class that represents the effect.++[^1]: In the future, we might also consider implementing the derivation of type classes from GADTs.++## Examples+Examples of using classy-effects combined with the Heftia effect handler backend can be found [here](https://github.com/sayo-hs/heftia/blob/master/docs/examples/01%20First-order.md).++## Your contributions are welcome!+Please see [CONTRIBUTING.md](https://github.com/sayo-hs/classy-effects/blob/master/CONTRIBUTING.md).
+ classy-effects-th.cabal view
@@ -0,0 +1,120 @@+cabal-version: 2.4+name: classy-effects-th+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis: Automatic compliance with the classy-effects protocols++-- A longer description of the package.+description:+ This package provides Template Haskell functions that enable automatic compliance with CEPs+ (classy-effects protocols), offering a unified framework for defining effects in Haskell.++ CEPs aim to standardize and unify the definition of effects in Haskell in a+ backend-library-agnostic manner. Please refer+ to [CEPs](https://github.com/sayo-hs/classy-effects/blob/master/CEPs/README.md) for details.++ Please also refer to the [classy-effects](https://hackage.haskell.org/package/classy-effects)+ package, which offers standard effect definitions compliant with CEPs.++-- A URL where users can report bugs.+bug-reports: https://github.com/sayo-hs/classy-effects++-- The license under which the package is released.+license: MPL-2.0+license-file: LICENSE+author: Yamada Ryo <ymdfield@outlook.jp>+maintainer: Yamada Ryo <ymdfield@outlook.jp>++-- A copyright notice.+copyright:+ 2023 Yamada Ryo,+ 2020 Michael Szvetits,+ 2010-2011 Patrick Bahr++category: Control, Effect, Template Haskell++extra-source-files:+ ChangeLog.md+ NOTICE+ README.md++tested-with:+ GHC == 9.2.8++source-repository head+ type: git+ location: https://github.com/sayo-hs/classy-effects+ tag: v0.1.0+ subdir: classy-effects-th++library+ exposed-modules:+ Control.Effect.Class.Machinery.TH+ Control.Effect.Class.Machinery.TH.Internal+ Control.Effect.Class.Machinery.TH.Send+ Control.Effect.Class.Machinery.TH.Send.Internal+ Data.Effect.Class.TH+ Data.Effect.Class.TH.Internal+ Data.Effect.Class.TH.HFunctor+ Data.Effect.Class.TH.HFunctor.Internal++ -- Modules included in this executable, other than Main.+ -- other-modules:++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:+ build-depends:+ base ^>= 4.16.4.0,+ classy-effects-base ^>= 0.1,+ template-haskell ^>= 2.18,+ th-abstraction ^>= 0.5,+ lens ^>= 5.2.3,+ mtl ^>= 2.2.2,+ extra ^>= 1.7.14++ hs-source-dirs: src+ ghc-options: -Wall+ default-language: GHC2021++ default-extensions:+ LambdaCase,+ DerivingStrategies,+ DataKinds,+ TypeFamilies,+ BlockArguments,+ FunctionalDependencies,+ RecordWildCards,+ DefaultSignatures+++test-suite Example+ other-modules:+ DeriveHFunctor++ main-is: Driver.hs+ hs-source-dirs: Example+ build-depends:+ classy-effects-th,+ base,+ classy-effects-base,+ tasty ^>= 1.4,+ tasty-hunit ^>= 0.10,++ type: exitcode-stdio-1.0++ build-tool-depends:+ tasty-discover:tasty-discover++ default-language: GHC2021+ ghc-options: -Wall++ default-extensions:+ LambdaCase,+ DerivingStrategies,+ DataKinds,+ TypeFamilies,+ BlockArguments,+ FunctionalDependencies,+ RecordWildCards,+ DefaultSignatures
+ src/Control/Effect/Class/Machinery/TH.hs view
@@ -0,0 +1,153 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at https://mozilla.org/MPL/2.0/.++{- |+Copyright : (c) 2023 Yamada Ryo+License : MPL-2.0 (see the file LICENSE)+Maintainer : ymdfield@outlook.jp+Stability : experimental+Portability : portable++This module provides @TemplateHaskell@ functions to generates automatically various data types and+instances that constitute the effect system supplied by the @classy-effects@ framework.+-}+module Control.Effect.Class.Machinery.TH where++import Control.Effect.Class.Machinery.TH.Internal (+ defaultEffDataNamer,+ generateEffect,+ generateEffectWith,+ generateOrderUnifiedEffDataTySyn,+ generateOrderUnifiedEffectClass,+ unifyEffTypeParams,+ )+import Control.Effect.Class.Machinery.TH.Send (deriveEffectSend)+import Control.Monad (unless, (<=<))+import Control.Monad.Writer (execWriterT, lift, tell)+import Data.Effect.Class.TH.Internal (+ EffectOrder (FirstOrder, HigherOrder),+ effMethods,+ reifyEffectInfo,+ )+import Data.Function ((&))+import Language.Haskell.TH (Dec, Name, Q, mkName, nameBase)++{- |+In addition to 'makeEffectF' and 'makeEffectH',+generate the order-unified empty effect class:++ @class (FoobarF ... f, FoobarH ... f) => Foobar ... f@++, and generate the order-unified effect data type synonym:++ @type Foobar ... = FoobarS ... :+: LiftIns (FoobarI ...)@+-}+makeEffect ::+ -- | A name of order-unified empty effect class generated newly+ String ->+ -- | The name of first-order effect class+ Name ->+ -- | The name of higher-order effect class+ Name ->+ Q [Dec]+makeEffect clsU clsF clsH = do+ makeEffectWith+ clsU+ (clsU <> "D")+ clsF+ (defaultEffDataNamer FirstOrder clsF)+ clsH+ (defaultEffDataNamer HigherOrder clsH)++{- |+Generate an /instruction/ data type and type and pattern synonyms for abbreviating+'Control.Effect.Class.LiftIns'.+-}+makeEffectF :: Name -> Q [Dec]+makeEffectF = generateEffect FirstOrder <=< reifyEffectInfo++-- | Generate a /signature/ data type and a 'Data.Comp.Multi.HFunctor.HFunctor' instance.+makeEffectH :: Name -> Q [Dec]+makeEffectH = generateEffect HigherOrder <=< reifyEffectInfo++{- |+In addition to 'makeEffectF' and 'makeEffectH',+generate the order-unified empty effect class:++ @class (FoobarF ... f, FoobarH ... f) => Foobar ... f@++, and generate the order-unified effect data type synonym:++ @type Foobar ... = FoobarS ... :+: LiftIns (FoobarI ...)@+-}+makeEffectWith ::+ -- | A name of order-unified empty effect class generated newly+ String ->+ -- | A name of type synonym of order-unified effect data type generated newly+ String ->+ -- | The name of first-order effect class+ Name ->+ -- | The name of instruction data type corresponding to the first-order effect class+ Name ->+ -- | The name of higher-order effect class+ Name ->+ -- | The name of signature data type corresponding to the higher-order effect class+ Name ->+ Q [Dec]+makeEffectWith clsU dataU clsF dataI clsH dataS =+ execWriterT do+ infoF <- reifyEffectInfo clsF & lift+ infoH <- reifyEffectInfo clsH & lift++ pvs <- unifyEffTypeParams infoF infoH & lift++ generateEffectWith FirstOrder dataI infoF & lift >>= tell+ generateEffectWith HigherOrder dataS infoH & lift >>= tell++ generateOrderUnifiedEffectClass infoF infoH pvs (mkName clsU) & lift >>= tell++ [generateOrderUnifiedEffDataTySyn dataI dataS pvs (mkName dataU)]+ & lift . sequence+ >>= tell++ pure ()++{- |+Generate an /instruction/ data type and type and pattern synonyms for abbreviating+'Control.Effect.Class.LiftIns'.+-}+makeEffectFWith :: String -> Name -> Q [Dec]+makeEffectFWith dataI = generateEffectWith FirstOrder (mkName dataI) <=< reifyEffectInfo++-- | Generate a /signature/ data type and a 'Data.Comp.Multi.HFunctor.HFunctor' instance.+makeEffectHWith :: String -> Name -> Q [Dec]+makeEffectHWith dataS = generateEffectWith HigherOrder (mkName dataS) <=< reifyEffectInfo++{- |+Derive an instance of the effect, with no methods, that handles via 'Control.Effect.Class.SendIns'/+'Control.Effect.Class.SendSig' instances.+-}+makeEmptyEffect :: Name -> Q [Dec]+makeEmptyEffect effClsName = do+ info <- reifyEffectInfo effClsName++ unless (null $ effMethods info) $+ fail ("The effect class \'" <> nameBase effClsName <> "\' is not empty.")++ sequence [deriveEffectSend info Nothing]++{- |+Generate the order-unified empty effect class:++ @class (FoobarF ... f, FoobarH ... f) => Foobar ... f@++, and derive an instance of the effect that handles via 'Control.Effect.Class.SendIns'/+'Control.Effect.Class.SendSig' instances.+-}+makeOrderUnifiedEffectClass :: Name -> Name -> String -> Q [Dec]+makeOrderUnifiedEffectClass clsF clsH clsU = do+ infoF <- reifyEffectInfo clsF+ infoH <- reifyEffectInfo clsH+ pvs <- unifyEffTypeParams infoF infoH+ generateOrderUnifiedEffectClass infoF infoH pvs (mkName clsU)
+ src/Control/Effect/Class/Machinery/TH/Internal.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE TemplateHaskell #-}++-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at https://mozilla.org/MPL/2.0/.++module Control.Effect.Class.Machinery.TH.Internal where++import Control.Effect.Class (LiftIns)+import Control.Effect.Class.Machinery.HFunctor ((:+:))+import Control.Effect.Class.Machinery.TH.Send (deriveEffectSend)+import Control.Monad (when)+import Control.Monad.Writer (execWriterT, lift, tell)+import Data.Effect.Class.TH.HFunctor.Internal (deriveHFunctor, tyVarName)+import Data.Effect.Class.TH.Internal (+ EffectInfo (EffectInfo, effName, effParamVars),+ EffectOrder (FirstOrder, HigherOrder),+ applyEffPVs,+ defaultEffectDataNamer,+ generateEffectDataByEffInfo,+ generateLiftInsPatternSynonyms,+ generateLiftInsTypeSynonym,+ )+import Data.Function ((&))+import Data.Functor ((<&>))+import Data.Kind qualified as K+import Language.Haskell.TH (+ Dec,+ Name,+ Q,+ TyVarBndr (PlainTV),+ appT,+ classD,+ kindedTV,+ mkName,+ nameBase,+ tySynD,+ varT,+ )++generateEffect :: EffectOrder -> EffectInfo -> Q [Dec]+generateEffect order info =+ generateEffectWith+ order+ (mkName $ defaultEffectDataNamer order $ nameBase $ effName info)+ info++defaultEffDataNamer :: EffectOrder -> Name -> Name+defaultEffDataNamer order = mkName . defaultEffectDataNamer order . nameBase++generateEffectWith :: EffectOrder -> Name -> EffectInfo -> Q [Dec]+generateEffectWith order effDataName info =+ execWriterT do+ (effDataInfo, effData) <- generateEffectDataByEffInfo order effDataName info & lift+ tell [effData]++ case order of+ FirstOrder -> do+ generateLiftInsPatternSynonyms effDataName info & lift >>= tell+ [generateLiftInsTypeSynonym info effDataName] & lift . sequence >>= tell+ HigherOrder ->+ deriveHFunctor effDataInfo & lift >>= tell++ [deriveEffectSend info $ Just (order, effDataName)] & lift . sequence >>= tell++ pure info++{- |+Generate the order-unified empty effect class:++ @class (FoobarF ... f, FoobarH ... f) => Foobar ... f@++, and derive an instance of the effect that handles via 'Control.Effect.Class.SendIns'/+'Control.Effect.Class.SendSig' instances.+-}+generateOrderUnifiedEffectClass :: EffectInfo -> EffectInfo -> [Name] -> Name -> Q [Dec]+generateOrderUnifiedEffectClass infoF infoH pvs unifiedClsName = do+ fKind <- [t|K.Type -> K.Type|]+ let f = mkName "f"+ fKinded = f `kindedTV` fKind++ cxt <-+ sequence+ [ applyEffPVs (effName infoF) pvs `appT` varT f+ , applyEffPVs (effName infoH) pvs `appT` varT f+ ]+ let pvs' = pvs <&> (`PlainTV` ())++ sequence+ [ classD+ (pure cxt)+ unifiedClsName+ (pvs' ++ [fKinded])+ []+ []+ , deriveEffectSend+ ( EffectInfo+ cxt+ unifiedClsName+ pvs'+ fKinded+ []+ )+ Nothing+ ]++{- |+Generate the order-unified effect data type synonym:++ @type Foobar ... = FoobarS ... :+: LiftIns (FoobarI ...)@+-}+generateOrderUnifiedEffDataTySyn :: Name -> Name -> [Name] -> Name -> Q Dec+generateOrderUnifiedEffDataTySyn dataI dataS pvs tySynName = do+ tySynD+ tySynName+ ((`PlainTV` ()) <$> pvs)+ [t|$(applyEffPVs dataS pvs) :+: LiftIns $(applyEffPVs dataI pvs)|]++unifyEffTypeParams :: EffectInfo -> EffectInfo -> Q [Name]+unifyEffTypeParams infoF infoH = do+ let pvF = nameBase . tyVarName <$> effParamVars infoF+ pvH = nameBase . tyVarName <$> effParamVars infoH++ when (pvF /= pvH) $+ fail $+ "The type parameter lists for the first and higher-order effect classes do not match:\n"+ <> (nameBase (effName infoF) <> ": " <> show pvF <> "\n")+ <> (nameBase (effName infoH) <> ": " <> show pvH <> "\n")++ pure $ mkName <$> pvH
+ src/Control/Effect/Class/Machinery/TH/Send.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE TemplateHaskell #-}++-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at https://mozilla.org/MPL/2.0/.++{- |+Copyright : (c) 2023 Yamada Ryo+License : MPL-2.0 (see the file LICENSE)+Maintainer : ymdfield@outlook.jp+Stability : experimental+Portability : portable++This module provides @TemplateHaskell@ functions to derive an instance of the effect that handles+via 'SendIns'/'SendSig' type classes.+-}+module Control.Effect.Class.Machinery.TH.Send where++import Control.Effect.Class (EffectDataHandler, EffectsVia, SendIns, SendSig)+import Control.Effect.Class.Machinery.TH.Send.Internal (effectMethodDec)+import Control.Exception (assert)+import Control.Monad (forM)+import Data.Effect.Class.TH.HFunctor.Internal (tyVarName)+import Data.Effect.Class.TH.Internal (+ EffectInfo,+ EffectOrder (FirstOrder, HigherOrder),+ MethodInterface (MethodInterface, methodName),+ effMethods,+ effMonad,+ effName,+ effParamVars,+ effectParamCxt,+ reifyEffectInfo,+ renameMethodToCon,+ superEffects,+ tyVarType,+ unkindTyVar,+ )+import Data.Maybe (maybeToList)+import Language.Haskell.TH (+ Dec (InstanceD),+ Name,+ Q,+ Type (ConT),+ appT,+ conT,+ varT,+ )++-- | Derive an instance of the effect that handles via 'SendIns'/'SendSig' type classes.+makeEffectSend ::+ -- | The class name of the effect.+ Name ->+ -- | The name and order of effect data type corresponding to the effect.+ Maybe (EffectOrder, Name) ->+ Q [Dec]+makeEffectSend effClsName effDataNameAndOrder = do+ info <- reifyEffectInfo effClsName+ sequence [deriveEffectSend info effDataNameAndOrder]++{- |+Derive an instance of the effect that handles via 'SendIns'/'SendSig' type classes, from+'EffectInfo'.+-}+deriveEffectSend ::+ -- | The reified information of the effect class.+ EffectInfo ->+ -- | The name and order of effect data type corresponding to the effect.+ Maybe (EffectOrder, Name) ->+ Q Dec+deriveEffectSend info effDataNameAndOrder = do+ let f = varT $ tyVarName $ effMonad info++ pvs = effParamVars info+ paramTypes = fmap (tyVarType . unkindTyVar) pvs++ carrier = [t|EffectsVia EffectDataHandler $f|]++ methods =+ [ (sig, renameMethodToCon methodName)+ | sig@MethodInterface{methodName} <- effMethods info+ ]++ sendCxt <-+ maybeToList+ <$> forM effDataNameAndOrder \(order, effDataName) ->+ assert (not $ null methods) do+ let sendCls =+ conT case order of+ FirstOrder -> ''SendIns+ HigherOrder -> ''SendSig++ effData = foldl appT (conT effDataName) paramTypes++ [t|$sendCls $effData $f|]++ let effParamCxt = effectParamCxt info++ superEffCxt <- forM (superEffects info) ((`appT` carrier) . pure)++ effDataC <- do+ let eff = pure $ ConT $ effName info+ [t|$(foldl appT eff paramTypes) $carrier|]++ decs <- mapM (uncurry $ effectMethodDec $ tyVarName <$> pvs) methods++ return $ InstanceD Nothing (sendCxt ++ superEffCxt ++ effParamCxt) effDataC (concat decs)
+ src/Control/Effect/Class/Machinery/TH/Send/Internal.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE TemplateHaskell #-}++-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at https://mozilla.org/MPL/2.0/.++module Control.Effect.Class.Machinery.TH.Send.Internal where++import Control.Effect.Class (+ EffectDataHandler,+ EffectsVia (EffectsVia),+ runEffectsVia,+ sendIns,+ sendSig,+ )+import Control.Effect.Class.Machinery.HFunctor (hfmap)+import Control.Monad (replicateM)+import Data.Effect.Class.TH.Internal (+ EffectOrder (FirstOrder, HigherOrder),+ MethodInterface (MethodInterface, methodName),+ methodOrder,+ methodParamTypes,+ methodReturnType,+ )+import Language.Haskell.TH (+ Dec,+ Inline (Inline),+ Name,+ Phases (AllPhases),+ Q,+ RuleMatch (FunLike),+ appE,+ appTypeE,+ clause,+ conE,+ funD,+ newName,+ normalB,+ pragInlD,+ varE,+ varP,+ varT,+ )++{- |+Generate a method implementation of the effect that handles via 'Control.Effect.Class.SendIns'/+'Control.Effect.Class.SendSig' type classes.+-}+effectMethodDec ::+ -- | The type parameters of the effect.+ [Name] ->+ -- | The interface of the effect method.+ MethodInterface ->+ -- | The name of effect data constructor corresponding to the method.+ Name ->+ Q [Dec]+effectMethodDec effTyVars MethodInterface{..} conName = do+ methodParams <- replicateM (length methodParamTypes) (newName "x")++ let con = foldl appTypeE (conE conName) (varT <$> effTyVars)++ effData = foldl appE con (varE <$> methodParams)++ sendMethod = case methodOrder of+ FirstOrder -> [|sendIns|]+ HigherOrder -> [|sendSig . hfmap runEffectsVia|]+ body = [|EffectsVia @EffectDataHandler $ $sendMethod $effData|]++ funDef <- funD methodName [clause (fmap varP methodParams) (normalB body) []]+ funInline <- pragInlD methodName Inline FunLike AllPhases++ return [funDef, funInline]
+ src/Data/Effect/Class/TH.hs view
@@ -0,0 +1,75 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at https://mozilla.org/MPL/2.0/.++{- |+Copyright : (c) 2023 Yamada Ryo+ (c) 2020 Michael Szvetits+License : MPL-2.0 (see the file LICENSE)+Maintainer : ymdfield@outlook.jp+Stability : experimental+Portability : portable++This module provides @TemplateHaskell@ functions to generate the effect data types+(/instruction/s and /signature/s) for effect type classes.+-}+module Data.Effect.Class.TH where++import Control.Monad ((<=<))+import Data.Effect.Class.TH.Internal (+ EffectOrder (FirstOrder, HigherOrder),+ defaultEffectDataNamer,+ generateEffectDataByEffInfo,+ generateLiftInsPatternSynonyms,+ reifyEffectInfo,+ )+import Data.List qualified as L+import Language.Haskell.TH (mkName)+import Language.Haskell.TH.Syntax (Dec, Name, Q, nameBase)++-- | Generate /instruction/ and /signature/ data types from the effect class of the given name.+makeEffectDataWith ::+ -- | An effect order of an effect data type to generate.+ EffectOrder ->+ -- | A name of an effect data type to generate.+ String ->+ -- | The name of the effect class.+ Name ->+ Q [Dec]+makeEffectDataWith order effDataName effClsName =+ fmap (L.singleton . snd)+ . generateEffectDataByEffInfo order (mkName effDataName)+ =<< reifyEffectInfo effClsName++-- | Generate only an /instruction/ data type from the effect class of the given name.+makeInstructionWith :: String -> Name -> Q [Dec]+makeInstructionWith = makeEffectDataWith FirstOrder++-- | Generate only a /signature/ data type from the effect class of the given name.+makeSignatureWith :: String -> Name -> Q [Dec]+makeSignatureWith = makeEffectDataWith HigherOrder++-- | Generate /instruction/ and /signature/ data types from the effect class of the given name.+makeEffectData :: EffectOrder -> Name -> Q [Dec]+makeEffectData order effClsName =+ makeEffectDataWith+ order+ (defaultEffectDataNamer order $ nameBase effClsName)+ effClsName++-- | Generate only an /instruction/ data type from the effect class of the given name.+makeInstruction :: Name -> Q [Dec]+makeInstruction = makeEffectData FirstOrder++-- | Generate only a /signature/ data type from the effect class of the given name.+makeSignature :: Name -> Q [Dec]+makeSignature = makeEffectData HigherOrder++{- |+Generate the pattern synonyms for instruction constructors:+@+ pattern Foobar x y = LiftIns (FoobarI x y)+@ .+-}+makeLiftInsPatternSynonyms :: Name -> Name -> Q [Dec]+makeLiftInsPatternSynonyms dataName = generateLiftInsPatternSynonyms dataName <=< reifyEffectInfo
+ src/Data/Effect/Class/TH/HFunctor.hs view
@@ -0,0 +1,30 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at https://mozilla.org/MPL/2.0/.++{- |+Copyright : (c) 2023 Yamada Ryo+ (c) 2010-2011 Patrick Bahr+License : MPL-2.0 (see the file LICENSE)+Maintainer : ymdfield@outlook.jp+Stability : experimental+Portability : portable++This module provides @TemplateHaskell@ functions to derive an instance of+'Data.Comp.Multi.HFunctor.HFunctor'.++The definitions come from "Data.Comp.Multi.Derive" in the compdata-0.13.0 package.+-}+module Data.Effect.Class.TH.HFunctor where++import Data.Effect.Class.TH.HFunctor.Internal (abstractNewtype, deriveHFunctor)+import Language.Haskell.TH (Dec, Name, Q, reify)++{- |+Derive an instance of 'Data.Comp.Multi.HFunctor.HFunctor' for a type constructor of any higher-order+kind taking at least two arguments.+-}+makeHFunctor :: Name -> Q [Dec]+makeHFunctor fname = do+ Just dInfo <- abstractNewtype <$> reify fname+ deriveHFunctor dInfo
+ src/Data/Effect/Class/TH/HFunctor/Internal.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE TemplateHaskellQuotes #-}++-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at https://mozilla.org/MPL/2.0/.++{-+The code before modification is BSD3 licensed, (c) 2010-2011 Patrick Bahr.+<https://github.com/pa-ba/compdata/blob/master/src/Data/Comp/Multi/Derive/HFunctor.hs>++This fork was made to work around the problem that the+'Control.Effect.Class.Machinery.TH.makeEffect' function that generates multiple+definitions at once for convenience is not possible with only the original+'Data.Comp.Multi.Derive.makeHFunctor' function due to TH limitations,+because the original function takes the name of the data type as an argument,+but there is no version that takes 'DataInfo' as an argument (the data type+reification and the HFunctor derivation process are not separated as functions).+-}++{- |+Copyright : (c) 2010-2011 Patrick Bahr+ (c) 2023 Yamada Ryo+License : MPL-2.0 (see the file LICENSE)+Maintainer : ymdfield@outlook.jp+Stability : experimental+Portability : portable+-}+module Data.Effect.Class.TH.HFunctor.Internal where++import Control.Effect.Class.Machinery.HFunctor (HFunctor, hfmap)+import Control.Monad (replicateM, (<=<))+import Data.Maybe (catMaybes)+import Language.Haskell.TH (+ Body (NormalB),+ Clause (Clause),+ Con (ForallC, GadtC, InfixC, NormalC, RecC),+ Cxt,+ Dec (DataD, InstanceD, NewtypeD),+ DerivClause,+ Exp,+ Info (TyConI),+ Name,+ Pat (ConP, VarP, WildP),+ Q,+ Quote (..),+ TyVarBndr (..),+ Type (AppT, ConT, ForallT, SigT, VarT),+ appE,+ conE,+ funD,+ varE,+ )+import Language.Haskell.TH.Syntax (StrictType)++{- |+Derive an instance of 'HFunctor' for a type constructor of any higher-order kind taking at least two+arguments, from 'DataInfo'.+-}+deriveHFunctor :: DataInfo flag -> Q [Dec]+deriveHFunctor (DataInfo _cxt name args constrs _deriving) = do+ let args' = init args+ fArg = VarT . tyVarName $ last args'+ argNames = map (VarT . tyVarName) (init args')+ complType = foldl AppT (ConT name) argNames+ classType = AppT (ConT ''HFunctor) complType+ constrs' <- mapM (mkPatAndVars . isFarg fArg <=< normalConExp) constrs+ hfmapDecl <- funD 'hfmap (map hfmapClause constrs')+ return [mkInstanceD [] classType [hfmapDecl]]+ where+ isFarg fArg (constr, args_, ty) = (constr, map (`containsType'` getBinaryFArg fArg ty) args_)+ filterVar _ nonFarg [] x = nonFarg x+ filterVar farg _ [depth] x = farg depth x+ filterVar _ _ _ _ = error "functor variable occurring twice in argument type"+ filterVars args_ varNs farg nonFarg = zipWith (filterVar farg nonFarg) args_ varNs+ mkCPat constr varNs = ConP constr [] $ map mkPat varNs+ mkPat = VarP+ mkPatAndVars ::+ (Name, [[t]]) ->+ Q (Q Exp, Pat, (t -> Q Exp -> c) -> (Q Exp -> c) -> [c], Bool, [Q Exp], [(t, Name)])+ mkPatAndVars (constr, args_) =+ do+ varNs <- newNames (length args_) "x"+ return+ ( conE constr+ , mkCPat constr varNs+ , \f g -> filterVars args_ varNs (\d x -> f d (varE x)) (g . varE)+ , not (all null args_)+ , map varE varNs+ , catMaybes $ filterVars args_ varNs (curry Just) (const Nothing)+ )+ hfmapClause (con, pat, vars', hasFargs, _, _) =+ do+ fn <- newName "f"+ let f = varE fn+ fp = if hasFargs then VarP fn else WildP+ vars = vars' (\d x -> iter d [|fmap|] f `appE` x) id+ body <- foldl appE con vars+ return $ Clause [fp, pat] (NormalB body) []++-- | A reified information of a datatype.+data DataInfo flag = DataInfo+ { dataCxt :: Cxt+ , dataName :: Name+ , dataTyVars :: [TyVarBndr flag]+ , dataCons :: [Con]+ , dataDerivings :: [DerivClause]+ }++{- |+This function abstracts away @newtype@ declaration, it turns them into+@data@ declarations.+-}+abstractNewtype :: Info -> Maybe (DataInfo ())+abstractNewtype = \case+ TyConI (NewtypeD cxt name args _ constr derive) -> Just (DataInfo cxt name args [constr] derive)+ TyConI (DataD cxt name args _ constrs derive) -> Just (DataInfo cxt name args constrs derive)+ _ -> Nothing++-- | Convert the reified information of the datatype to a definition.+infoToDataD :: DataInfo () -> Dec+infoToDataD (DataInfo cxt name args cons deriv) = DataD cxt name args Nothing cons deriv++{- |+This function provides the name and the arity of the given data+constructor, and if it is a GADT also its type.+-}+normalCon :: Con -> (Name, [StrictType], Maybe Type)+normalCon (NormalC constr args) = (constr, args, Nothing)+normalCon (RecC constr args) = (constr, map (\(_, s, t) -> (s, t)) args, Nothing)+normalCon (InfixC a constr b) = (constr, [a, b], Nothing)+normalCon (ForallC _ _ constr) = normalCon constr+normalCon (GadtC (constr : _) args typ) = (constr, args, Just typ)+normalCon _ = error "missing case for 'normalCon'"++normalConExp :: Con -> Q (Name, [Type], Maybe Type)+normalConExp con = pure (n, map snd ts, t)+ where+ (n, ts, t) = normalCon con++containsType' :: Type -> Type -> [Int]+containsType' = run 0+ where+ run n s t+ | s == t = [n]+ | otherwise = case s of+ ForallT _ _ s' -> run n s' t+ -- only going through the right-hand side counts!+ AppT s1 s2 -> run n s1 t ++ run (n + 1) s2 t+ SigT s' _ -> run n s' t+ _ -> []++{- |+Auxiliary function to extract the first argument of a binary type+application (the second argument of this function). If the second+argument is @Nothing@ or not of the right shape, the first argument+is returned as a default.+-}+getBinaryFArg :: Type -> Maybe Type -> Type+getBinaryFArg _ (Just (AppT (AppT _ t) _)) = t+getBinaryFArg def _ = def++mkInstanceD :: Cxt -> Type -> [Dec] -> Dec+mkInstanceD = InstanceD Nothing++{- |+This function provides a list (of the given length) of new names based+on the given string.+-}+newNames :: Int -> String -> Q [Name]+newNames n name = replicateM n (newName name)++iter :: (Eq t, Num t, Quote m) => t -> m Exp -> m Exp -> m Exp+iter 0 _ e = e+iter n f e = iter (n - 1) f (f `appE` e)++-- | pures the name of a type variable.+tyVarName :: TyVarBndr a -> Name+tyVarName (PlainTV n _) = n+tyVarName (KindedTV n _ _) = n
+ src/Data/Effect/Class/TH/Internal.hs view
@@ -0,0 +1,458 @@+{-# LANGUAGE TemplateHaskellQuotes #-}++-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at https://mozilla.org/MPL/2.0/.++-- The code before modification is BSD3 licensed, (c) 2020 Michael Szvetits.+-- <https://github.com/typedbyte/effet/blob/master/src/Control/Effect/Machinery/TH.hs>++{- |+Copyright : (c) 2020 Michael Szvetits+ (c) 2023 Yamada Ryo+License : MPL-2.0 (see the file LICENSE)+Maintainer : ymdfield@outlook.jp+Stability : experimental+Portability : portable+-}+module Data.Effect.Class.TH.Internal where++import Control.Monad (forM, replicateM, unless, when)+import Control.Monad.IO.Class (MonadIO)+import Data.List (intercalate, nub)+import Language.Haskell.TH.Lib (+ appT,+ conT,+ patSynSigD,+ sigT,+ varT,+ )+import Language.Haskell.TH.Syntax (+ Con,+ Cxt,+ Dec (ClassD, SigD),+ Info (ClassI),+ Kind,+ Name,+ Q,+ Quote (newName),+ TyVarBndr (KindedTV, PlainTV),+ Type (+ AppKindT,+ AppT,+ ArrowT,+ ConT,+ ForallT,+ ImplicitParamT,+ InfixT,+ ParensT,+ PromotedT,+ SigT,+ StarT,+ UInfixT,+ VarT+ ),+ nameBase,+ reify,+ )++import Control.Effect.Class (LiftIns (LiftIns))+import Control.Lens ((%~), (^?), _head, _last)+import Control.Monad.Writer (Any (Any), runWriterT, tell)+import Data.Bool (bool)+import Data.Char (toUpper)+import Data.Effect.Class.TH.HFunctor.Internal (DataInfo (DataInfo), infoToDataD, tyVarName)+import Data.Either (partitionEithers)+import Data.Function ((&))+import Data.Functor ((<&>))+import Data.List.Extra (dropEnd)+import Data.Maybe (isNothing, mapMaybe)+import Language.Haskell.TH (+ Bang (Bang),+ Con (ForallC, GadtC),+ SourceStrictness (NoSourceStrictness),+ SourceUnpackedness (NoSourceUnpackedness),+ Specificity (SpecifiedSpec),+ arrowT,+ conP,+ implBidir,+ mkName,+ patSynD,+ pragCompleteD,+ prefixPatSyn,+ tySynD,+ varP,+ )+import Language.Haskell.TH.Datatype (freeVariables)++-- | Generate /instruction/ and /signature/ data types from an effect class, from 'EffectInfo'.+generateEffectDataByEffInfo ::+ -- | An effect order of an effect data type to generate.+ EffectOrder ->+ -- | A name of an effect data type to generate.+ Name ->+ EffectInfo ->+ Q (DataInfo (), Dec)+generateEffectDataByEffInfo order effDataName info = do+ effDataInfo <- do+ let pvs = effParamVars info++ additionalTypeParams <- do+ a <- do+ a <- newName "a"+ pure $ KindedTV a () StarT++ pure case order of+ FirstOrder -> [a]+ HigherOrder -> [unkindTyVar $ effMonad info, a]++ cons <- do+ (errorMethods, cons) <- do+ consWithMethodInfo <- do+ effData <- do+ let paramTypes = fmap (tyVarType . unkindTyVar) pvs+ foldl appT (conT effDataName) paramTypes++ forM (effMethods info) \method ->+ (methodName method,)+ <$> interfaceToCon info effData method++ pure . partitionEithers $+ consWithMethodInfo <&> \(methodName, (methodOrder, con)) ->+ if methodOrder == order+ then Right con+ else Left (methodOrder, nameBase methodName)++ unless (null errorMethods) $+ fail $+ "Unexpected order of effect methods: "+ <> intercalate+ ", "+ ( errorMethods <&> \(methodOrder, name) ->+ name <> " [" <> [fst $ effectOrderSymbol methodOrder] <> "]"+ )++ pure cons++ pure $ DataInfo [] effDataName (pvs ++ additionalTypeParams) cons []++ pure (effDataInfo, infoToDataD effDataInfo)++-- | Convert an effect method interface to a constructor of the effect data type.+interfaceToCon ::+ EffectInfo ->+ Type ->+ MethodInterface ->+ Q (EffectOrder, Con)+interfaceToCon info effData MethodInterface{..} =+ (methodOrder,) <$> do+ effDataFunctor <- case methodOrder of+ FirstOrder -> pure effData+ HigherOrder -> pure effData `appT` (unkindType <$> tyVarType (effMonad info))++ let vars =+ foldl+ (\acc t -> nub $ acc ++ freeVariables t)+ (tyVarName <$> effParamVars info)+ (methodParamTypes ++ [methodReturnType])++ pure $+ ForallC ((`PlainTV` SpecifiedSpec) <$> vars) methodCxt $+ GadtC+ [renameMethodToCon methodName]+ (methodParamTypes & map (Bang NoSourceUnpackedness NoSourceStrictness,))+ (AppT effDataFunctor methodReturnType)++{- |+Decompose an effect method interface type to get the effect order, the list of argument types, and+the return type.+-}+analyzeMethodInterface :: TyVarBndr () -> Type -> Q (EffectOrder, [Type], Type, Cxt)+analyzeMethodInterface m interface = do+ ((resultType, cxt, paramTypes), Any isHigherOrderMethod) <- runWriterT $ go interface+ pure (bool FirstOrder HigherOrder isHigherOrderMethod, paramTypes, resultType, cxt)+ where+ go = \case+ ArrowT `AppT` l `AppT` r -> do+ when (tyVarName m `occurs` l) $ tell $ Any True+ fmap (l :) <$> go r+ ForallT _ cxt u -> do+ (r, c, p) <- go u+ return (r, cxt ++ c, p)+ VarT n `AppT` a | n == tyVarName m -> pure (a, [], [])+ other -> fail $ "Expected a pure type of the form 'm a', but encountered: " ++ show other++-- | Convert a lower-camel-cased method name to an upper-camel-cased constructor name.+renameMethodToCon :: Name -> Name+renameMethodToCon = mkName . (_head %~ toUpper) . nameBase++-- | An order of effect.+data EffectOrder = FirstOrder | HigherOrder+ deriving (Show, Eq, Ord)++-- | Is the order of effect higher-order?+isHigherOrder :: EffectOrder -> Bool+isHigherOrder = \case+ FirstOrder -> False+ HigherOrder -> True++{- |+The default naming convention of effect data types.++Add an @I@ or @S@ symbol indicating the order of the effect to the end of the effect class name.++If the name of the effect class ends in @F@ or @H@, depending on its order, replace @F@ or @H@ with+@I@ or @S@.+-}+defaultEffectDataNamer :: EffectOrder -> String -> String+defaultEffectDataNamer order clsName =+ effNameBase ++ [dataOrderSym]+ where+ (clsOrderSym, dataOrderSym) = effectOrderSymbol order+ effNameBase =+ if clsName ^? _last == Just clsOrderSym+ then dropEnd 1 clsName+ else clsName++-- | Symbol letters representing the order of the effect.+effectOrderSymbol :: EffectOrder -> (Char, Char)+effectOrderSymbol = \case+ FirstOrder -> ('F', 'I')+ HigherOrder -> ('H', 'S')++-- ** Generating Synonyms about LiftIns++{- |+Generate the pattern synonyms for instruction constructors:++ @pattern BazS ... = LiftIns (Baz ...)@+-}+generateLiftInsPatternSynonyms :: Name -> EffectInfo -> Q [Dec]+generateLiftInsPatternSynonyms dataName info = do+ patSyns <-+ forM (effMethods info) \MethodInterface{..} -> do+ let conName = renameMethodToCon methodName+ newConName = mkName $ nameBase conName ++ "S"+ args <- replicateM (length methodParamTypes) (newName "x")+ a <- varT . mkName . show <$> newName "a"+ (newConName,)+ <$> sequence+ [ patSynSigD+ newConName+ -- For some reason, if I don't write constraints in this form, the type is+ -- not inferred properly (why?).+ [t|+ () =>+ ($a ~ $(pure methodReturnType)) =>+ $( foldr+ (\l r -> arrowT `appT` pure l `appT` r)+ [t|+ $(liftInsType dataName $ tyVarName <$> effParamVars info)+ $(varT $ tyVarName $ effMonad info)+ $a+ |]+ methodParamTypes+ )+ |]+ , patSynD+ newConName+ (prefixPatSyn args)+ implBidir+ (conP 'LiftIns [conP conName $ varP <$> args])+ ]++ (concatMap snd patSyns ++)+ <$> sequence [pragCompleteD (fst <$> patSyns) Nothing]++{- |+Generate the type synonym for an instruction datatype:++ @type (FoobarS ...) = LiftIns (FoobarI ...)@+-}+generateLiftInsTypeSynonym :: EffectInfo -> Name -> Q Dec+generateLiftInsTypeSynonym info dataName = do+ nameS <- mkName <$> renameI2S (nameBase dataName)+ tySynD+ nameS+ (pvs <&> (`PlainTV` ()))+ (liftInsType dataName pvs)+ where+ pvs = tyVarName <$> effParamVars info++renameI2S :: String -> Q String+renameI2S name = dropEndI name <&> (++ "S")++dropEndI :: String -> Q String+dropEndI name =+ if name ^? _last == Just 'I'+ then pure $ dropEnd 1 name+ else fail $ "The name doesn't end in 'I': \"" <> name <> "\"."++liftInsType :: Name -> [Name] -> Q Type+liftInsType dataName pvs =+ conT ''LiftIns `appT` foldl appT (conT dataName) (varT <$> pvs)++applyEffPVs :: Name -> [Name] -> Q Type+applyEffPVs effClsName = foldl appT (conT effClsName) . fmap varT++-- ** Reification of Effect Class++-- | Information about effect type classes.+data EffectInfo = EffectInfo+ { effCxts :: [Type]+ , effName :: Name+ , effParamVars :: [TyVarBndr ()]+ , effMonad :: TyVarBndr ()+ , effMethods :: [MethodInterface]+ }++effParamVar :: (Name, Maybe Kind) -> TyVarBndr ()+effParamVar (n, k) = case k of+ Just k' -> KindedTV n () k'+ Nothing -> PlainTV n ()++data MethodInterface = MethodInterface+ { methodName :: Name+ , methodOrder :: EffectOrder+ , methodParamTypes :: [Type]+ , methodReturnType :: Type+ , methodCxt :: Cxt+ }++-- | Given a type class name, extracts infos about an effect.+reifyEffectInfo :: Name -> Q EffectInfo+reifyEffectInfo className = do+ info <- reify className+ case info of+ ClassI (ClassD cxts name tyVars _funDeps decs) _ -> do+ (paramVars, monad) <-+ case tyVars of+ [] ->+ fail $+ "The specified effect type class `"+ ++ nameBase name+ ++ "' has no monad type variable. "+ ++ "It is expected to be the last type variable."+ vs -> pure (init vs, last vs)++ EffectInfo cxts name paramVars monad+ <$> sequence+ [ do+ (order, paramTypes, retType, cxt) <- analyzeMethodInterface monad t+ pure $ MethodInterface n order paramTypes retType cxt+ | SigD n t <- decs+ ]+ other ->+ fail $+ "The specified name `"+ ++ nameBase className+ ++ "' is not a type class, but the following instead: "+ ++ show other++-- | Constructs the type of an effect, i.e. the type class without its monad parameter.+effectType :: EffectInfo -> Q Type+effectType info =+ foldl+ appT+ (conT $ effName info)+ (fmap tyVarType (effParamVars info))++partitionSuperEffects :: EffectInfo -> (Cxt, [Type])+partitionSuperEffects info =+ ( filter (isNothing . extract) cxts+ , mapMaybe extract (effCxts info)+ )+ where+ cxts = effCxts info+ m = tyVarName (effMonad info)+ extract = \case+ ForallT _ _ t -> extract t+ SigT t _ -> extract t+ ParensT t -> extract t+ t `AppT` VarT n | n == m -> Just t+ InfixT t _ (VarT n) | n == m -> Just t+ UInfixT t _ (VarT n) | n == m -> Just t+ AppKindT t _ -> extract t+ ImplicitParamT _ t -> extract t+ _ -> Nothing++{- |+Extracts the super classes of an effect which have the kind of effects. As an example, for the+following effect ...++@class (State s m, Monad m) => MyEffect s m where ...@++... this would pure [State s, Monad].+-}+superEffects :: EffectInfo -> [Type]+superEffects = snd . partitionSuperEffects++{- |+Like superEffects, but ignores super classes from base (i.e., Applicative, Functor, Monad, MonadIO).+-}+superEffectsWithoutBase :: EffectInfo -> [Type]+superEffectsWithoutBase =+ filter (not . isBase) . superEffects+ where+ isBase = \case+ ConT n -> n `elem` [''Applicative, ''Functor, ''Monad, ''MonadIO]+ _ -> False++effectParamCxt :: EffectInfo -> Cxt+effectParamCxt = fst . partitionSuperEffects++-- ** Utility functions++-- | Construct a namer from a conversion function of string.+pureNamer :: (String -> String) -> Name -> Q Name+pureNamer f = pure . mkName . f . nameBase++-- | Throws away all kind information from a type.+unkindType :: Type -> Type+unkindType = \case+ ForallT vs ps t -> ForallT (fmap unkindTyVar vs) (fmap unkindType ps) (unkindType t)+ AppT l r -> AppT (unkindType l) (unkindType r)+ SigT t _ -> t+ InfixT l n r -> InfixT (unkindType l) n (unkindType r)+ UInfixT l n r -> UInfixT (unkindType l) n (unkindType r)+ ParensT t -> ParensT (unkindType t)+ AppKindT t _ -> unkindType t+ ImplicitParamT s t -> ImplicitParamT s (unkindType t)+ other -> other++-- | Throws away the kind information of a type variable.+unkindTyVar :: TyVarBndr a -> TyVarBndr a+unkindTyVar (KindedTV n s _) = PlainTV n s+unkindTyVar unkinded = unkinded++-- | Converts a type variable to a type.+tyVarType :: TyVarBndr a -> Q Type+tyVarType (PlainTV n _) = varT n+tyVarType (KindedTV n _ k) = sigT (varT n) k++tyVarKind :: TyVarBndr a -> Q Type+tyVarKind (KindedTV _ _ k) = pure k+tyVarKind (PlainTV _ _) = fail "The type variable has no kind."++-- | Counts the parameters of a type.+paramCount :: Type -> Int+paramCount = \case+ ArrowT `AppT` _ `AppT` r -> 1 + paramCount r+ ForallT _ _ t -> paramCount t+ _ -> 0++-- | Checks if a name m appears somewhere in a type.+occurs :: Name -> Type -> Bool+occurs m = \case+ ForallT _ _ t -> m `occurs` t+ AppT l r -> m `occurs` l || m `occurs` r+ SigT t _ -> m `occurs` t+ VarT n -> n == m+ ConT n -> n == m+ PromotedT n -> n == m+ InfixT l n r -> n == m || m `occurs` l || m `occurs` r+ UInfixT l n r -> n == m || m `occurs` l || m `occurs` r+ ParensT t -> m `occurs` t+ AppKindT t _ -> m `occurs` t+ ImplicitParamT _ t -> m `occurs` t+ _ -> False