diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/Example/Driver.hs b/Example/Driver.hs --- a/Example/Driver.hs +++ b/Example/Driver.hs @@ -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 diff --git a/Example/Example.hs b/Example/Example.hs --- a/Example/Example.hs +++ b/Example/Example.hs @@ -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 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 +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 -maintainer: Sayo Koyoneda +author: Sayo contributors +maintainer: ymdfield -- 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 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 @@ -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'. 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 @@ -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] ] diff --git a/src/Data/Effect/Key/TH.hs b/src/Data/Effect/Key/TH.hs deleted file mode 100644 --- a/src/Data/Effect/Key/TH.hs +++ /dev/null @@ -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 "'" 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 @@ -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 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 @@ -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