data-effects-th (empty) → 0.1.0.0
raw patch · 12 files changed
+1874/−0 lines, 12 filesdep +basedep +containersdep +data-default
Dependencies added: base, containers, data-default, data-effects-core, data-effects-th, either, extra, formatting, infinite-list, lens, mtl, tasty, tasty-hunit, template-haskell, text, th-abstraction
Files
- ChangeLog.md +5/−0
- Example/Driver.hs +5/−0
- Example/Example.hs +43/−0
- LICENSE +373/−0
- NOTICE +7/−0
- README.md +22/−0
- data-effects-th.cabal +120/−0
- src/Data/Effect/HFunctor/TH.hs +58/−0
- src/Data/Effect/HFunctor/TH/Internal.hs +240/−0
- src/Data/Effect/Key/TH.hs +111/−0
- src/Data/Effect/TH.hs +164/−0
- src/Data/Effect/TH/Internal.hs +726/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for data-effects-th++## 0.1.0.0 -- 2023-09-18++* Initial public release.
+ 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/.
+ Example/Example.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE PatternSynonyms #-}+{-# 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 Example where++import Data.Effect.HFunctor (HFunctor)+import Data.Effect.HFunctor.TH (makeHFunctor, makeHFunctor')+import Data.Effect.TH (makeEffect, makeEffectH)+import Data.Kind (Type)+import Data.List.Infinite (Infinite ((:<)))++data Throw e (a :: Type) where+ Throw :: e -> Throw e a++data Catch e f (a :: Type) where+ Catch :: f a -> (e -> f a) -> Catch e f a++makeEffect [''Throw] [''Catch]++data Unlift b f (a :: Type) where+ WithRunInBase :: ((forall x. f x -> b x) -> b a) -> Unlift b f a++makeEffectH [''Unlift]++data Nested (f :: Type -> Type) (a :: Type) where+ Nested :: ([f a -> Int] -> Int) -> Nested f a+makeHFunctor ''Nested++data ManuallyCxt (g :: Type -> Type) h (f :: Type -> Type) (a :: Type) where+ ManuallyCxt :: g (h f a) -> ManuallyCxt g h f a+makeHFunctor' ''ManuallyCxt \(g :< h :< _) -> [t|(Functor $g, HFunctor $h)|]++data NestedTuple (f :: Type -> Type) (a :: Type) where+ NestedTuple :: ((forall x. (f x, f a) -> Int) -> Int) -> NestedTuple f a+makeHFunctor ''NestedTuple++newtype IdentityH f (a :: Type) = IdentityH {unIdentityH :: f a}+makeHFunctor ''IdentityH
+ 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,22 @@+# data-effects++[](https://hackage.haskell.org/package/data-effects)+[](https://hackage.haskell.org/package/data-effects-core)+[](https://hackage.haskell.org/package/data-effects-th)++A basic framework for a Haskell effect system library based on GADTs-based effect representations+with a style that separates first-order effects and higher-order effects.++This library set was created by being separated from+the [Heftia](https://github.com/sayo-hs/heftia) extensible effects library.++## Your contributions are welcome!+Please see [CONTRIBUTING.md](CONTRIBUTING.md).++## Credits+Parts of this project have been adapted or inspired by the following resources:++* **[compdata](https://github.com/pa-ba/compdata)**+ * **Copyright** (c) 2010--2011 Patrick Bahr, Tom Hvitved+ * **License**: BSD-3-Clause+ * **Modifications**: Used TemplateHaskell code to derive instances of the `HFunctor` type class.
+ data-effects-th.cabal view
@@ -0,0 +1,120 @@+cabal-version: 2.4+name: data-effects-th+version: 0.1.0.0++-- A short (one-line) description of the package.+synopsis: Template Haskell utilities for the data-effects library.++-- A longer description of the package.+description:+ TemplateHaskell functions for deriving effect invocation+ functions, [HFunctor](https://hackage.haskell.org/package/data-effects-core-0.1.0.0/docs/Data-Effect-HFunctor.html#t:HFunctor)+ instances, and more from the definition of effects+ with [data-effects](https://hackage.haskell.org/package/data-effects)-based GADT representations.++-- A URL where users can report bugs.+bug-reports: https://github.com/sayo-hs/data-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/data-effects+ tag: v0.1.0+ subdir: data-effects-th++library+ exposed-modules:+ Data.Effect.HFunctor.TH+ Data.Effect.HFunctor.TH.Internal+ Data.Effect.TH.Internal+ Data.Effect.TH+ Data.Effect.Key.TH++ -- 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,+ data-effects-core ^>= 0.1,+ template-haskell ^>= 2.18,+ th-abstraction >= 0.4 && < 0.7,+ lens ^>= 5.2.3,+ mtl ^>= 2.2.2,+ extra ^>= 1.7.14,+ containers ^>= 0.6.5,+ either ^>= 5.0.2,+ text ^>= 1.2.5,+ data-default ^>= 0.7.1,+ infinite-list ^>= 0.1.1,+ formatting ^>= 7.2.0,++ 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:+ Example++ main-is: Driver.hs+ hs-source-dirs: Example+ build-depends:+ data-effects-th,+ base,+ data-effects-core,+ tasty ^>= 1.4,+ tasty-hunit ^>= 0.10,+ data-default,+ infinite-list,++ 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/Data/Effect/HFunctor/TH.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Redundant <&>" #-}++-- 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+t'Data.Effect.HFunctor.HFunctor'.+-}+module Data.Effect.HFunctor.TH where++import Data.Effect.HFunctor.TH.Internal (deriveHFunctor)+import Data.Effect.TH.Internal (analyzeData)+import Data.Functor ((<&>))+import Data.List.Infinite (Infinite)+import Language.Haskell.TH (Dec, Name, Q, reify)+import Language.Haskell.TH qualified as TH+import Language.Haskell.TH.Syntax (nameBase)++{- |+Derive an instance of t'Data.Effect.HFunctor.HFunctor' for a type constructor of any higher-order+kind taking at least two arguments.+-}+makeHFunctor :: Name -> Q [Dec]+makeHFunctor name = makeHFunctor' name (const [t|()|])++{- |+Derive an instance of t'Data.Effect.HFunctor.HFunctor' for a type constructor of any higher-order+kind taking at least two arguments.++Furthermore, you can manually provide type constraints for the instance:++@+{\-# LANGUAGE BlockArguments #-\}+import Data.List.Infinite (Infinite ((:<)))++data Example (g :: Type -> Type) h (f :: Type -> Type) (a :: Type) where+ Example :: g (h f a) -> Example g h f a++makeHFunctor' ''Example \\(g \:\< h \:\< _) -> [t| (Functor $g, HFunctor $h) |]+@+-}+makeHFunctor' :: Name -> (Infinite (Q TH.Type) -> Q TH.Type) -> Q [Dec]+makeHFunctor' name manualCxt = do+ reify name <&> analyzeData >>= \case+ Just dat -> do+ deriveHFunctor manualCxt dat+ Nothing -> fail $ "The specified name is not that of a data type: " ++ nameBase name
+ src/Data/Effect/HFunctor/TH/Internal.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Use <=<" #-}++-- 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 licensed under the BSD3 License as+ shown in [1]. The modified code, in its entirety, is licensed under+ MPL 2.0. When redistributing, please ensure that you do not remove+ the BSD3 License text as indicated in [1].+ <https://github.com/pa-ba/compdata/blob/master/src/Data/Comp/Multi/Derive/HFunctor.hs>++ [1] Copyright (c) 2010--2011 Patrick Bahr, Tom Hvitved++ All rights reserved.++ Redistribution and use in source and binary forms, with or without+ modification, are permitted provided that the following conditions+ are met:++ 1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ 2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++ 3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+ POSSIBILITY OF SUCH DAMAGE.+-}++{- |+Copyright : (c) 2010-2011 Patrick Bahr, Tom Hvitved+ (c) 2023 Yamada Ryo+License : MPL-2.0 (see the file LICENSE)+Maintainer : ymdfield@outlook.jp+Stability : experimental+Portability : portable+-}+module Data.Effect.HFunctor.TH.Internal where++import Control.Monad (replicateM, zipWithM)+import Data.Effect.HFunctor (HFunctor, hfmap)+import Data.Effect.TH.Internal (+ ConInfo (ConInfo),+ DataInfo (DataInfo),+ conArgs,+ conGadtReturnType,+ conName,+ occurs,+ tyVarName,+ tyVarType,+ unkindType,+ )+import Data.Foldable (foldl')+import Data.Functor ((<&>))+import Data.List.Infinite (Infinite, prependList)+import Data.Text qualified as T+import Formatting (int, sformat, shown, stext, (%))+import Language.Haskell.TH (+ Body (NormalB),+ Clause (Clause),+ Dec (FunD, InstanceD, PragmaD),+ Exp (AppE, CaseE, ConE, LamE, TupE, VarE),+ Inline (Inline),+ Match (Match),+ Name,+ Pat (ConP, TupP, VarP),+ Phases (AllPhases),+ Pragma (InlineP),+ Q,+ Quote (..),+ RuleMatch (FunLike),+ TyVarBndr (PlainTV),+ Type (AppT, ArrowT, ConT, ForallT, SigT, TupleT, VarT),+ appE,+ nameBase,+ pprint,+ )+import Language.Haskell.TH qualified as TH++{- |+Derive an instance of t'Data.Effect.HFunctor.HFunctor' for a type constructor of any higher-order+kind taking at least two arguments.+-}+deriveHFunctor :: (Infinite (Q TH.Type) -> Q TH.Type) -> DataInfo -> Q [Dec]+deriveHFunctor manualCxt (DataInfo _ name args cons) = do+ mapFnName <- newName "_f"+ let mapFn = VarE mapFnName++ initArgs = init args+ hfArgs = init initArgs++ hfArgNames = map (VarT . tyVarName) hfArgs++ -- The algorithm is based on: https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/derive-functor+ hfmapClause :: ConInfo -> Q Clause+ hfmapClause ConInfo{..} = do+ let f = case conGadtReturnType of+ Nothing -> last initArgs+ Just t -> case t of+ _ `AppT` VarT n `AppT` _ -> PlainTV n ()+ _ `AppT` (VarT n `SigT` _) `AppT` _ -> PlainTV n ()+ _ -> error $ "Encounted unknown structure: " ++ pprint t++ hfmapE :: TH.Type -> Exp -> Q Exp+ hfmapE tk+ | fNotOccurs t = pure+ | otherwise = \x -> case t of+ VarT n `AppT` a | n == tyVarName f && fNotOccurs a -> pure $ mapFn `AppE` x+ ArrowT `AppT` c `AppT` d ->+ wrapLam \y -> hfmapE d . (x `AppE`) =<< cohfmapE c y+ g `AppT` a+ | fNotOccurs g ->+ ((VarE 'fmap `AppE`) <$> wrapLam (hfmapE a)) <&> (`AppE` x)+ ff `AppT` g `AppT` a+ | fNotOccurs ff && fNotOccurs a ->+ ((VarE 'hfmap `AppE`) <$> wrapLam (hfmapE $ g `AppT` a)) <&> (`AppE` x)+ -- todo: tuple support+ ForallT _ _ a -> hfmapE a x+ _ ->+ case mapTupleE hfmapE t x of+ Just e -> e+ Nothing -> fail $ "Encounted unsupported structure: " ++ pprint t+ where+ t = unkindType tk++ cohfmapE :: TH.Type -> Exp -> Q Exp+ cohfmapE tk+ | not $ tyVarName f `occurs` t = pure+ | otherwise = \x -> case t of+ VarT n `AppT` a+ | n == tyVarName f && fNotOccurs a ->+ fail $ "Functor type variable occurs in contravariant position: " ++ pprint t+ ArrowT `AppT` c `AppT` d ->+ wrapLam \y -> cohfmapE d . (x `AppE`) =<< hfmapE c y+ g `AppT` a+ | fNotOccurs g ->+ ((VarE 'fmap `AppE`) <$> wrapLam (cohfmapE a)) <&> (`AppE` x)+ ff `AppT` _ `AppT` a+ | fNotOccurs ff && fNotOccurs a ->+ fail $ "Functor type variable occurs in contravariant position: " ++ pprint t+ ForallT _ _ b' -> cohfmapE b' x+ _ ->+ case mapTupleE cohfmapE t x of+ Just e -> e+ Nothing -> fail $ "Encounted unsupported structure: " ++ pprint t+ where+ t = unkindType tk++ fNotOccurs = not . (tyVarName f `occurs`)++ vars <- replicateM (length conArgs) (newName "x")+ mappedArgs <- zipWithM hfmapE (map snd conArgs) (map VarE vars)+ let body = foldl' AppE (ConE conName) mappedArgs+ pure $ Clause [VarP mapFnName, ConP conName [] (map VarP vars)] (NormalB body) []++ cxt <-+ manualCxt $+ map (pure . tyVarType) hfArgs+ `prependList` error+ ( T.unpack $+ sformat+ ( "Too many data type arguments in use. The number of usable type arguments in the data type ‘"+ % shown+ % "’ to be derived is "+ % int+ % ". ("+ % stext+ % ")"+ )+ name+ (length hfArgs)+ (T.intercalate ", " $ map ((\t -> "‘" <> t <> "’") . T.pack . nameBase . tyVarName) hfArgs)+ )++ hfmapDecls <- FunD 'hfmap <$> mapM hfmapClause cons+ let fnInline = PragmaD (InlineP 'hfmap Inline FunLike AllPhases)++ pure+ [ InstanceD+ Nothing+ [cxt]+ (ConT ''HFunctor `AppT` foldl' AppT (ConT name) hfArgNames)+ [hfmapDecls, fnInline]+ ]++wrapLam :: (Exp -> Q Exp) -> Q Exp+wrapLam f = do+ x <- newName "x"+ LamE [VarP x] <$> f (VarE x)++mapTupleE :: (TH.Type -> Exp -> Q Exp) -> TH.Type -> Exp -> Maybe (Q Exp)+mapTupleE f t e = do+ es <- decomposeTupleT t+ let n = length es+ Just do+ xs <- newNames n "x"+ ys <- zipWithM f es $ map VarE xs+ pure $ CaseE e [Match (TupP $ map VarP xs) (NormalB $ TupE $ map Just ys) []]++decomposeTupleT :: TH.Type -> Maybe [TH.Type]+decomposeTupleT = go [] 0+ where+ go :: [TH.Type] -> Int -> TH.Type -> Maybe [TH.Type]+ go acc !n = \case+ TupleT m | m == n -> Just acc+ f `AppT` a -> go (a : acc) (n + 1) f+ _ -> Nothing+{-# INLINE decomposeTupleT #-}++-- * Utility functions++{- |+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)
+ src/Data/Effect/Key/TH.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}+{-# 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/.++module Data.Effect.Key.TH where++import Control.Effect.Key (SendInsBy, SendSigBy)+import Control.Lens ((%~), (<&>), _Just, _head)+import Control.Monad (forM_)+import Control.Monad.Writer (execWriterT, tell)+import Data.Char (toLower)+import Data.Default (def)+import Data.Effect.Key (type (##>), type (#>))+import Data.Effect.TH (makeEffect')+import Data.Effect.TH.Internal (+ DataInfo,+ EffClsInfo (EffClsInfo),+ EffConInfo (EffConInfo),+ EffectClassConf (EffectClassConf),+ EffectConf (EffectConf, _keyedSenderGenConf),+ EffectOrder (FirstOrder, HigherOrder),+ MakeEffectConf,+ SenderFunctionConf (SenderFunctionConf),+ alterEffectConf,+ ecEffs,+ ecName,+ ecParamVars,+ effName,+ genSenderArmor,+ normalSenderGenConf,+ senderFnName,+ tyVarName,+ _confByEffect,+ _keyedSenderGenConf,+ _senderFnName,+ )+import Data.Function ((&))+import Data.List.Extra (stripSuffix)+import Data.Text qualified as T+import Formatting (sformat, string, (%))+import Language.Haskell.TH (+ Body (NormalB),+ Clause (Clause),+ Dec (DataD, TySynD),+ Exp (AppTypeE, VarE),+ Info,+ Name,+ Q,+ TyVarBndr (PlainTV),+ Type (AppT, ConT, InfixT, VarT),+ mkName,+ nameBase,+ )++makeKeyedEffect :: [Name] -> [Name] -> Q [Dec]+makeKeyedEffect =+ makeEffect'+ (def & changeNormalSenderFnNameFormat)+ genEffectKey+{-# INLINE makeKeyedEffect #-}++changeNormalSenderFnNameFormat :: MakeEffectConf -> MakeEffectConf+changeNormalSenderFnNameFormat =+ alterEffectConf $ normalSenderGenConf . _Just . senderFnName %~ (++ "'_")+{-# INLINE changeNormalSenderFnNameFormat #-}++genEffectKey :: EffectOrder -> Info -> DataInfo -> EffClsInfo -> EffectClassConf -> Q [Dec]+genEffectKey order _ _ EffClsInfo{..} EffectClassConf{..} = execWriterT do+ let keyedOp = case order of+ FirstOrder -> ''(#>)+ HigherOrder -> ''(##>)++ pvs = tyVarName <$> ecParamVars++ ecNamePlain <-+ removeLastApostrophe (nameBase ecName)+ & maybe+ ( fail . T.unpack $+ sformat+ ("No last apostrophe on the effect class ‘" % string % "’.")+ (nameBase ecName)+ )+ pure++ let keyDataName = mkName $ ecNamePlain ++ "Key"+ key = ConT keyDataName++ tell [DataD [] keyDataName [] Nothing [] []]++ tell+ [ TySynD+ (mkName ecNamePlain)+ (pvs <&> (`PlainTV` ()))+ (InfixT key keyedOp (foldl AppT (ConT ecName) (map VarT pvs)))+ ]++ forM_ ecEffs \con@EffConInfo{..} -> do+ let EffectConf{..} = _confByEffect effName+ forM_ _keyedSenderGenConf \conf@SenderFunctionConf{..} -> do+ let sendCxt effDataType carrier = case order of+ FirstOrder -> ConT ''SendInsBy `AppT` key `AppT` effDataType `AppT` carrier+ HigherOrder -> ConT ''SendSigBy `AppT` key `AppT` effDataType `AppT` carrier++ genSenderArmor sendCxt id conf{_senderFnName = nameBase effName & _head %~ toLower} con \_f ->+ pure $ Clause [] (NormalB $ VarE (mkName _senderFnName) `AppTypeE` key) []++removeLastApostrophe :: String -> Maybe String+removeLastApostrophe = stripSuffix "'"
+ src/Data/Effect/TH.hs view
@@ -0,0 +1,164 @@+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Eta reduce" #-}++-- 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+-}+module Data.Effect.TH (+ module Data.Effect.TH,+ module Data.Default,+ module Data.Function,+ EffectOrder (..),+ orderOf,+ MakeEffectConf (..),+ alterEffectClassConf,+ alterEffectConf,+ EffectClassConf (..),+ confByEffect,+ doesDeriveHFunctor,+ doesGenerateLiftInsPatternSynonyms,+ doesGenerateLiftInsTypeSynonym,+ EffectConf (..),+ keyedSenderGenConf,+ normalSenderGenConf,+ taggedSenderGenConf,+ warnFirstOrderInSigCls,+ SenderFunctionConf (..),+ senderFnName,+ doesGenerateSenderFnSignature,+ senderFnDoc,+ senderFnArgDoc,+ senderFnConfs,+ deriveHFunctor,+ noDeriveHFunctor,+ generateLiftInsTypeSynonym,+ noGenerateLiftInsTypeSynonym,+ generateLiftInsPatternSynonyms,+ noGenerateLiftInsPatternSynonyms,+ noGenerateNormalSenderFunction,+ noGenerateTaggedSenderFunction,+ noGenerateKeyedSenderFunction,+ suppressFirstOrderInSignatureClassWarning,+ noGenerateSenderFunctionSignature,+) where++import Control.Monad.Writer (execWriterT, forM_, lift, tell, when)+import Data.Default (Default (def))+import Data.Effect.HFunctor.TH.Internal (deriveHFunctor)+import Data.Effect.TH.Internal (+ DataInfo,+ EffClsInfo,+ EffectClassConf (+ EffectClassConf,+ _confByEffect,+ _doesDeriveHFunctor,+ _doesGenerateLiftInsPatternSynonyms,+ _doesGenerateLiftInsTypeSynonym+ ),+ EffectConf (+ EffectConf,+ _keyedSenderGenConf,+ _normalSenderGenConf,+ _taggedSenderGenConf,+ _warnFirstOrderInSigCls+ ),+ EffectOrder (FirstOrder, HigherOrder),+ MakeEffectConf (MakeEffectConf, unMakeEffectConf),+ SenderFunctionConf (+ _doesGenerateSenderFnSignature,+ _senderFnArgDoc,+ _senderFnDoc,+ _senderFnName+ ),+ alterEffectClassConf,+ alterEffectConf,+ confByEffect,+ doesDeriveHFunctor,+ doesGenerateLiftInsPatternSynonyms,+ doesGenerateLiftInsTypeSynonym,+ doesGenerateSenderFnSignature,+ genLiftInsPatternSynonyms,+ genLiftInsTypeSynonym,+ genSenders,+ generateLiftInsPatternSynonyms,+ generateLiftInsTypeSynonym,+ keyedSenderGenConf,+ noDeriveHFunctor,+ noGenerateKeyedSenderFunction,+ noGenerateLiftInsPatternSynonyms,+ noGenerateLiftInsTypeSynonym,+ noGenerateNormalSenderFunction,+ noGenerateSenderFunctionSignature,+ noGenerateTaggedSenderFunction,+ normalSenderGenConf,+ orderOf,+ reifyEffCls,+ senderFnArgDoc,+ senderFnConfs,+ senderFnDoc,+ senderFnName,+ suppressFirstOrderInSignatureClassWarning,+ taggedSenderGenConf,+ unMakeEffectConf,+ warnFirstOrderInSigCls,+ )+import Data.Function ((&))+import Data.List (singleton)+import Language.Haskell.TH (Dec, Info, Name, Q, Type (TupleT))++makeEffect' ::+ MakeEffectConf ->+ (EffectOrder -> Info -> DataInfo -> EffClsInfo -> EffectClassConf -> Q [Dec]) ->+ [Name] ->+ [Name] ->+ Q [Dec]+makeEffect' (MakeEffectConf conf) extTemplate inss sigs = execWriterT do+ forM_ inss \ins -> do+ (info, dataInfo, effClsInfo) <- reifyEffCls FirstOrder ins & lift+ ecConf@EffectClassConf{..} <- conf effClsInfo & lift++ genSenders ecConf effClsInfo & lift >>= tell++ when _doesGenerateLiftInsTypeSynonym do+ genLiftInsTypeSynonym effClsInfo & singleton & tell++ when _doesGenerateLiftInsPatternSynonyms do+ genLiftInsPatternSynonyms effClsInfo & lift >>= tell++ extTemplate FirstOrder info dataInfo effClsInfo ecConf & lift >>= tell++ forM_ sigs \sig -> do+ (info, dataInfo, effClsInfo) <- reifyEffCls HigherOrder sig & lift+ ecConf@EffectClassConf{..} <- conf effClsInfo & lift++ genSenders ecConf effClsInfo & lift >>= tell++ when _doesDeriveHFunctor do+ deriveHFunctor (const $ pure $ TupleT 0) dataInfo & lift >>= tell++ extTemplate HigherOrder info dataInfo effClsInfo ecConf & lift >>= tell++noExtTemplate :: EffectOrder -> Info -> DataInfo -> EffClsInfo -> EffectClassConf -> Q [Dec]+noExtTemplate = mempty+{-# INLINE noExtTemplate #-}++makeEffect :: [Name] -> [Name] -> Q [Dec]+makeEffect = makeEffect' def noExtTemplate+{-# INLINE makeEffect #-}++makeEffectF :: [Name] -> Q [Dec]+makeEffectF inss = makeEffect inss []+{-# INLINE makeEffectF #-}++makeEffectH :: [Name] -> Q [Dec]+makeEffectH sigs = makeEffect [] sigs+{-# INLINE makeEffectH #-}
+ src/Data/Effect/TH/Internal.hs view
@@ -0,0 +1,726 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE OverloadedStrings #-}+{-# 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-2024 Yamada Ryo+ (c) 2010-2011 Patrick Bahr, Tom Hvitved+ (c) 2020 Michael Szvetits+License : MPL-2.0 (see the file LICENSE)+Maintainer : ymdfield@outlook.jp+Stability : experimental+Portability : portable+-}+module Data.Effect.TH.Internal where++import Control.Lens (Traversal', makeLenses, (%~), (.~), _head)+import Control.Monad (forM, forM_, replicateM, unless, when)+import Data.List (foldl')+import Language.Haskell.TH.Syntax (+ Con,+ Cxt,+ Dec (SigD),+ Info,+ Name,+ Q,+ Quote (newName),+ TyVarBndr,+ Type (+ AppKindT,+ AppT,+ ArrowT,+ ConT,+ ForallT,+ ImplicitParamT,+ InfixT,+ ParensT,+ PromotedT,+ SigT,+ UInfixT,+ VarT+ ),+ addModFinalizer,+ nameBase,+ reify,+ )++import Control.Arrow ((>>>))+import Control.Effect (SendIns, SendSig, sendIns, sendSig)+import Control.Effect.Key (SendInsBy, SendSigBy, sendInsBy, sendSigBy)+import Control.Monad.Writer (WriterT, execWriterT, lift, tell)+import Data.Char (toLower)+import Data.Default (Default, def)+import Data.Effect (LiftIns (LiftIns))+import Data.Effect.Tag (Tag (Tag), TagH (TagH))+import Data.Either.Extra (mapLeft, maybeToEither)+import Data.Either.Validation (Validation, eitherToValidation, validationToEither)+import Data.Function ((&))+import Data.Functor (($>), (<&>))+import Data.List.Extra (unsnoc)+import Data.Maybe (fromJust, isJust)+import Data.Text qualified as T+import Language.Haskell.TH (+ BangType,+ Body (NormalB),+ Clause (Clause),+ Con (ForallC, GadtC, InfixC, NormalC, RecC, RecGadtC),+ Dec (DataD, FunD, NewtypeD, PatSynD, PragmaD, TySynD),+ DocLoc (ArgDoc, DeclDoc),+ Exp (AppE, AppTypeE, ConE, SigE, VarE),+ Info (TyConI),+ Inline (Inline),+ Pat (ConP, VarP),+ PatSynArgs (PrefixPatSyn),+ PatSynDir (ImplBidir),+ Phases (AllPhases),+ Pragma (CompleteP, InlineP),+ RuleMatch (FunLike),+ Specificity (SpecifiedSpec),+ TyVarBndr (..),+ TyVarBndrSpec,+ Type (WildCardT),+ getDoc,+ mkName,+ patSynSigD,+ pprint,+ putDoc,+ reportWarning,+ )+import Language.Haskell.TH qualified as TH++data EffClsInfo = EffClsInfo+ { ecName :: Name+ , ecParamVars :: [TyVarBndr ()]+ , ecCarrier :: Maybe (TyVarBndr ())+ , ecEffs :: [EffConInfo]+ }++data EffConInfo = EffConInfo+ { effName :: Name+ , effParamTypes :: [TH.Type]+ , effDataType :: TH.Type+ , effResultType :: TH.Type+ , effTyVars :: [TyVarBndrSpec]+ , effCarrier :: Maybe (TyVarBndr ())+ , effCxt :: Cxt+ }++-- | An order of effect.+data EffectOrder = FirstOrder | HigherOrder+ deriving (Show, Eq, Ord)++orderOf :: EffClsInfo -> EffectOrder+orderOf =+ ecCarrier >>> \case+ Just _ -> HigherOrder+ Nothing -> FirstOrder++newtype MakeEffectConf = MakeEffectConf {unMakeEffectConf :: EffClsInfo -> Q EffectClassConf}++alterEffectClassConf :: (EffectClassConf -> EffectClassConf) -> MakeEffectConf -> MakeEffectConf+alterEffectClassConf f (MakeEffectConf conf) = MakeEffectConf (fmap f . conf)+{-# INLINE alterEffectClassConf #-}++alterEffectConf :: (EffectConf -> EffectConf) -> MakeEffectConf -> MakeEffectConf+alterEffectConf f = alterEffectClassConf \conf ->+ conf{_confByEffect = f . _confByEffect conf}++data EffectClassConf = EffectClassConf+ { _confByEffect :: Name -> EffectConf+ , _doesDeriveHFunctor :: Bool+ , _doesGenerateLiftInsTypeSynonym :: Bool+ , _doesGenerateLiftInsPatternSynonyms :: Bool+ }++data EffectConf = EffectConf+ { _normalSenderGenConf :: Maybe SenderFunctionConf+ , _taggedSenderGenConf :: Maybe SenderFunctionConf+ , _keyedSenderGenConf :: Maybe SenderFunctionConf+ , _warnFirstOrderInSigCls :: Bool+ }++data SenderFunctionConf = SenderFunctionConf+ { _senderFnName :: String+ , _doesGenerateSenderFnSignature :: Bool+ , _senderFnDoc :: Maybe String -> Q (Maybe String)+ , _senderFnArgDoc :: Int -> Maybe String -> Q (Maybe String)+ }++senderFnConfs :: Traversal' EffectConf SenderFunctionConf+senderFnConfs f EffectConf{..} = do+ normal <- traverse f _normalSenderGenConf+ tagged <- traverse f _taggedSenderGenConf+ keyed <- traverse f _keyedSenderGenConf+ pure+ EffectConf+ { _normalSenderGenConf = normal+ , _taggedSenderGenConf = tagged+ , _keyedSenderGenConf = keyed+ , _warnFirstOrderInSigCls+ }++makeLenses ''EffectClassConf+makeLenses ''EffectConf+makeLenses ''SenderFunctionConf++deriveHFunctor :: MakeEffectConf -> MakeEffectConf+deriveHFunctor = alterEffectClassConf $ doesDeriveHFunctor .~ True+{-# INLINE deriveHFunctor #-}++noDeriveHFunctor :: MakeEffectConf -> MakeEffectConf+noDeriveHFunctor = alterEffectClassConf $ doesDeriveHFunctor .~ False+{-# INLINE noDeriveHFunctor #-}++generateLiftInsTypeSynonym :: MakeEffectConf -> MakeEffectConf+generateLiftInsTypeSynonym = alterEffectClassConf $ doesGenerateLiftInsTypeSynonym .~ True+{-# INLINE generateLiftInsTypeSynonym #-}++noGenerateLiftInsTypeSynonym :: MakeEffectConf -> MakeEffectConf+noGenerateLiftInsTypeSynonym = alterEffectClassConf $ doesGenerateLiftInsTypeSynonym .~ False+{-# INLINE noGenerateLiftInsTypeSynonym #-}++generateLiftInsPatternSynonyms :: MakeEffectConf -> MakeEffectConf+generateLiftInsPatternSynonyms = alterEffectClassConf $ doesGenerateLiftInsPatternSynonyms .~ True+{-# INLINE generateLiftInsPatternSynonyms #-}++noGenerateLiftInsPatternSynonyms :: MakeEffectConf -> MakeEffectConf+noGenerateLiftInsPatternSynonyms =+ alterEffectClassConf $ doesGenerateLiftInsPatternSynonyms .~ False+{-# INLINE noGenerateLiftInsPatternSynonyms #-}++noGenerateNormalSenderFunction :: MakeEffectConf -> MakeEffectConf+noGenerateNormalSenderFunction = alterEffectConf $ normalSenderGenConf .~ Nothing+{-# INLINE noGenerateNormalSenderFunction #-}++noGenerateTaggedSenderFunction :: MakeEffectConf -> MakeEffectConf+noGenerateTaggedSenderFunction = alterEffectConf $ taggedSenderGenConf .~ Nothing+{-# INLINE noGenerateTaggedSenderFunction #-}++noGenerateKeyedSenderFunction :: MakeEffectConf -> MakeEffectConf+noGenerateKeyedSenderFunction = alterEffectConf $ keyedSenderGenConf .~ Nothing+{-# INLINE noGenerateKeyedSenderFunction #-}++suppressFirstOrderInSignatureClassWarning :: MakeEffectConf -> MakeEffectConf+suppressFirstOrderInSignatureClassWarning = alterEffectConf $ warnFirstOrderInSigCls .~ False+{-# INLINE suppressFirstOrderInSignatureClassWarning #-}++noGenerateSenderFunctionSignature :: MakeEffectConf -> MakeEffectConf+noGenerateSenderFunctionSignature =+ alterEffectConf $ senderFnConfs %~ doesGenerateSenderFnSignature .~ False+{-# INLINE noGenerateSenderFunctionSignature #-}++instance Default MakeEffectConf where+ def = MakeEffectConf $ const $ pure def+ {-# INLINE def #-}++instance Default EffectClassConf where+ def =+ EffectClassConf+ { _confByEffect = \effConName ->+ let normalSenderFnConf =+ SenderFunctionConf+ { _senderFnName = nameBase effConName & _head %~ toLower+ , _doesGenerateSenderFnSignature = True+ , _senderFnDoc = pure+ , _senderFnArgDoc = const pure+ }+ in EffectConf+ { _normalSenderGenConf = Just normalSenderFnConf+ , _taggedSenderGenConf =+ Just $ normalSenderFnConf & senderFnName %~ (++ "'")+ , _keyedSenderGenConf =+ Just $ normalSenderFnConf & senderFnName %~ (++ "''")+ , _warnFirstOrderInSigCls = True+ }+ , _doesDeriveHFunctor = True+ , _doesGenerateLiftInsTypeSynonym = True+ , _doesGenerateLiftInsPatternSynonyms = True+ }++genSenders :: EffectClassConf -> EffClsInfo -> Q [Dec]+genSenders EffectClassConf{..} ec@EffClsInfo{..} = do+ let order = orderOf ec++ execWriterT $ forM ecEffs \con@EffConInfo{..} -> do+ let EffectConf{..} = _confByEffect effName++ forM_ _normalSenderGenConf \conf -> genNormalSender order conf con+ forM_ _taggedSenderGenConf \conf -> genTaggedSender order conf con+ forM_ _keyedSenderGenConf \conf -> genKeyedSender order conf con++ -- Check for First Order in Signature Class warning+ when (_warnFirstOrderInSigCls && order == HigherOrder) do+ let isHigherOrderEffect = any (tyVarName (fromJust effCarrier) `occurs`) effParamTypes++ unless isHigherOrderEffect do+ lift $+ reportWarning $+ "The first-order effect ‘"+ <> nameBase effName+ <> "’ has been found within the signature class data type ‘"+ <> nameBase ecName+ <> "’.\nConsider separating the first-order effect into an instruction class data type."++genNormalSender ::+ EffectOrder ->+ SenderFunctionConf ->+ EffConInfo ->+ WriterT [Dec] Q ()+genNormalSender order = genSender order send sendCxt id+ where+ (send, sendCxt) = case order of+ FirstOrder ->+ ( (VarE 'sendIns `AppE`)+ , \effDataType carrier -> ConT ''SendIns `AppT` effDataType `AppT` carrier+ )+ HigherOrder ->+ ( (VarE 'sendSig `AppE`)+ , \effDataType carrier -> ConT ''SendSig `AppT` effDataType `AppT` carrier+ )++genTaggedSender ::+ EffectOrder ->+ SenderFunctionConf ->+ EffConInfo ->+ WriterT [Dec] Q ()+genTaggedSender order conf eff = do+ nTag <- newName "tag" & lift+ let tag = VarT nTag++ (send, sendCxt) = case order of+ FirstOrder ->+ ( (VarE 'sendIns `AppE`) . (ConE 'Tag `AppTypeE` WildCardT `AppTypeE` tag `AppE`)+ , \effDataType carrier ->+ ConT ''SendIns `AppT` (ConT ''Tag `AppT` effDataType `AppT` tag) `AppT` carrier+ )+ HigherOrder ->+ ( (VarE 'sendSig `AppE`) . (ConE 'TagH `AppTypeE` WildCardT `AppTypeE` tag `AppE`)+ , \effDataType carrier ->+ ConT ''SendSig `AppT` (ConT ''TagH `AppT` effDataType `AppT` tag) `AppT` carrier+ )++ genSender order send sendCxt (PlainTV nTag SpecifiedSpec :) conf eff++genKeyedSender ::+ EffectOrder ->+ SenderFunctionConf ->+ EffConInfo ->+ WriterT [Dec] Q ()+genKeyedSender order conf eff = do+ nKey <- newName "key" & lift+ let key = VarT nKey++ (send, sendCxt) = case order of+ FirstOrder ->+ ( (VarE 'sendInsBy `AppTypeE` key `AppE`)+ , \effDataType carrier ->+ ConT ''SendInsBy `AppT` key `AppT` effDataType `AppT` carrier+ )+ HigherOrder ->+ ( (VarE 'sendSigBy `AppTypeE` key `AppE`)+ , \effDataType carrier ->+ ConT ''SendSigBy `AppT` key `AppT` effDataType `AppT` carrier+ )++ genSender order send sendCxt (PlainTV nKey SpecifiedSpec :) conf eff++genSender ::+ EffectOrder ->+ (Exp -> Exp) ->+ (TH.Type -> TH.Type -> TH.Type) ->+ ([TyVarBndrSpec] -> [TyVarBndrSpec]) ->+ SenderFunctionConf ->+ EffConInfo ->+ WriterT [Dec] Q ()+genSender order send sendCxt alterFnSigTVs conf@SenderFunctionConf{..} con@EffConInfo{..} = do+ genSenderArmor sendCxt alterFnSigTVs conf con \f -> do+ args <- replicateM (length effParamTypes) (newName "x")++ let body =+ send+ ( foldl' AppE (ConE effName) (map VarE args)+ & if _doesGenerateSenderFnSignature+ then (`SigE` ((effDataType & appCarrier) `AppT` effResultType))+ else id+ )++ appCarrier = case order of+ FirstOrder -> id+ HigherOrder -> (`AppT` f)++ pure $ Clause (map VarP args) (NormalB body) []++genSenderArmor ::+ (TH.Type -> TH.Type -> TH.Type) ->+ ([TyVarBndrSpec] -> [TyVarBndrSpec]) ->+ SenderFunctionConf ->+ EffConInfo ->+ (Type -> Q Clause) ->+ WriterT [Dec] Q ()+genSenderArmor sendCxt alterFnSigTVs SenderFunctionConf{..} EffConInfo{..} clause = do+ carrier <- maybe ((`PlainTV` ()) <$> newName "f") pure effCarrier & lift++ let f = tyVarType carrier++ fnName = mkName _senderFnName++ funSig =+ SigD+ fnName+ ( ForallT+ (effTyVars ++ [carrier $> SpecifiedSpec] & alterFnSigTVs)+ (sendCxt effDataType f : effCxt)+ (arrowChain effParamTypes (f `AppT` effResultType))+ )++ funInline = PragmaD (InlineP fnName Inline FunLike AllPhases)++ funDef <- FunD fnName <$> sequence [clause f & lift]++ -- Put documents+ lift do+ effDoc <- getDoc $ DeclDoc effName+ _senderFnDoc effDoc >>= mapM_ \doc -> do+ addModFinalizer $ putDoc (DeclDoc fnName) doc++ forM [0 .. length effParamTypes - 1] \i -> do+ argDoc <- getDoc $ ArgDoc effName i+ _senderFnArgDoc i argDoc >>= mapM_ \doc -> do+ addModFinalizer $ putDoc (ArgDoc fnName i) doc++ -- Append declerations+ when _doesGenerateSenderFnSignature $ tell [funSig]+ tell [funDef, funInline]++arrowChain :: Foldable t => t TH.Type -> TH.Type -> TH.Type+arrowChain = flip $ foldr \l r -> ArrowT `AppT` l `AppT` r++-- | A reified information of a datatype.+data DataInfo = DataInfo+ { dataCxt :: Cxt+ , dataName :: Name+ , dataTyVars :: [TyVarBndr ()]+ , dataCons :: [ConInfo]+ }++data ConInfo = ConInfo+ { conName :: Name+ , conArgs :: [BangType]+ , conGadtReturnType :: Maybe TH.Type+ , conTyVars :: [TyVarBndrSpec]+ , conCxt :: Cxt+ }++reifyEffCls :: EffectOrder -> Name -> Q (Info, DataInfo, EffClsInfo)+reifyEffCls order name = do+ info <- reify name++ dataInfo <-+ analyzeData info+ & maybe (fail $ "Not datatype: ‘" <> pprint name <> "’") pure++ effClsInfo <-+ analyzeEffCls order dataInfo+ & either (fail . T.unpack) pure++ pure (info, dataInfo, effClsInfo)++analyzeEffCls :: EffectOrder -> DataInfo -> Either T.Text EffClsInfo+analyzeEffCls order DataInfo{..} = do+ (initTyVars, resultType) <- unsnoc dataTyVars & maybeToEither "No result type variable."++ (paramVars, mCarrier) <-+ case order of+ FirstOrder -> pure (initTyVars, Nothing)+ HigherOrder -> do+ (pvs, carrier) <- unsnoc initTyVars & maybeToEither "No carrier type variable."+ pure (pvs, Just carrier)++ let analyzeEffCon :: ConInfo -> Validation [T.Text] EffConInfo+ analyzeEffCon ConInfo{..} = eitherToValidation do+ (effDataType, effCarrier, effResultType) <-+ maybe+ ( pure+ ( foldl' AppT (VarT dataName) (map tyVarType paramVars)+ , mCarrier+ , tyVarType resultType+ )+ )+ decomposeGadtReturnType+ conGadtReturnType++ let removeCarrierTV :: [TyVarBndr a] -> [TyVarBndr a]+ removeCarrierTV = case order of+ FirstOrder -> id+ HigherOrder -> filter ((tyVarName <$> effCarrier /=) . Just . tyVarName)++ effTyVars =+ if isJust conGadtReturnType+ then removeCarrierTV conTyVars+ else map (SpecifiedSpec <$) (removeCarrierTV paramVars) ++ conTyVars++ Right+ EffConInfo+ { effName = conName+ , effParamTypes = map snd conArgs+ , effDataType = effDataType+ , effResultType = effResultType+ , effTyVars = effTyVars+ , effCarrier = effCarrier+ , effCxt = conCxt+ }+ where+ decomposeGadtReturnType ::+ TH.Type -> Either [T.Text] (TH.Type, Maybe (TyVarBndr ()), TH.Type)+ decomposeGadtReturnType =+ unkindType >>> case order of+ FirstOrder ->+ \case+ ins `AppT` x -> Right (ins, Nothing, x)+ t ->+ Left+ [ "Unexpected form of GADT return type for the instruction ‘"+ <> T.pack (nameBase conName)+ <> "’: "+ <> T.pack (pprint t)+ ]+ HigherOrder -> \case+ sig `AppT` SigT (VarT f) kf `AppT` x ->+ Right (sig, Just (KindedTV f () kf), x)+ sig `AppT` VarT f `AppT` x ->+ Right (sig, Just (PlainTV f ()), x)+ t ->+ Left+ [ "Unexpected form of GADT return type for the signature ‘"+ <> T.pack (nameBase conName)+ <> "’: "+ <> T.pack (pprint t)+ ]++ effCons <-+ traverse analyzeEffCon dataCons+ & validationToEither+ & mapLeft T.unlines++ pure+ EffClsInfo+ { ecName = dataName+ , ecParamVars = paramVars+ , ecCarrier = mCarrier+ , ecEffs = effCons+ }++-- ** Generating Synonyms about LiftIns++{- |+Generate the pattern synonyms for instruction constructors:++ @pattern LBaz ... = LiftIns (Baz ...)@+-}+genLiftInsPatternSynonyms :: EffClsInfo -> Q [Dec]+genLiftInsPatternSynonyms EffClsInfo{..} = do+ patSyns <-+ forM ecEffs \EffConInfo{..} -> do+ let newConName = mkName $ 'L' : nameBase effName+ args <- replicateM (length effParamTypes) (newName "x")++ f <- VarT <$> newName "f"+ a <- VarT <$> 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|+ () =>+ ($(pure a) ~ $(pure effResultType)) =>+ $( pure $+ arrowChain+ effParamTypes+ ((ConT ''LiftIns `AppT` effDataType) `AppT` f `AppT` a)+ )+ |]+ , pure $+ PatSynD+ newConName+ (PrefixPatSyn args)+ ImplBidir+ (ConP 'LiftIns [] [ConP effName [] (VarP <$> args)])+ ]++ pure $ concatMap snd patSyns ++ [PragmaD $ CompleteP (fst <$> patSyns) Nothing]++{- |+Generate the type synonym for an instruction class datatype:++ @type (LFoobar ...) = LiftIns (Foobar ...)@+-}+genLiftInsTypeSynonym :: EffClsInfo -> Dec+genLiftInsTypeSynonym EffClsInfo{..} = do+ TySynD+ (mkName $ 'L' : nameBase ecName)+ (pvs <&> (`PlainTV` ()))+ (ConT ''LiftIns `AppT` foldl AppT (ConT ecName) (map VarT pvs))+ where+ pvs = tyVarName <$> ecParamVars++-- * Utility functions++{- The code before modification is licensed under the BSD3 License as+ shown in [1]. The modified code, in its entirety, is licensed under+ MPL 2.0. When redistributing, please ensure that you do not remove+ the BSD3 License text as indicated in [1].+ <https://hackage.haskell.org/package/effet-0.4.0.0/docs/src/Control.Effect.Machinery.TH.html>++ [1] Copyright Michael Szvetits (c) 2020++ All rights reserved.++ Redistribution and use in source and binary forms, with or without+ modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Michael Szvetits nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+-}++-- | Pures the name of a type variable.+tyVarName :: TyVarBndr a -> Name+tyVarName (PlainTV n _) = n+tyVarName (KindedTV n _ _) = n++-- | Converts a type variable to a type.+tyVarType :: TyVarBndr a -> TH.Type+tyVarType (PlainTV n _) = VarT n+tyVarType (KindedTV n _ k) = SigT (VarT n) k++-- | Throws away all kind information from a type.+unkindTypeRec :: TH.Type -> TH.Type+unkindTypeRec = \case+ ForallT vs ps t -> ForallT (fmap unkindTyVar vs) (fmap unkindTypeRec ps) (unkindTypeRec t)+ AppT l r -> AppT (unkindTypeRec l) (unkindTypeRec r)+ SigT t _ -> t+ InfixT l n r -> InfixT (unkindTypeRec l) n (unkindTypeRec r)+ UInfixT l n r -> UInfixT (unkindTypeRec l) n (unkindTypeRec r)+ ParensT t -> ParensT (unkindTypeRec t)+ AppKindT t _ -> unkindTypeRec t+ ImplicitParamT s t -> ImplicitParamT s (unkindTypeRec t)+ other -> other++unkindType :: TH.Type -> TH.Type+unkindType = \case+ SigT t _ -> 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++-- | Checks if a name m appears somewhere in a type.+occurs :: Name -> TH.Type -> Bool+occurs m = \case+ ForallT _ cxt t -> m `occurs` t || any (m `occurs`) cxt+ 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++{- The code before modification is licensed under the BSD3 License as+ shown in [1]. The modified code, in its entirety, is licensed under+ MPL 2.0. When redistributing, please ensure that you do not remove+ the BSD3 License text as indicated in [2].+ <https://github.com/pa-ba/compdata/blob/master/src/Data/Comp/Derive/Utils.hs>++ [2] Copyright (c) 2010--2011 Patrick Bahr, Tom Hvitved++ All rights reserved.++ Redistribution and use in source and binary forms, with or without+ modification, are permitted provided that the following conditions+ are met:++ 1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ 2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++ 3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+ POSSIBILITY OF SUCH DAMAGE.+-}++{- |+This function abstracts away @newtype@ declaration, it turns them into+@data@ declarations.+-}+analyzeData :: Info -> Maybe DataInfo+analyzeData = \case+ TyConI (NewtypeD cxt name args _ constr _) ->+ Just $ DataInfo cxt name args (normalizeCon constr)+ TyConI (DataD cxt name args _ constrs _) ->+ Just $ DataInfo cxt name args (concatMap normalizeCon constrs)+ _ -> Nothing++normalizeCon :: Con -> [ConInfo]+normalizeCon = \case+ ForallC vars cxt constr ->+ [con{conTyVars = vars, conCxt = cxt} | con <- normalizeNonForallCon constr]+ con -> normalizeNonForallCon con++normalizeNonForallCon :: Con -> [ConInfo]+normalizeNonForallCon = \case+ NormalC constr args -> [ConInfo constr args Nothing [] []]+ RecC constr args -> [ConInfo constr (args <&> \(_, s, t) -> (s, t)) Nothing [] []]+ InfixC a constr b -> [ConInfo constr [a, b] Nothing [] []]+ GadtC cons args typ -> [ConInfo con args (Just typ) [] [] | con <- cons]+ RecGadtC cons args typ ->+ [ConInfo con (args <&> \(_, s, t) -> (s, t)) (Just typ) [] [] | con <- cons]+ ForallC{} -> fail "Unexpected nested forall."