data-effects-th 0.2.0.0 → 0.4.0.0

raw patch · 9 files changed

+421/−715 lines, 9 filesdep ~basedep ~data-effects-coredep ~extraPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, data-effects-core, extra, mtl, template-haskell

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• Example/Driver.hs +1/−3
• Example/Example.hs +13/−14
• data-effects-th.cabal +22/−19
• src/Data/Effect/HFunctor/TH.hs +2/−6
• src/Data/Effect/HFunctor/TH/Internal.hs +5/−8
• src/Data/Effect/Key/TH.hs +0/−119
• src/Data/Effect/TH.hs +84/−143
• src/Data/Effect/TH/Internal.hs +288/−403

@@ -11,3 +11,9 @@ ## 0.2.0.0 -- 2024-10-10 * Support for the core version upgrade to 0.2.     * Support for GHC 9.8.2.++## 0.4.0.0 -- 2025-04-16++* Adopt to the new v4 interface.+    * Unified first-order and higher-order effect interfaces.+    * Added a generic `Eff` carrier type.

@@ -1,5 +1,3 @@ {-# 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/.+-- SPDX-License-Identifier: MPL-2.0

@@ -1,41 +1,40 @@ {-# 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/.+-- SPDX-License-Identifier: MPL-2.0  module Example where +import Data.Effect (Effect) import Data.Effect.HFunctor (HFunctor) import Data.Effect.HFunctor.TH (makeHFunctor, makeHFunctor')-import Data.Effect.TH (makeEffect, makeEffectH)+import Data.Effect.TH (makeEffectF, makeEffectH) import Data.Kind (Type) import Data.List.Infinite (Infinite ((:<))) -data Throw e (a :: Type) where-    Throw :: e -> Throw e a+data Throw e :: Effect where+    Throw :: e -> Throw e f a -data Catch e f (a :: Type) where+data Catch e :: Effect where     Catch :: f a -> (e -> f a) -> Catch e f a -makeEffect [''Throw] [''Catch]+makeEffectF ''Throw+makeEffectH ''Catch -data Unlift b f (a :: Type) where+data Unlift b :: Effect where     WithRunInBase :: ((forall x. f x -> b x) -> b a) -> Unlift b f a -makeEffectH [''Unlift]+makeEffectH ''Unlift -data Nested (f :: Type -> Type) (a :: Type) where+data Nested :: Effect where     Nested :: ([f a -> Int] -> Int) -> Nested f a makeHFunctor ''Nested -data ManuallyCxt (g :: Type -> Type) h (f :: Type -> Type) (a :: Type) where+data ManuallyCxt (g :: Type -> Type) h :: Effect 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+data NestedTuple :: Effect where     NestedTuple :: ((forall x. (f x, f a) -> Int) -> Int) -> NestedTuple f a makeHFunctor ''NestedTuple 

@@ -1,6 +1,6 @@-cabal-version:      2.4+cabal-version:      3.0 name:               data-effects-th-version:            0.2.0.0+version:            0.4.0.0  -- A short (one-line) description of the package. synopsis: Template Haskell utilities for the data-effects library.@@ -16,14 +16,14 @@ bug-reports: https://github.com/sayo-hs/data-effects  -- The license under which the package is released.-license:            MPL-2.0 AND BSD-3-Clause+license:            MPL-2.0 license-file:       LICENSE-author:             Sayo Koyoneda <ymdfield@outlook.jp>-maintainer:         Sayo Koyoneda <ymdfield@outlook.jp>+author:             Sayo contributors <ymdfield@outlook.jp>+maintainer:         ymdfield <ymdfield@outlook.jp>  -- A copyright notice. copyright:-    2023-2024 Sayo Koyoneda,+    2023-2025 Sayo contributors,     2020 Michael Szvetits,     2010-2011 Patrick Bahr @@ -34,24 +34,25 @@     NOTICE     README.md -tested-with:-    GHC == 9.8.2-    GHC == 9.4.1-    GHC == 9.2.8+tested-with: GHC == {9.2.8, 9.4.8, 9.6.7, 9.8.4, 9.10.1, 9.12.2} +common warnings+    ghc-options: -Wall -Wredundant-constraints+ source-repository head     type: git     location: https://github.com/sayo-hs/data-effects-    tag: v0.2.0+    tag: v0.4.0     subdir: data-effects-th  library+    import: warnings+     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:@@ -59,17 +60,17 @@     -- LANGUAGE extensions used by modules in this package.     -- other-extensions:     build-depends:-        base                    >= 4.16.4 && < 4.21,-        data-effects-core       ^>= 0.2,-        template-haskell        >= 2.18 && < 2.23,-        th-abstraction          >= 0.4 && < 0.8,+        base                    >= 4.16.4 && < 4.22,+        data-effects-core       ^>= 0.4,+        template-haskell        >= 2.18 && < 2.24,+        th-abstraction          >= 0.6 && < 0.8,         lens                    >= 5.2.3 && < 5.4,-        mtl                     >= 2.2.2 && < 2.4,-        extra                   ^>= 1.7.14,+        mtl                     >= 2.3 && < 2.4,+        extra                   >= 1.7.14 && < 1.9,         containers              >= 0.6.5 && < 0.8,         either                  ^>= 5.0.2,         text                    >= 2.0 && < 2.2,-        data-default            ^>= 0.7.1,+        data-default            >= 0.7.1 && < 0.9,         infinite-list           ^>= 0.1.1,         formatting              ^>= 7.2.0, @@ -90,6 +91,8 @@   test-suite Example+    import: warnings+     other-modules:         Example 

@@ -3,16 +3,12 @@  {-# 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/.+-- SPDX-License-Identifier: MPL-2.0  {- |-Copyright   :  (c) 2023 Sayo Koyoneda+Copyright   :  (c) 2023 Sayo contributors 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'.

@@ -4,9 +4,7 @@  {-# 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/.+-- SPDX-License-Identifier: MPL-2.0 AND BSD-3-Clause  {-  The code before modification is licensed under the BSD3 License as     shown in [1].  The modified code, in its entirety, is licensed under@@ -48,11 +46,9 @@  {- | Copyright   :  (c) 2010-2011 Patrick Bahr, Tom Hvitved-               (c) 2023 Sayo Koyoneda-License     :  MPL-2.0 (see the file LICENSE)+               (c) 2023 Sayo contributors+License     :  MPL-2.0 (see the LICENSE file) AND BSD-3-Clause Maintainer  :  ymdfield@outlook.jp-Stability   :  experimental-Portability :  portable -} module Data.Effect.HFunctor.TH.Internal where @@ -72,6 +68,7 @@ import Data.Foldable (foldl') import Data.Functor ((<&>)) import Data.List.Infinite (Infinite, prependList)+import Data.Maybe (fromMaybe) import Data.Text qualified as T import Formatting (int, sformat, shown, stext, (%)) import Language.Haskell.TH (@@ -197,7 +194,7 @@     pure         [ InstanceD             Nothing-            [cxt]+            (fromMaybe [cxt] $ decomposeTupleT cxt)             (ConT ''HFunctor `AppT` foldl' AppT (ConT name) hfArgNames)             [hfmapDecls, fnInline]         ]

@@ -1,119 +0,0 @@-{-# 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 (SendFOEBy, SendHOEBy)-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', noDeriveHFunctor)-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,- )-import Language.Haskell.TH.Datatype.TyVarBndr (pattern BndrReq)--makeKeyedEffect :: [Name] -> [Name] -> Q [Dec]-makeKeyedEffect =-    makeEffect'-        (def & changeNormalSenderFnNameFormat)-        genEffectKey-{-# INLINE makeKeyedEffect #-}--makeKeyedEffect_ :: [Name] -> [Name] -> Q [Dec]-makeKeyedEffect_ =-    makeEffect'-        (def & noDeriveHFunctor & 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` BndrReq))-            (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 ''SendFOEBy `AppT` key `AppT` effDataType `AppT` carrier-                    HigherOrder -> ConT ''SendHOEBy `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 "'"

@@ -2,172 +2,113 @@  {-# 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/.+-- SPDX-License-Identifier: MPL-2.0  {- |-Copyright   :  (c) 2023 Sayo Koyoneda+Copyright   :  (c) 2023-2025 Sayo contributors 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,-    doesGenerateLiftFOEPatternSynonyms,-    doesGenerateLiftFOETypeSynonym,     EffectConf (..),-    keyedSenderGenConf,-    normalSenderGenConf,-    taggedSenderGenConf,-    warnFirstOrderInHOE,-    SenderFunctionConf (..),-    senderFnName,-    doesGenerateSenderFnSignature,-    senderFnDoc,-    senderFnArgDoc,-    senderFnConfs,+    OpConf (..),+    keyedPerformerConf,+    normalPerformerConf,+    taggedPerformerConf,+    PerformerConf (..),+    performerName,+    doesGeneratePerformerSignature,+    performerDoc,+    performerArgDoc,+    performerConfs,     deriveHFunctor,-    noDeriveHFunctor,-    generateLiftFOETypeSynonym,-    noGenerateLiftFOETypeSynonym,-    generateLiftFOEPatternSynonyms,-    noGenerateLiftFOEPatternSynonyms,-    noGenerateNormalSenderFunction,-    noGenerateTaggedSenderFunction,-    noGenerateKeyedSenderFunction,-    suppressFirstOrderInHigherOrderEffectWarning,-    noGenerateSenderFunctionSignature,+    noGenerateNormalPerformer,+    noGenerateTaggedPerformer,+    noGenerateKeyedPerformer,+    noGeneratePerformerSignature,+    noGenerateLabel,+    noGenerateOrderInstance, ) where -import Control.Monad (forM_, when)-import Control.Monad.Writer (execWriterT, lift, tell)+import Control.Monad.Reader (ask, runReaderT)+import Control.Monad.Writer.CPS (execWriterT, lift, tell) import Data.Default (Default (def))+import Data.Effect (EffectOrder (FirstOrder, HigherOrder)) import Data.Effect.HFunctor.TH.Internal (deriveHFunctor) import Data.Effect.TH.Internal (-    DataInfo,-    EffClsInfo,-    EffectClassConf (-        EffectClassConf,-        _confByEffect,-        _doesDeriveHFunctor,-        _doesGenerateLiftFOEPatternSynonyms,-        _doesGenerateLiftFOETypeSynonym-    ),-    EffectConf (-        EffectConf,-        _keyedSenderGenConf,-        _normalSenderGenConf,-        _taggedSenderGenConf,-        _warnFirstOrderInHOE-    ),-    EffectOrder (FirstOrder, HigherOrder),-    MakeEffectConf (MakeEffectConf, unMakeEffectConf),-    SenderFunctionConf (-        _doesGenerateSenderFnSignature,-        _senderFnArgDoc,-        _senderFnDoc,-        _senderFnName-    ),-    alterEffectClassConf,-    alterEffectConf,-    confByEffect,-    doesDeriveHFunctor,-    doesGenerateLiftFOEPatternSynonyms,-    doesGenerateLiftFOETypeSynonym,-    doesGenerateSenderFnSignature,-    genLiftFOEPatternSynonyms,-    genLiftFOETypeSynonym,-    genSenders,-    generateLiftFOEPatternSynonyms,-    generateLiftFOETypeSynonym,-    keyedSenderGenConf,-    noDeriveHFunctor,-    noGenerateKeyedSenderFunction,-    noGenerateLiftFOEPatternSynonyms,-    noGenerateLiftFOETypeSynonym,-    noGenerateNormalSenderFunction,-    noGenerateSenderFunctionSignature,-    noGenerateTaggedSenderFunction,-    normalSenderGenConf,-    orderOf,-    reifyEffCls,-    senderFnArgDoc,-    senderFnConfs,-    senderFnDoc,-    senderFnName,-    suppressFirstOrderInHigherOrderEffectWarning,-    taggedSenderGenConf,-    unMakeEffectConf,-    warnFirstOrderInHOE,+    EffectConf (..),+    EffectGenerator,+    OpConf (..),+    PerformerConf (..),+    doesGeneratePerformerSignature,+    genFOE,+    genHOE,+    keyedPerformerConf,+    noGenerateKeyedPerformer,+    noGenerateLabel,+    noGenerateNormalPerformer,+    noGenerateOrderInstance,+    noGeneratePerformerSignature,+    noGenerateTaggedPerformer,+    normalPerformerConf,+    performerArgDoc,+    performerConfs,+    performerDoc,+    performerName,+    reifyEffect,+    taggedPerformerConf,  ) 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 _doesGenerateLiftFOETypeSynonym do-            genLiftFOETypeSynonym effClsInfo & singleton & tell--        when _doesGenerateLiftFOEPatternSynonyms do-            genLiftFOEPatternSynonyms 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+import Language.Haskell.TH (Dec, Name, Q, Type (TupleT)) -        extTemplate HigherOrder info dataInfo effClsInfo ecConf & lift >>= tell+makeEffectF :: Name -> Q [Dec]+makeEffectsF :: [Name] -> Q [Dec]+makeEffectF' :: EffectConf -> Name -> Q [Dec]+(makeEffectF, makeEffectsF, makeEffectF') = effectMakers genFOEwithHFunctor -noExtTemplate :: EffectOrder -> Info -> DataInfo -> EffClsInfo -> EffectClassConf -> Q [Dec]-noExtTemplate = mempty-{-# INLINE noExtTemplate #-}+makeEffectF_ :: Name -> Q [Dec]+makeEffectsF_ :: [Name] -> Q [Dec]+makeEffectF_' :: EffectConf -> Name -> Q [Dec]+(makeEffectF_, makeEffectsF_, makeEffectF_') = effectMakers genFOE -makeEffect :: [Name] -> [Name] -> Q [Dec]-makeEffect = makeEffect' def noExtTemplate-{-# INLINE makeEffect #-}+makeEffectH :: Name -> Q [Dec]+makeEffectsH :: [Name] -> Q [Dec]+makeEffectH' :: EffectConf -> Name -> Q [Dec]+(makeEffectH, makeEffectsH, makeEffectH') = effectMakers genHOEwithHFunctor -makeEffectF :: [Name] -> Q [Dec]-makeEffectF inss = makeEffect inss []-{-# INLINE makeEffectF #-}+makeEffectH_ :: Name -> Q [Dec]+makeEffectsH_ :: [Name] -> Q [Dec]+makeEffectH_' :: EffectConf -> Name -> Q [Dec]+(makeEffectH_, makeEffectsH_, makeEffectH_') = effectMakers genHOE -makeEffectH :: [Name] -> Q [Dec]-makeEffectH sigs = makeEffect [] sigs-{-# INLINE makeEffectH #-}+effectMakers+    :: EffectGenerator+    -> ( Name -> Q [Dec]+       , [Name] -> Q [Dec]+       , EffectConf -> Name -> Q [Dec]+       )+effectMakers gen =+    ( execWriterT . gen' def+    , execWriterT . mapM (gen' def)+    , \conf -> execWriterT . gen' conf+    )+  where+    gen' conf e = do+        (info, dataInfo, eInfo) <- reifyEffect e & lift+        runReaderT gen (conf, e, info, dataInfo, eInfo) -makeEffect_ :: [Name] -> [Name] -> Q [Dec]-makeEffect_ = makeEffect' (def & noDeriveHFunctor) noExtTemplate-{-# INLINE makeEffect_ #-}+genFOEwithHFunctor :: EffectGenerator+genFOEwithHFunctor = do+    genFOE+    (_, _, _, dataInfo, _) <- ask+    deriveHFunctor (const $ pure $ TupleT 0) dataInfo & lift & lift >>= tell -makeEffectH_ :: [Name] -> Q [Dec]-makeEffectH_ sigs = makeEffect_ [] sigs-{-# INLINE makeEffectH_ #-}+genHOEwithHFunctor :: EffectGenerator+genHOEwithHFunctor = do+    genHOE+    (_, _, _, dataInfo, _) <- ask+    deriveHFunctor (const $ pure $ TupleT 0) dataInfo & lift & lift >>= tell

@@ -2,64 +2,33 @@ {-# 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/.+-- SPDX-License-Identifier: MPL-2.0 AND BSD-3-Clause  {- |-Copyright   :  (c) 2023-2024 Sayo Koyoneda+Copyright   :  (c) 2023-2025 Sayo contributors                (c) 2010-2011 Patrick Bahr, Tom Hvitved                (c) 2020 Michael Szvetits-License     :  MPL-2.0 (see the file LICENSE)+License     :  MPL-2.0 (see the LICENSE file) AND BSD-3-Clause 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 (SendFOE, SendHOE, sendFOE, sendHOE)-import Control.Effect.Key (SendFOEBy, SendHOEBy, sendFOEBy, sendHOEBy)-import Control.Monad.Writer (WriterT, execWriterT, lift, tell)+import Control.Effect (Eff, Free, perform, perform', perform'', send)+import Control.Lens (Traversal', makeLenses, (%~), (.~), _head)+import Control.Monad (forM, forM_, replicateM, when)+import Control.Monad.Reader (ReaderT, ask)+import Control.Monad.Writer.CPS (WriterT, execWriterT, lift, tell) import Data.Char (toLower) import Data.Default (Default, def)-import Data.Effect (LiftFOE (LiftFOE))-import Data.Effect.Tag (Tag (Tag), TagH (TagH))+import Data.Effect (EffectOrder (FirstOrder, HigherOrder), FirstOrder, LabelOf, OrderOf)+import Data.Effect.OpenUnion (Has, In, (:>))+import Data.Effect.Tag (Tagged) import Data.Either.Extra (mapLeft, maybeToEither) import Data.Either.Validation (Validation, eitherToValidation, validationToEither) import Data.Function ((&)) import Data.Functor (($>), (<&>))+import Data.List (foldl', uncons) import Data.List.Extra (unsnoc) import Data.Maybe (fromJust, isJust) import Data.Text qualified as T@@ -68,337 +37,324 @@     Body (NormalB),     Clause (Clause),     Con (ForallC, GadtC, InfixC, NormalC, RecC, RecGadtC),-    Dec (DataD, FunD, NewtypeD, PatSynD, PragmaD, TySynD),+    Dec (DataD, FunD, NewtypeD, PragmaD),     DocLoc (ArgDoc, DeclDoc),     Exp (AppE, AppTypeE, ConE, SigE, VarE),     Info (TyConI),     Inline (Inline),-    Pat (ConP, VarP),-    PatSynArgs (PrefixPatSyn),-    PatSynDir (ImplBidir),+    Pat (VarP),     Phases (AllPhases),-    Pragma (CompleteP, InlineP),+    Pragma (InlineP),     RuleMatch (FunLike),     Specificity (SpecifiedSpec),     TyVarBndr (..),     TyVarBndrSpec,-    Type (TupleT, WildCardT),+    Type,+    conT,     getDoc,     mkName,-    patSynSigD,     pprint,     putDoc,-    reportWarning,+    varT,  ) import Language.Haskell.TH qualified as TH-import Language.Haskell.TH.Datatype.TyVarBndr (pattern BndrReq)+import Language.Haskell.TH.Syntax (+    Cxt,+    Dec (SigD),+    Name,+    Q,+    Quote (newName),+    Type (+        AppKindT,+        AppT,+        ArrowT,+        ConT,+        ForallT,+        ImplicitParamT,+        InfixT,+        ParensT,+        PromotedT,+        SigT,+        UInfixT,+        VarT+    ),+    addModFinalizer,+    nameBase,+    reify,+ ) -data EffClsInfo = EffClsInfo-    { ecName :: Name-    , ecParamVars :: [TyVarBndr ()]-    , ecCarrier :: Maybe (TyVarBndr ())-    , ecEffs :: [EffConInfo]+data EffectInfo = EffectInfo+    { eName :: Name+    , eParamVars :: [TyVarBndr ()]+    , eCarrier :: TyVarBndr ()+    , eOps :: [OpInfo]     } -data EffConInfo = EffConInfo-    { effName :: Name-    , effParamTypes :: [TH.Type]-    , effDataType :: TH.Type-    , effResultType :: TH.Type-    , effTyVars :: [TyVarBndrSpec]-    , effCarrier :: Maybe (TyVarBndr ())-    , effCxt :: Cxt+data OpInfo = OpInfo+    { opName :: Name+    , opParamTypes :: [TH.Type]+    , opDataType :: TH.Type+    , opResultType :: TH.Type+    , opTyVars :: [TyVarBndrSpec]+    , opCarrier :: TyVarBndr ()+    , opCxt :: Cxt+    , opOrder :: EffectOrder     } --- | 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-    , _doesGenerateLiftFOETypeSynonym :: Bool-    , _doesGenerateLiftFOEPatternSynonyms :: Bool+data EffectConf = EffectConf+    { opConf :: Name -> OpConf+    , doesGenerateLabel :: Bool+    , doesGenerateOrderInstance :: Bool     } -data EffectConf = EffectConf-    { _normalSenderGenConf :: Maybe SenderFunctionConf-    , _taggedSenderGenConf :: Maybe SenderFunctionConf-    , _keyedSenderGenConf :: Maybe SenderFunctionConf-    , _warnFirstOrderInHOE :: Bool+alterOpConf :: (OpConf -> OpConf) -> EffectConf -> EffectConf+alterOpConf f conf = conf{opConf = f . opConf conf}++data OpConf = OpConf+    { _normalPerformerConf :: Maybe PerformerConf+    , _keyedPerformerConf :: Maybe PerformerConf+    , _taggedPerformerConf :: Maybe PerformerConf+    , _senderConf :: Maybe PerformerConf     } -data SenderFunctionConf = SenderFunctionConf-    { _senderFnName :: String-    , _doesGenerateSenderFnSignature :: Bool-    , _senderFnDoc :: Maybe String -> Q (Maybe String)-    , _senderFnArgDoc :: Int -> Maybe String -> Q (Maybe String)+data PerformerConf = PerformerConf+    { _performerName :: String+    , _doesGeneratePerformerSignature :: Bool+    , _performerDoc :: Maybe String -> Q (Maybe String)+    , _performerArgDoc :: 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+performerConfs :: Traversal' OpConf PerformerConf+performerConfs f OpConf{..} = do+    normal <- traverse f _normalPerformerConf+    keyed <- traverse f _keyedPerformerConf+    tagged <- traverse f _taggedPerformerConf+    sender <- traverse f _senderConf     pure-        EffectConf-            { _normalSenderGenConf = normal-            , _taggedSenderGenConf = tagged-            , _keyedSenderGenConf = keyed-            , _warnFirstOrderInHOE+        OpConf+            { _normalPerformerConf = normal+            , _keyedPerformerConf = keyed+            , _taggedPerformerConf = tagged+            , _senderConf = sender             } -makeLenses ''EffectClassConf-makeLenses ''EffectConf-makeLenses ''SenderFunctionConf--deriveHFunctor :: MakeEffectConf -> MakeEffectConf-deriveHFunctor = alterEffectClassConf $ doesDeriveHFunctor .~ True-{-# INLINE deriveHFunctor #-}--noDeriveHFunctor :: MakeEffectConf -> MakeEffectConf-noDeriveHFunctor = alterEffectClassConf $ doesDeriveHFunctor .~ False-{-# INLINE noDeriveHFunctor #-}--generateLiftFOETypeSynonym :: MakeEffectConf -> MakeEffectConf-generateLiftFOETypeSynonym = alterEffectClassConf $ doesGenerateLiftFOETypeSynonym .~ True-{-# INLINE generateLiftFOETypeSynonym #-}--noGenerateLiftFOETypeSynonym :: MakeEffectConf -> MakeEffectConf-noGenerateLiftFOETypeSynonym = alterEffectClassConf $ doesGenerateLiftFOETypeSynonym .~ False-{-# INLINE noGenerateLiftFOETypeSynonym #-}--generateLiftFOEPatternSynonyms :: MakeEffectConf -> MakeEffectConf-generateLiftFOEPatternSynonyms = alterEffectClassConf $ doesGenerateLiftFOEPatternSynonyms .~ True-{-# INLINE generateLiftFOEPatternSynonyms #-}--noGenerateLiftFOEPatternSynonyms :: MakeEffectConf -> MakeEffectConf-noGenerateLiftFOEPatternSynonyms =-    alterEffectClassConf $ doesGenerateLiftFOEPatternSynonyms .~ False-{-# INLINE noGenerateLiftFOEPatternSynonyms #-}+makeLenses ''OpConf+makeLenses ''PerformerConf -noGenerateNormalSenderFunction :: MakeEffectConf -> MakeEffectConf-noGenerateNormalSenderFunction = alterEffectConf $ normalSenderGenConf .~ Nothing-{-# INLINE noGenerateNormalSenderFunction #-}+noGenerateNormalPerformer :: EffectConf -> EffectConf+noGenerateNormalPerformer = alterOpConf $ normalPerformerConf .~ Nothing+{-# INLINE noGenerateNormalPerformer #-} -noGenerateTaggedSenderFunction :: MakeEffectConf -> MakeEffectConf-noGenerateTaggedSenderFunction = alterEffectConf $ taggedSenderGenConf .~ Nothing-{-# INLINE noGenerateTaggedSenderFunction #-}+noGenerateKeyedPerformer :: EffectConf -> EffectConf+noGenerateKeyedPerformer = alterOpConf $ keyedPerformerConf .~ Nothing+{-# INLINE noGenerateKeyedPerformer #-} -noGenerateKeyedSenderFunction :: MakeEffectConf -> MakeEffectConf-noGenerateKeyedSenderFunction = alterEffectConf $ keyedSenderGenConf .~ Nothing-{-# INLINE noGenerateKeyedSenderFunction #-}+noGenerateTaggedPerformer :: EffectConf -> EffectConf+noGenerateTaggedPerformer = alterOpConf $ taggedPerformerConf .~ Nothing+{-# INLINE noGenerateTaggedPerformer #-} -suppressFirstOrderInHigherOrderEffectWarning :: MakeEffectConf -> MakeEffectConf-suppressFirstOrderInHigherOrderEffectWarning = alterEffectConf $ warnFirstOrderInHOE .~ False-{-# INLINE suppressFirstOrderInHigherOrderEffectWarning #-}+noGeneratePerformerSignature :: EffectConf -> EffectConf+noGeneratePerformerSignature =+    alterOpConf $ performerConfs %~ doesGeneratePerformerSignature .~ False+{-# INLINE noGeneratePerformerSignature #-} -noGenerateSenderFunctionSignature :: MakeEffectConf -> MakeEffectConf-noGenerateSenderFunctionSignature =-    alterEffectConf $ senderFnConfs %~ doesGenerateSenderFnSignature .~ False-{-# INLINE noGenerateSenderFunctionSignature #-}+noGenerateLabel :: EffectConf -> EffectConf+noGenerateLabel conf = conf{doesGenerateLabel = False}+{-# INLINE noGenerateLabel #-} -instance Default MakeEffectConf where-    def = MakeEffectConf $ const $ pure def-    {-# INLINE def #-}+noGenerateOrderInstance :: EffectConf -> EffectConf+noGenerateOrderInstance conf = conf{doesGenerateOrderInstance = False}+{-# INLINE noGenerateOrderInstance #-} -instance Default EffectClassConf where+instance Default EffectConf where     def =-        EffectClassConf-            { _confByEffect = \effConName ->-                let normalSenderFnConf =-                        SenderFunctionConf-                            { _senderFnName =-                                let effConName' = nameBase effConName-                                 in if head effConName' == ':'-                                        then tail effConName'+        EffectConf+            { opConf = \opName ->+                let conf =+                        PerformerConf+                            { _performerName =+                                let effConName' = nameBase opName+                                    (opNameInitial, opNameTail) = fromJust $ uncons effConName'+                                 in if opNameInitial == ':'+                                        then opNameTail                                         else effConName' & _head %~ toLower-                            , _doesGenerateSenderFnSignature = True-                            , _senderFnDoc = pure-                            , _senderFnArgDoc = const pure+                            , _doesGeneratePerformerSignature = True+                            , _performerDoc = pure+                            , _performerArgDoc = const pure                             }-                 in EffectConf-                        { _normalSenderGenConf = Just normalSenderFnConf-                        , _taggedSenderGenConf =-                            Just $ normalSenderFnConf & senderFnName %~ (++ "'")-                        , _keyedSenderGenConf =-                            Just $ normalSenderFnConf & senderFnName %~ (++ "''")-                        , _warnFirstOrderInHOE = True+                 in OpConf+                        { _normalPerformerConf = Just conf+                        , _keyedPerformerConf =+                            Just $ conf & performerName %~ (++ "'")+                        , _taggedPerformerConf =+                            Just $ conf & performerName %~ (++ "''")+                        , _senderConf =+                            Just $ conf & performerName %~ (++ "'_")                         }-            , _doesDeriveHFunctor = True-            , _doesGenerateLiftFOETypeSynonym = True-            , _doesGenerateLiftFOEPatternSynonyms = True+            , doesGenerateLabel = True+            , doesGenerateOrderInstance = True             } -genSenders :: EffectClassConf -> EffClsInfo -> Q [Dec]-genSenders EffectClassConf{..} ec@EffClsInfo{..} = do-    let order = orderOf ec+type EffectGenerator =+    ReaderT (EffectConf, Name, Info, DataInfo, EffectInfo) (WriterT [Dec] Q) () -    execWriterT $ forM ecEffs \con@EffConInfo{..} -> do-        let EffectConf{..} = _confByEffect effName+genEffect, genFOE, genHOE :: EffectGenerator+genEffect = do+    (conf, _, _, _, eInfo) <- ask+    genPerformers conf eInfo & lift & lift >>= tell+    genLabel conf eInfo & lift & lift >>= tell+genFOE = do+    genEffect+    (conf, _, _, _, EffectInfo{..}) <- ask+    let eData = foldl AppT (ConT eName) (map (VarT . tyVarName) eParamVars)+    when (doesGenerateOrderInstance conf) do+        [d|type instance OrderOf $(pure eData) = 'FirstOrder|] & lift & lift >>= tell+        [d|instance FirstOrder $(pure eData)|] & lift & lift >>= tell+genHOE = do+    genEffect+    (conf, _, _, _, EffectInfo{..}) <- ask+    let eData = foldl AppT (ConT eName) (map (VarT . tyVarName) eParamVars)+    when (doesGenerateOrderInstance conf) do+        [d|type instance OrderOf $(pure eData) = 'HigherOrder|] & lift & lift >>= tell -        forM_ _normalSenderGenConf \conf -> genNormalSender order conf con-        forM_ _taggedSenderGenConf \conf -> genTaggedSender order conf con-        forM_ _keyedSenderGenConf \conf -> genKeyedSender order conf con+genPerformers :: EffectConf -> EffectInfo -> Q [Dec]+genPerformers EffectConf{..} EffectInfo{..} = do+    execWriterT $ forM eOps \con@OpInfo{..} -> do+        let OpConf{..} = opConf opName -        -- Check for First Order in Higher Order effect warning-        when (_warnFirstOrderInHOE && order == HigherOrder) do-            let isHigherOrderEffect = any (tyVarName (fromJust effCarrier) `occurs`) effParamTypes+        forM_ _normalPerformerConf (genNormalPerformer con)+        forM_ _keyedPerformerConf (genKeyedPerformer con)+        forM_ _taggedPerformerConf (genTaggedPerformer con)+        forM_ _senderConf (genSender con) -            unless isHigherOrderEffect do-                lift $-                    reportWarning $-                        "The first-order operation ‘"-                            <> nameBase effName-                            <> "’ has been found within the higher-order effect data type ‘"-                            <> nameBase ecName-                            <> "’.\nConsider separating the first-order operation into an first-order effect data type."+genLabel :: EffectConf -> EffectInfo -> Q [Dec]+genLabel EffectConf{..} EffectInfo{..} =+    execWriterT $ when doesGenerateLabel do+        let labelData = mkName $ nameBase eName ++ "Label"+            eData = foldl AppT (ConT eName) (map (VarT . tyVarName) eParamVars) -genNormalSender-    :: EffectOrder-    -> SenderFunctionConf-    -> EffConInfo-    -> WriterT [Dec] Q ()-genNormalSender order = genSender order send sendCxt id-  where-    (send, sendCxt) = case order of-        FirstOrder ->-            ( (VarE 'sendFOE `AppE`)-            , \effDataType carrier -> ConT ''SendFOE `AppT` effDataType `AppT` carrier-            )-        HigherOrder ->-            ( (VarE 'sendHOE `AppE`)-            , \effDataType carrier -> ConT ''SendHOE `AppT` effDataType `AppT` carrier-            )+        [DataD [] labelData [] Nothing [] []] & tell+        [d|type instance LabelOf $(pure eData) = $(conT labelData)|] & lift >>= tell -genTaggedSender-    :: EffectOrder-    -> SenderFunctionConf-    -> EffConInfo+genNormalPerformer+    :: OpInfo+    -> PerformerConf     -> WriterT [Dec] Q ()-genTaggedSender order conf eff = do-    nTag <- newName "tag" & lift-    let tag = VarT nTag--        (send, sendCxt) = case order of-            FirstOrder ->-                ( (VarE 'sendFOE `AppE`) . (ConE 'Tag `AppTypeE` WildCardT `AppTypeE` tag `AppE`)-                , \effDataType carrier ->-                    ConT ''SendFOE `AppT` (ConT ''Tag `AppT` effDataType `AppT` tag) `AppT` carrier-                )-            HigherOrder ->-                ( (VarE 'sendHOE `AppE`) . (ConE 'TagH `AppTypeE` WildCardT `AppTypeE` tag `AppE`)-                , \effDataType carrier ->-                    ConT ''SendHOE `AppT` (ConT ''TagH `AppT` effDataType `AppT` tag) `AppT` carrier-                )--    genSender order send sendCxt (PlainTV nTag SpecifiedSpec :) conf eff+genNormalPerformer =+    genPerformer+        (VarE 'perform `AppE`)+        (\opDataType es -> InfixT opDataType ''(:>) es)+        id -genKeyedSender-    :: EffectOrder-    -> SenderFunctionConf-    -> EffConInfo+genKeyedPerformer+    :: OpInfo+    -> PerformerConf     -> WriterT [Dec] Q ()-genKeyedSender order conf eff = do+genKeyedPerformer eff conf = do     nKey <- newName "key" & lift     let key = VarT nKey -        (send, sendCxt) = case order of-            FirstOrder ->-                ( (VarE 'sendFOEBy `AppTypeE` key `AppE`)-                , \effDataType carrier ->-                    ConT ''SendFOEBy `AppT` key `AppT` effDataType `AppT` carrier-                )-            HigherOrder ->-                ( (VarE 'sendHOEBy `AppTypeE` key `AppE`)-                , \effDataType carrier ->-                    ConT ''SendHOEBy `AppT` key `AppT` effDataType `AppT` carrier-                )+    genPerformer+        (VarE 'perform' `AppTypeE` key `AppE`)+        ( \opDataType es ->+            ConT ''Has `AppT` key `AppT` opDataType `AppT` es+        )+        (PlainTV nKey SpecifiedSpec :)+        eff+        conf -    genSender order send sendCxt (PlainTV nKey SpecifiedSpec :) conf eff+genTaggedPerformer+    :: OpInfo+    -> PerformerConf+    -> WriterT [Dec] Q ()+genTaggedPerformer conf eff = do+    nTag <- newName "tag" & lift+    let tag = VarT nTag +    genPerformer+        (VarE 'perform'' `AppTypeE` tag `AppE`)+        ( \opDataType es ->+            InfixT (ConT ''Tagged `AppT` tag `AppT` opDataType) ''(:>) es+        )+        (PlainTV nTag SpecifiedSpec :)+        conf+        eff+ genSender-    :: EffectOrder-    -> (Exp -> Exp)+    :: OpInfo+    -> PerformerConf+    -> WriterT [Dec] Q ()+genSender =+    genPerformer+        (VarE 'send `AppE`)+        (\opDataType es -> InfixT opDataType ''In es)+        id++genPerformer+    :: (Exp -> Exp)     -> (TH.Type -> TH.Type -> TH.Type)     -> ([TyVarBndrSpec] -> [TyVarBndrSpec])-    -> SenderFunctionConf-    -> EffConInfo+    -> OpInfo+    -> PerformerConf     -> 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")+genPerformer performer performCxt alterFnSigTVs con@OpInfo{..} conf@PerformerConf{..} = do+    genPerformerArmor performCxt alterFnSigTVs con conf \f -> do+        args <- replicateM (length opParamTypes) (newName "x")          let body =-                send-                    ( foldl' AppE (ConE effName) (map VarE args)-                        & if _doesGenerateSenderFnSignature-                            then (`SigE` ((effDataType & appCarrier) `AppT` effResultType))+                performer+                    ( foldl' AppE (ConE opName) (map VarE args)+                        & if _doesGeneratePerformerSignature+                            then (`SigE` ((opDataType `AppT` f) `AppT` opResultType))                             else id                     ) -            appCarrier = case order of-                FirstOrder -> id-                HigherOrder -> (`AppT` f)-         pure $ Clause (map VarP args) (NormalB body) [] -genSenderArmor+genPerformerArmor     :: (TH.Type -> TH.Type -> TH.Type)     -> ([TyVarBndrSpec] -> [TyVarBndrSpec])-    -> SenderFunctionConf-    -> EffConInfo+    -> OpInfo+    -> PerformerConf     -> (Type -> Q Clause)     -> WriterT [Dec] Q ()-genSenderArmor sendCxt alterFnSigTVs SenderFunctionConf{..} EffConInfo{..} clause = do-    carrier <- maybe ((`PlainTV` ()) <$> newName "f") pure effCarrier & lift+genPerformerArmor performCxt alterFnSigTVs OpInfo{..} PerformerConf{..} clause = do+    let carrier = tyVarType opCarrier -    let f = tyVarType carrier+    free <- newName "ff" & lift+    es <- newName "es" & lift+    c <- newName "c" & lift+    freeCxt <- [t|Free $(varT c) $(varT free)|] & lift+    carrierCxt <- [t|$(pure carrier) ~ Eff $(varT free) $(varT es)|] & lift -        fnName = mkName _senderFnName+    let fnName = mkName _performerName          funSig =             SigD                 fnName                 ( ForallT-                    (effTyVars ++ [carrier $> SpecifiedSpec] & alterFnSigTVs)-                    (sendCxt effDataType f : effCxt)-                    (arrowChain effParamTypes (f `AppT` effResultType))+                    (opTyVars ++ (opCarrier $> SpecifiedSpec) : map (\n -> PlainTV n () $> SpecifiedSpec) [es, free, c] & alterFnSigTVs)+                    (freeCxt : carrierCxt : performCxt opDataType (VarT es) : opCxt)+                    (arrowChain opParamTypes (carrier `AppT` opResultType))                 )          funInline = PragmaD (InlineP fnName Inline FunLike AllPhases) -    funDef <- FunD fnName <$> sequence [clause f & lift]+    funDef <- FunD fnName <$> sequence [clause carrier & lift]      -- Put documents-    lift do-        effDoc <- getDoc $ DeclDoc effName-        _senderFnDoc effDoc >>= mapM_ \doc -> do-            addModFinalizer $ putDoc (DeclDoc fnName) doc+    lift $ addModFinalizer do+        effDoc <- getDoc $ DeclDoc opName+        _performerDoc effDoc >>= mapM_ \doc -> do+            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+        forM_ [0 .. length opParamTypes - 1] \i -> do+            argDoc <- getDoc $ ArgDoc opName i+            _performerArgDoc i argDoc >>= mapM_ \doc -> do+                putDoc (ArgDoc fnName i) doc      -- Append declerations-    when _doesGenerateSenderFnSignature $ tell [funSig]+    when _doesGeneratePerformerSignature $ tell [funSig]     tell [funDef, funInline]  arrowChain :: (Foldable t) => t TH.Type -> TH.Type -> TH.Type@@ -420,8 +376,8 @@     , conCxt :: Cxt     } -reifyEffCls :: EffectOrder -> Name -> Q (Info, DataInfo, EffClsInfo)-reifyEffCls order name = do+reifyEffect :: Name -> Q (Info, DataInfo, EffectInfo)+reifyEffect name = do     info <- reify name      dataInfo <-@@ -429,29 +385,23 @@             & maybe (fail $ "Not datatype: ‘" <> pprint name <> "’") pure      effClsInfo <--        analyzeEffCls order dataInfo+        analyzeEffect dataInfo             & either (fail . T.unpack) pure      pure (info, dataInfo, effClsInfo) -analyzeEffCls :: EffectOrder -> DataInfo -> Either T.Text EffClsInfo-analyzeEffCls order DataInfo{..} = do+analyzeEffect :: DataInfo -> Either T.Text EffectInfo+analyzeEffect 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)+    (paramVars, carrier) <- unsnoc initTyVars & maybeToEither "No carrier type variable." -    let analyzeEffCon :: ConInfo -> Validation [T.Text] EffConInfo-        analyzeEffCon ConInfo{..} = eitherToValidation do-            (effDataType, effCarrier, effResultType) <-+    let analyzeOp :: ConInfo -> Validation [T.Text] OpInfo+        analyzeOp ConInfo{..} = eitherToValidation do+            (opDataType, opCarrier, opResultType) <-                 maybe                     ( pure                         ( foldl' AppT (VarT dataName) (map tyVarType paramVars)-                        , mCarrier+                        , carrier                         , tyVarType resultType                         )                     )@@ -459,123 +409,58 @@                     conGadtReturnType              let removeCarrierTV :: [TyVarBndr a] -> [TyVarBndr a]-                removeCarrierTV = case order of-                    FirstOrder -> id-                    HigherOrder -> filter ((tyVarName <$> effCarrier /=) . Just . tyVarName)+                removeCarrierTV = filter ((tyVarName opCarrier /=) . tyVarName) -                effTyVars =+                opTyVars =                     if isJust conGadtReturnType                         then removeCarrierTV conTyVars                         else map (SpecifiedSpec <$) (removeCarrierTV paramVars) ++ conTyVars +                opParamTypes = map snd conArgs+             Right-                EffConInfo-                    { effName = conName-                    , effParamTypes = map snd conArgs-                    , effDataType = effDataType-                    , effResultType = effResultType-                    , effTyVars = effTyVars-                    , effCarrier = effCarrier-                    , effCxt = conCxt+                OpInfo+                    { opName = conName+                    , opParamTypes = opParamTypes+                    , opDataType = opDataType+                    , opResultType = opResultType+                    , opTyVars = opTyVars+                    , opCarrier = opCarrier+                    , opCxt = conCxt+                    , opOrder =+                        if any (tyVarName opCarrier `occurs`) opParamTypes+                            then HigherOrder+                            else FirstOrder                     }           where             decomposeGadtReturnType-                :: TH.Type -> Either [T.Text] (TH.Type, Maybe (TyVarBndr ()), TH.Type)+                :: TH.Type -> Either [T.Text] (TH.Type, 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 first-order operation ‘"-                                        <> 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 higher-order operation ‘"-                                    <> T.pack (nameBase conName)-                                    <> "’: "-                                    <> T.pack (pprint t)-                                ]+                unkindType >>> \case+                    e `AppT` SigT (VarT f) kf `AppT` x ->+                        Right (e, KindedTV f () kf, x)+                    e `AppT` VarT f `AppT` x ->+                        Right (e, PlainTV f (), x)+                    t ->+                        Left+                            [ "Unexpected form of GADT return type for the higher-order operation ‘"+                                <> T.pack (nameBase conName)+                                <> "’: "+                                <> T.pack (pprint t)+                            ]      effCons <--        traverse analyzeEffCon dataCons+        traverse analyzeOp dataCons             & validationToEither             & mapLeft T.unlines      pure-        EffClsInfo-            { ecName = dataName-            , ecParamVars = paramVars-            , ecCarrier = mCarrier-            , ecEffs = effCons+        EffectInfo+            { eName = dataName+            , eParamVars = paramVars+            , eCarrier = carrier+            , eOps = effCons             }---- ** Generating Synonyms about LiftFOE--{- |-Generate the pattern synonyms for operation constructors:--    @pattern LBaz ... = LiftFOE (Baz ...)@--}-genLiftFOEPatternSynonyms :: EffClsInfo -> Q [Dec]-genLiftFOEPatternSynonyms 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 $ foldl AppT (TupleT (length effCxt)) effCxt)-                               )-                            => $( pure $-                                    arrowChain-                                        effParamTypes-                                        ((ConT ''LiftFOE `AppT` effDataType) `AppT` f `AppT` a)-                                )-                            |]-                    , pure $-                        PatSynD-                            newConName-                            (PrefixPatSyn args)-                            ImplBidir-                            (ConP 'LiftFOE [] [ConP effName [] (VarP <$> args)])-                    ]--    pure $ concatMap snd patSyns ++ [PragmaD $ CompleteP (fst <$> patSyns) Nothing]--{- |-Generate the type synonym for an first-order effect datatype:--    @type (LFoobar ...) = LiftFOE (Foobar ...)@--}-genLiftFOETypeSynonym :: EffClsInfo -> Dec-genLiftFOETypeSynonym EffClsInfo{..} = do-    TySynD-        (mkName $ 'L' : nameBase ecName)-        (pvs <&> (`PlainTV` BndrReq))-        (ConT ''LiftFOE `AppT` foldl AppT (ConT ecName) (map VarT pvs))-  where-    pvs = tyVarName <$> ecParamVars  -- * Utility functions