diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -5,5 +5,9 @@ * Initial public release. ## 0.1.1.0 -- 2024-09-01 -* Fix an issue where constraints in the effect constructor were not properly reflected in 'genLiftInsPatternSynonyms'. +* Fix an issue where constraints in the effect constructor were not properly reflected in 'genLiftFOEPatternSynonyms'. * Fixed an issue where the auto-generation would fail when the name of the effect constructor started with a colon (:) operator. + +## 0.2.0.0 -- 2024-10-10 +* Support for the core version upgrade to 0.2. + * Support for GHC 9.8.2. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -13,10 +13,13 @@ ## Your contributions are welcome! Please see [CONTRIBUTING.md](https://github.com/sayo-hs/data-effects/blob/ef706ef3fa547de01ce6bb5636af911354e53b58/CONTRIBUTING.md). -## Credits -Parts of this project have been adapted or inspired by the following resources: +## Acknowledgements, citations, and related work +The following is a non-exhaustive list of people and works that have had a significant impact, directly or indirectly, on its design and implementation: -* **[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. +- Casper Bach Poulsen and Cas van der Rest — [Hefty Algebras: Modular Elaboration of Higher-Order Algebraic Effects][casper:hefty] +- Patrick Bahr and Tom Hvitved — [`compdata`: Compositional Data Types][gh:compdata] +- Michael Szvetits — [`effet`][gh:effet] + +[casper:hefty]: https://dl.acm.org/doi/10.1145/3571255 +[gh:compdata]: https://github.com/pa-ba/compdata +[gh:effet]: https://github.com/typedbyte/effet diff --git a/data-effects-th.cabal b/data-effects-th.cabal --- a/data-effects-th.cabal +++ b/data-effects-th.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: data-effects-th -version: 0.1.2.0 +version: 0.2.0.0 -- A short (one-line) description of the package. synopsis: Template Haskell utilities for the data-effects library. @@ -16,31 +16,33 @@ bug-reports: https://github.com/sayo-hs/data-effects -- The license under which the package is released. -license: MPL-2.0 +license: MPL-2.0 AND BSD-3-Clause license-file: LICENSE -author: Yamada Ryo -maintainer: Yamada Ryo +author: Sayo Koyoneda +maintainer: Sayo Koyoneda -- A copyright notice. copyright: - 2023 Yamada Ryo, + 2023-2024 Sayo Koyoneda, 2020 Michael Szvetits, 2010-2011 Patrick Bahr category: Control, Effect, Template Haskell -extra-source-files: +extra-doc-files: ChangeLog.md NOTICE README.md tested-with: + GHC == 9.8.2 + GHC == 9.4.1 GHC == 9.2.8 source-repository head type: git location: https://github.com/sayo-hs/data-effects - tag: v0.1.0 + tag: v0.2.0 subdir: data-effects-th library @@ -57,14 +59,14 @@ -- 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, + base >= 4.16.4 && < 4.21, + data-effects-core ^>= 0.2, + template-haskell >= 2.18 && < 2.23, + th-abstraction >= 0.4 && < 0.8, + lens >= 5.2.3 && < 5.4, + mtl >= 2.2.2 && < 2.4, extra ^>= 1.7.14, - containers ^>= 0.6.5, + containers >= 0.6.5 && < 0.8, either ^>= 5.0.2, text >= 2.0 && < 2.2, data-default ^>= 0.7.1, @@ -83,7 +85,8 @@ BlockArguments, FunctionalDependencies, RecordWildCards, - DefaultSignatures + DefaultSignatures, + PatternSynonyms test-suite Example @@ -96,7 +99,7 @@ data-effects-th, base, data-effects-core, - tasty ^>= 1.4, + tasty >= 1.4 && < 1.6, tasty-hunit ^>= 0.10, data-default, infinite-list, diff --git a/src/Data/Effect/HFunctor/TH.hs b/src/Data/Effect/HFunctor/TH.hs --- a/src/Data/Effect/HFunctor/TH.hs +++ b/src/Data/Effect/HFunctor/TH.hs @@ -8,7 +8,7 @@ -- file, You can obtain one at https://mozilla.org/MPL/2.0/. {- | -Copyright : (c) 2023 Yamada Ryo +Copyright : (c) 2023 Sayo Koyoneda License : MPL-2.0 (see the file LICENSE) Maintainer : ymdfield@outlook.jp Stability : experimental diff --git a/src/Data/Effect/HFunctor/TH/Internal.hs b/src/Data/Effect/HFunctor/TH/Internal.hs --- a/src/Data/Effect/HFunctor/TH/Internal.hs +++ b/src/Data/Effect/HFunctor/TH/Internal.hs @@ -48,7 +48,7 @@ {- | Copyright : (c) 2010-2011 Patrick Bahr, Tom Hvitved - (c) 2023 Yamada Ryo + (c) 2023 Sayo Koyoneda License : MPL-2.0 (see the file LICENSE) Maintainer : ymdfield@outlook.jp Stability : experimental diff --git a/src/Data/Effect/Key/TH.hs b/src/Data/Effect/Key/TH.hs --- a/src/Data/Effect/Key/TH.hs +++ b/src/Data/Effect/Key/TH.hs @@ -7,14 +7,14 @@ module Data.Effect.Key.TH where -import Control.Effect.Key (SendInsBy, SendSigBy) +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') +import Data.Effect.TH (makeEffect', noDeriveHFunctor) import Data.Effect.TH.Internal ( DataInfo, EffClsInfo (EffClsInfo), @@ -54,6 +54,7 @@ mkName, nameBase, ) +import Language.Haskell.TH.Datatype.TyVarBndr (pattern BndrReq) makeKeyedEffect :: [Name] -> [Name] -> Q [Dec] makeKeyedEffect = @@ -62,6 +63,13 @@ genEffectKey {-# INLINE makeKeyedEffect #-} +makeKeyedEffect_ :: [Name] -> [Name] -> Q [Dec] +makeKeyedEffect_ = + makeEffect' + (def & noDeriveHFunctor & changeNormalSenderFnNameFormat) + genEffectKey +{-# INLINE makeKeyedEffect_ #-} + changeNormalSenderFnNameFormat :: MakeEffectConf -> MakeEffectConf changeNormalSenderFnNameFormat = alterEffectConf $ normalSenderGenConf . _Just . senderFnName %~ (++ "'_") @@ -93,7 +101,7 @@ tell [ TySynD (mkName ecNamePlain) - (pvs <&> (`PlainTV` ())) + (pvs <&> (`PlainTV` BndrReq)) (InfixT key keyedOp (foldl AppT (ConT ecName) (map VarT pvs))) ] @@ -101,8 +109,8 @@ 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 + 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) [] diff --git a/src/Data/Effect/TH.hs b/src/Data/Effect/TH.hs --- a/src/Data/Effect/TH.hs +++ b/src/Data/Effect/TH.hs @@ -7,7 +7,7 @@ -- file, You can obtain one at https://mozilla.org/MPL/2.0/. {- | -Copyright : (c) 2023 Yamada Ryo +Copyright : (c) 2023 Sayo Koyoneda License : MPL-2.0 (see the file LICENSE) Maintainer : ymdfield@outlook.jp Stability : experimental @@ -25,13 +25,13 @@ EffectClassConf (..), confByEffect, doesDeriveHFunctor, - doesGenerateLiftInsPatternSynonyms, - doesGenerateLiftInsTypeSynonym, + doesGenerateLiftFOEPatternSynonyms, + doesGenerateLiftFOETypeSynonym, EffectConf (..), keyedSenderGenConf, normalSenderGenConf, taggedSenderGenConf, - warnFirstOrderInSigCls, + warnFirstOrderInHOE, SenderFunctionConf (..), senderFnName, doesGenerateSenderFnSignature, @@ -40,18 +40,19 @@ senderFnConfs, deriveHFunctor, noDeriveHFunctor, - generateLiftInsTypeSynonym, - noGenerateLiftInsTypeSynonym, - generateLiftInsPatternSynonyms, - noGenerateLiftInsPatternSynonyms, + generateLiftFOETypeSynonym, + noGenerateLiftFOETypeSynonym, + generateLiftFOEPatternSynonyms, + noGenerateLiftFOEPatternSynonyms, noGenerateNormalSenderFunction, noGenerateTaggedSenderFunction, noGenerateKeyedSenderFunction, - suppressFirstOrderInSignatureClassWarning, + suppressFirstOrderInHigherOrderEffectWarning, noGenerateSenderFunctionSignature, ) where -import Control.Monad.Writer (execWriterT, forM_, lift, tell, when) +import Control.Monad (forM_, when) +import Control.Monad.Writer (execWriterT, lift, tell) import Data.Default (Default (def)) import Data.Effect.HFunctor.TH.Internal (deriveHFunctor) import Data.Effect.TH.Internal ( @@ -61,15 +62,15 @@ EffectClassConf, _confByEffect, _doesDeriveHFunctor, - _doesGenerateLiftInsPatternSynonyms, - _doesGenerateLiftInsTypeSynonym + _doesGenerateLiftFOEPatternSynonyms, + _doesGenerateLiftFOETypeSynonym ), EffectConf ( EffectConf, _keyedSenderGenConf, _normalSenderGenConf, _taggedSenderGenConf, - _warnFirstOrderInSigCls + _warnFirstOrderInHOE ), EffectOrder (FirstOrder, HigherOrder), MakeEffectConf (MakeEffectConf, unMakeEffectConf), @@ -83,19 +84,19 @@ alterEffectConf, confByEffect, doesDeriveHFunctor, - doesGenerateLiftInsPatternSynonyms, - doesGenerateLiftInsTypeSynonym, + doesGenerateLiftFOEPatternSynonyms, + doesGenerateLiftFOETypeSynonym, doesGenerateSenderFnSignature, - genLiftInsPatternSynonyms, - genLiftInsTypeSynonym, + genLiftFOEPatternSynonyms, + genLiftFOETypeSynonym, genSenders, - generateLiftInsPatternSynonyms, - generateLiftInsTypeSynonym, + generateLiftFOEPatternSynonyms, + generateLiftFOETypeSynonym, keyedSenderGenConf, noDeriveHFunctor, noGenerateKeyedSenderFunction, - noGenerateLiftInsPatternSynonyms, - noGenerateLiftInsTypeSynonym, + noGenerateLiftFOEPatternSynonyms, + noGenerateLiftFOETypeSynonym, noGenerateNormalSenderFunction, noGenerateSenderFunctionSignature, noGenerateTaggedSenderFunction, @@ -106,21 +107,21 @@ senderFnConfs, senderFnDoc, senderFnName, - suppressFirstOrderInSignatureClassWarning, + suppressFirstOrderInHigherOrderEffectWarning, taggedSenderGenConf, unMakeEffectConf, - warnFirstOrderInSigCls, + warnFirstOrderInHOE, ) 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 + -> (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 @@ -128,11 +129,11 @@ genSenders ecConf effClsInfo & lift >>= tell - when _doesGenerateLiftInsTypeSynonym do - genLiftInsTypeSynonym effClsInfo & singleton & tell + when _doesGenerateLiftFOETypeSynonym do + genLiftFOETypeSynonym effClsInfo & singleton & tell - when _doesGenerateLiftInsPatternSynonyms do - genLiftInsPatternSynonyms effClsInfo & lift >>= tell + when _doesGenerateLiftFOEPatternSynonyms do + genLiftFOEPatternSynonyms effClsInfo & lift >>= tell extTemplate FirstOrder info dataInfo effClsInfo ecConf & lift >>= tell @@ -162,3 +163,11 @@ makeEffectH :: [Name] -> Q [Dec] makeEffectH sigs = makeEffect [] sigs {-# INLINE makeEffectH #-} + +makeEffect_ :: [Name] -> [Name] -> Q [Dec] +makeEffect_ = makeEffect' (def & noDeriveHFunctor) noExtTemplate +{-# INLINE makeEffect_ #-} + +makeEffectH_ :: [Name] -> Q [Dec] +makeEffectH_ sigs = makeEffect_ [] sigs +{-# INLINE makeEffectH_ #-} diff --git a/src/Data/Effect/TH/Internal.hs b/src/Data/Effect/TH/Internal.hs --- a/src/Data/Effect/TH/Internal.hs +++ b/src/Data/Effect/TH/Internal.hs @@ -7,7 +7,7 @@ -- file, You can obtain one at https://mozilla.org/MPL/2.0/. {- | -Copyright : (c) 2023-2024 Yamada Ryo +Copyright : (c) 2023-2024 Sayo Koyoneda (c) 2010-2011 Patrick Bahr, Tom Hvitved (c) 2020 Michael Szvetits License : MPL-2.0 (see the file LICENSE) @@ -49,12 +49,12 @@ ) import Control.Arrow ((>>>)) -import Control.Effect (SendIns, SendSig, sendIns, sendSig) -import Control.Effect.Key (SendInsBy, SendSigBy, sendInsBy, sendSigBy) +import Control.Effect (SendFOE, SendHOE, sendFOE, sendHOE) +import Control.Effect.Key (SendFOEBy, SendHOEBy, sendFOEBy, sendHOEBy) 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 (LiftFOE (LiftFOE)) import Data.Effect.Tag (Tag (Tag), TagH (TagH)) import Data.Either.Extra (mapLeft, maybeToEither) import Data.Either.Validation (Validation, eitherToValidation, validationToEither) @@ -91,6 +91,7 @@ reportWarning, ) import Language.Haskell.TH qualified as TH +import Language.Haskell.TH.Datatype.TyVarBndr (pattern BndrReq) data EffClsInfo = EffClsInfo { ecName :: Name @@ -132,15 +133,15 @@ data EffectClassConf = EffectClassConf { _confByEffect :: Name -> EffectConf , _doesDeriveHFunctor :: Bool - , _doesGenerateLiftInsTypeSynonym :: Bool - , _doesGenerateLiftInsPatternSynonyms :: Bool + , _doesGenerateLiftFOETypeSynonym :: Bool + , _doesGenerateLiftFOEPatternSynonyms :: Bool } data EffectConf = EffectConf { _normalSenderGenConf :: Maybe SenderFunctionConf , _taggedSenderGenConf :: Maybe SenderFunctionConf , _keyedSenderGenConf :: Maybe SenderFunctionConf - , _warnFirstOrderInSigCls :: Bool + , _warnFirstOrderInHOE :: Bool } data SenderFunctionConf = SenderFunctionConf @@ -160,7 +161,7 @@ { _normalSenderGenConf = normal , _taggedSenderGenConf = tagged , _keyedSenderGenConf = keyed - , _warnFirstOrderInSigCls + , _warnFirstOrderInHOE } makeLenses ''EffectClassConf @@ -175,22 +176,22 @@ noDeriveHFunctor = alterEffectClassConf $ doesDeriveHFunctor .~ False {-# INLINE noDeriveHFunctor #-} -generateLiftInsTypeSynonym :: MakeEffectConf -> MakeEffectConf -generateLiftInsTypeSynonym = alterEffectClassConf $ doesGenerateLiftInsTypeSynonym .~ True -{-# INLINE generateLiftInsTypeSynonym #-} +generateLiftFOETypeSynonym :: MakeEffectConf -> MakeEffectConf +generateLiftFOETypeSynonym = alterEffectClassConf $ doesGenerateLiftFOETypeSynonym .~ True +{-# INLINE generateLiftFOETypeSynonym #-} -noGenerateLiftInsTypeSynonym :: MakeEffectConf -> MakeEffectConf -noGenerateLiftInsTypeSynonym = alterEffectClassConf $ doesGenerateLiftInsTypeSynonym .~ False -{-# INLINE noGenerateLiftInsTypeSynonym #-} +noGenerateLiftFOETypeSynonym :: MakeEffectConf -> MakeEffectConf +noGenerateLiftFOETypeSynonym = alterEffectClassConf $ doesGenerateLiftFOETypeSynonym .~ False +{-# INLINE noGenerateLiftFOETypeSynonym #-} -generateLiftInsPatternSynonyms :: MakeEffectConf -> MakeEffectConf -generateLiftInsPatternSynonyms = alterEffectClassConf $ doesGenerateLiftInsPatternSynonyms .~ True -{-# INLINE generateLiftInsPatternSynonyms #-} +generateLiftFOEPatternSynonyms :: MakeEffectConf -> MakeEffectConf +generateLiftFOEPatternSynonyms = alterEffectClassConf $ doesGenerateLiftFOEPatternSynonyms .~ True +{-# INLINE generateLiftFOEPatternSynonyms #-} -noGenerateLiftInsPatternSynonyms :: MakeEffectConf -> MakeEffectConf -noGenerateLiftInsPatternSynonyms = - alterEffectClassConf $ doesGenerateLiftInsPatternSynonyms .~ False -{-# INLINE noGenerateLiftInsPatternSynonyms #-} +noGenerateLiftFOEPatternSynonyms :: MakeEffectConf -> MakeEffectConf +noGenerateLiftFOEPatternSynonyms = + alterEffectClassConf $ doesGenerateLiftFOEPatternSynonyms .~ False +{-# INLINE noGenerateLiftFOEPatternSynonyms #-} noGenerateNormalSenderFunction :: MakeEffectConf -> MakeEffectConf noGenerateNormalSenderFunction = alterEffectConf $ normalSenderGenConf .~ Nothing @@ -204,9 +205,9 @@ noGenerateKeyedSenderFunction = alterEffectConf $ keyedSenderGenConf .~ Nothing {-# INLINE noGenerateKeyedSenderFunction #-} -suppressFirstOrderInSignatureClassWarning :: MakeEffectConf -> MakeEffectConf -suppressFirstOrderInSignatureClassWarning = alterEffectConf $ warnFirstOrderInSigCls .~ False -{-# INLINE suppressFirstOrderInSignatureClassWarning #-} +suppressFirstOrderInHigherOrderEffectWarning :: MakeEffectConf -> MakeEffectConf +suppressFirstOrderInHigherOrderEffectWarning = alterEffectConf $ warnFirstOrderInHOE .~ False +{-# INLINE suppressFirstOrderInHigherOrderEffectWarning #-} noGenerateSenderFunctionSignature :: MakeEffectConf -> MakeEffectConf noGenerateSenderFunctionSignature = @@ -238,11 +239,11 @@ Just $ normalSenderFnConf & senderFnName %~ (++ "'") , _keyedSenderGenConf = Just $ normalSenderFnConf & senderFnName %~ (++ "''") - , _warnFirstOrderInSigCls = True + , _warnFirstOrderInHOE = True } , _doesDeriveHFunctor = True - , _doesGenerateLiftInsTypeSynonym = True - , _doesGenerateLiftInsPatternSynonyms = True + , _doesGenerateLiftFOETypeSynonym = True + , _doesGenerateLiftFOEPatternSynonyms = True } genSenders :: EffectClassConf -> EffClsInfo -> Q [Dec] @@ -256,90 +257,90 @@ 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 + -- Check for First Order in Higher Order effect warning + when (_warnFirstOrderInHOE && order == HigherOrder) do let isHigherOrderEffect = any (tyVarName (fromJust effCarrier) `occurs`) effParamTypes unless isHigherOrderEffect do lift $ reportWarning $ - "The first-order effect ‘" + "The first-order operation ‘" <> nameBase effName - <> "’ has been found within the signature class data type ‘" + <> "’ has been found within the higher-order effect data type ‘" <> nameBase ecName - <> "’.\nConsider separating the first-order effect into an instruction class data type." + <> "’.\nConsider separating the first-order operation into an first-order effect data type." -genNormalSender :: - EffectOrder -> - SenderFunctionConf -> - EffConInfo -> - WriterT [Dec] Q () +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 + ( (VarE 'sendFOE `AppE`) + , \effDataType carrier -> ConT ''SendFOE `AppT` effDataType `AppT` carrier ) HigherOrder -> - ( (VarE 'sendSig `AppE`) - , \effDataType carrier -> ConT ''SendSig `AppT` effDataType `AppT` carrier + ( (VarE 'sendHOE `AppE`) + , \effDataType carrier -> ConT ''SendHOE `AppT` effDataType `AppT` carrier ) -genTaggedSender :: - EffectOrder -> - SenderFunctionConf -> - EffConInfo -> - WriterT [Dec] Q () +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`) + ( (VarE 'sendFOE `AppE`) . (ConE 'Tag `AppTypeE` WildCardT `AppTypeE` tag `AppE`) , \effDataType carrier -> - ConT ''SendIns `AppT` (ConT ''Tag `AppT` effDataType `AppT` tag) `AppT` carrier + ConT ''SendFOE `AppT` (ConT ''Tag `AppT` effDataType `AppT` tag) `AppT` carrier ) HigherOrder -> - ( (VarE 'sendSig `AppE`) . (ConE 'TagH `AppTypeE` WildCardT `AppTypeE` tag `AppE`) + ( (VarE 'sendHOE `AppE`) . (ConE 'TagH `AppTypeE` WildCardT `AppTypeE` tag `AppE`) , \effDataType carrier -> - ConT ''SendSig `AppT` (ConT ''TagH `AppT` effDataType `AppT` tag) `AppT` carrier + ConT ''SendHOE `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 + :: 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`) + ( (VarE 'sendFOEBy `AppTypeE` key `AppE`) , \effDataType carrier -> - ConT ''SendInsBy `AppT` key `AppT` effDataType `AppT` carrier + ConT ''SendFOEBy `AppT` key `AppT` effDataType `AppT` carrier ) HigherOrder -> - ( (VarE 'sendSigBy `AppTypeE` key `AppE`) + ( (VarE 'sendHOEBy `AppTypeE` key `AppE`) , \effDataType carrier -> - ConT ''SendSigBy `AppT` key `AppT` effDataType `AppT` carrier + ConT ''SendHOEBy `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 + :: 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") @@ -358,13 +359,13 @@ 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 + :: (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 @@ -400,7 +401,7 @@ when _doesGenerateSenderFnSignature $ tell [funSig] tell [funDef, funInline] -arrowChain :: Foldable t => t TH.Type -> TH.Type -> TH.Type +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. @@ -478,8 +479,8 @@ , effCxt = conCxt } where - decomposeGadtReturnType :: - TH.Type -> Either [T.Text] (TH.Type, Maybe (TyVarBndr ()), TH.Type) + decomposeGadtReturnType + :: TH.Type -> Either [T.Text] (TH.Type, Maybe (TyVarBndr ()), TH.Type) decomposeGadtReturnType = unkindType >>> case order of FirstOrder -> @@ -487,7 +488,7 @@ ins `AppT` x -> Right (ins, Nothing, x) t -> Left - [ "Unexpected form of GADT return type for the instruction ‘" + [ "Unexpected form of GADT return type for the first-order operation ‘" <> T.pack (nameBase conName) <> "’: " <> T.pack (pprint t) @@ -499,7 +500,7 @@ Right (sig, Just (PlainTV f ()), x) t -> Left - [ "Unexpected form of GADT return type for the signature ‘" + [ "Unexpected form of GADT return type for the higher-order operation ‘" <> T.pack (nameBase conName) <> "’: " <> T.pack (pprint t) @@ -518,15 +519,15 @@ , ecEffs = effCons } --- ** Generating Synonyms about LiftIns +-- ** Generating Synonyms about LiftFOE {- | -Generate the pattern synonyms for instruction constructors: +Generate the pattern synonyms for operation constructors: - @pattern LBaz ... = LiftIns (Baz ...)@ + @pattern LBaz ... = LiftFOE (Baz ...)@ -} -genLiftInsPatternSynonyms :: EffClsInfo -> Q [Dec] -genLiftInsPatternSynonyms EffClsInfo{..} = do +genLiftFOEPatternSynonyms :: EffClsInfo -> Q [Dec] +genLiftFOEPatternSynonyms EffClsInfo{..} = do patSyns <- forM ecEffs \EffConInfo{..} -> do let newConName = mkName $ 'L' : nameBase effName @@ -542,37 +543,37 @@ -- 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 ''LiftIns `AppT` effDataType) `AppT` f `AppT` a) - ) + () + => ( $(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 'LiftIns [] [ConP effName [] (VarP <$> args)]) + (ConP 'LiftFOE [] [ConP effName [] (VarP <$> args)]) ] pure $ concatMap snd patSyns ++ [PragmaD $ CompleteP (fst <$> patSyns) Nothing] {- | -Generate the type synonym for an instruction class datatype: +Generate the type synonym for an first-order effect datatype: - @type (LFoobar ...) = LiftIns (Foobar ...)@ + @type (LFoobar ...) = LiftFOE (Foobar ...)@ -} -genLiftInsTypeSynonym :: EffClsInfo -> Dec -genLiftInsTypeSynonym EffClsInfo{..} = do +genLiftFOETypeSynonym :: EffClsInfo -> Dec +genLiftFOETypeSynonym EffClsInfo{..} = do TySynD (mkName $ 'L' : nameBase ecName) - (pvs <&> (`PlainTV` ())) - (ConT ''LiftIns `AppT` foldl AppT (ConT ecName) (map VarT pvs)) + (pvs <&> (`PlainTV` BndrReq)) + (ConT ''LiftFOE `AppT` foldl AppT (ConT ecName) (map VarT pvs)) where pvs = tyVarName <$> ecParamVars @@ -710,9 +711,9 @@ analyzeData :: Info -> Maybe DataInfo analyzeData = \case TyConI (NewtypeD cxt name args _ constr _) -> - Just $ DataInfo cxt name args (normalizeCon constr) + Just $ DataInfo cxt name (map ($> ()) args) (normalizeCon constr) TyConI (DataD cxt name args _ constrs _) -> - Just $ DataInfo cxt name args (concatMap normalizeCon constrs) + Just $ DataInfo cxt name (map ($> ()) args) (concatMap normalizeCon constrs) _ -> Nothing normalizeCon :: Con -> [ConInfo]