diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog for `cleff-plugin` + +## 0.1.0.0 (2022-03-13) + +- Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Xy Ren (c) 2022 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Xy Ren nor the names of other contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,48 @@ +# `cleff-plugin` + +This GHC typechecking plugin disambiguates obvious usages of effects for the extensible effect framework `cleff`. + +## Usage + +This plugin works with GHC 8.6 through 9.2 and `cleff >= 0.1 && < 0.4`. To use the plugin: + +1. Add this plugin as your package's dependency. + - If you use `stack`, then you also need to add these lines your `stack.yaml`: + ```yaml + extra-deps: + - cleff-plugin-0.1.0.0 + ``` +2. Enable the plugin by adding the following GHC option to your project file: + ``` + ghc-options: -fplugin=Cleff.Plugin + ``` + +## What it does + +When using `cleff`, the following code would not compile: + +```haskell +action :: '[State Int, State String] :>> es => Eff es () +action = do + x <- get + put (x + 1) +-- • Could not deduce (Cleff.Internal.Rec.Elem (State s0) es) +-- arising from a use of ‘get’ +``` + +This is because GHC is unable to determine which `State` effect we're trying to operate on, although the only viable choice is `State Int`. We had to write: + +```haskell +action :: '[State Int, State String] :>> es => Eff es () +action = do + x <- get @Int + put (x + 1) +``` + +This is quite unwieldy. This plugin tells GHC extra information so code like this can typecheck without requiring manually annotating which effect to use. + +## References + +This plugin's design is largely inspired by [`polysemy-plugin`](https://hackage.haskell.org/package/polysemy-plugin), which is in turn based on [`simple-effects`](https://hackage.haskell.org/package/simple-effects). + +Refer to [`docs/plugin-spec.md`](https://github.com/re-xyr/cleff/tree/master/docs/plugin-spec.md) for details on the disambiguation algorithm this typecheck plugin uses. diff --git a/cleff-plugin.cabal b/cleff-plugin.cabal new file mode 100644 --- /dev/null +++ b/cleff-plugin.cabal @@ -0,0 +1,107 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: cleff-plugin +version: 0.1.0.0 +synopsis: Automatic disambiguation for extensible effects +description: Please see the README on GitHub at +category: Control, Effect, Language +homepage: https://github.com/re-xyr/cleff#readme +bug-reports: https://github.com/re-xyr/cleff/issues +author: Xy Ren +maintainer: xy.r@outlook.com +copyright: 2022 Xy Ren +license: BSD3 +license-file: LICENSE +build-type: Simple +tested-with: + GHC == 8.6.5 + , GHC == 8.8.4 + , GHC == 8.10.7 + , GHC == 9.0.2 +extra-source-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/re-xyr/cleff + +library + exposed-modules: + Cleff.Plugin + Cleff.Plugin.Internal + other-modules: + Paths_cleff_plugin + hs-source-dirs: + src + default-extensions: + BangPatterns + BlockArguments + DerivingStrategies + EmptyCase + FlexibleContexts + FlexibleInstances + LambdaCase + NoStarIsType + PolyKinds + ScopedTypeVariables + TupleSections + UnicodeSyntax + ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors -Wpartial-fields -Wunused-type-patterns -Wmissing-export-lists + build-depends: + base >=4.12 && <4.17 + , cleff >=0.1 && <0.4 + , containers >=0.5 && <0.7 + , ghc >=8.6 && <9.3 + , ghc-tcplugins-extra >=0.3 && <0.5 + if impl(ghc >= 8.8) + ghc-options: -Wmissing-deriving-strategies + default-language: Haskell2010 + +test-suite cleff-plugin-test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + CleffSpec + Paths_cleff_plugin + hs-source-dirs: + test + default-extensions: + BangPatterns + BlockArguments + DerivingStrategies + EmptyCase + FlexibleContexts + FlexibleInstances + LambdaCase + NoStarIsType + PolyKinds + ScopedTypeVariables + TupleSections + UnicodeSyntax + DataKinds + FunctionalDependencies + TemplateHaskell + GADTs + GeneralizedNewtypeDeriving + KindSignatures + RankNTypes + TypeApplications + TypeFamilies + TypeOperators + UndecidableInstances + ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors -Wpartial-fields -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.12 && <4.17 + , cleff + , cleff-plugin + , containers >=0.5 && <0.7 + , ghc >=8.6 && <9.3 + , ghc-tcplugins-extra >=0.3 && <0.5 + if impl(ghc >= 8.8) + ghc-options: -Wmissing-deriving-strategies + default-language: Haskell2010 diff --git a/src/Cleff/Plugin.hs b/src/Cleff/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Plugin.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE CPP #-} +-- | Copyright: (c) 2022 Xy Ren +-- License: BSD3 +-- Maintainer: xy.r@outlook.com +-- Stability: experimental +-- Portability: non-portable (GHC only) +module Cleff.Plugin (plugin) where + +import Cleff.Plugin.Internal (Plugin, makePlugin) + +-- | The GHC typechecker plugin that disambiguates trivial uses of @cleff@ effects. Refer to the README for more info. +plugin :: Plugin +#if MIN_VERSION_cleff(0, 3, 2) +plugin = makePlugin [("cleff", "Cleff.Internal.Rec", ":>")] +#elif MIN_VERSION_cleff(0, 3, 1) +plugin = makePlugin [("cleff", "Cleff.Internal.Rec", "Elem")] +#elif MIN_VERSION_cleff(0, 2, 0) +plugin = makePlugin [("rec-smallarray", "Data.Rec.SmallArray", "Elem")] +#else +plugin = makePlugin [("cleff", "Data.Rec", "Elem")] +#endif diff --git a/src/Cleff/Plugin/Internal.hs b/src/Cleff/Plugin/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Cleff/Plugin/Internal.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Redundant if" #-} +-- | Copyright: (c) 2022 Xy Ren +-- License: BSD3 +-- Maintainer: xy.r@outlook.com +-- Stability: unstable +-- Portability: non-portable (GHC only) +module Cleff.Plugin.Internal (Plugin, Names, makePlugin) where + +import Data.Function (on) +import Data.IORef (IORef, modifyIORef, newIORef, readIORef) +import Data.Maybe (isNothing, mapMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Traversable (for) +import GHC.TcPluginM.Extra (lookupModule, lookupName) + +#if __GLASGOW_HASKELL__ >= 900 +import GHC.Core.Class (Class) +import GHC.Core.InstEnv (InstEnvs, lookupInstEnv) +import GHC.Core.Unify (tcUnifyTy) +import GHC.Plugins (Outputable (ppr), Plugin (pluginRecompile, tcPlugin), PredType, + Role (Nominal), TCvSubst, Type, defaultPlugin, eqType, fsLit, mkModuleName, + mkTcOcc, nonDetCmpType, purePlugin, showSDocUnsafe, splitAppTys, substTys, + tyConClass_maybe) +import GHC.Tc.Plugin (tcLookupClass, tcPluginIO) +import GHC.Tc.Solver.Monad (newWantedEq, runTcSDeriveds) +import GHC.Tc.Types (TcM, TcPlugin (TcPlugin, tcPluginInit, tcPluginSolve, tcPluginStop), + TcPluginM, TcPluginResult (TcPluginOk), unsafeTcPluginTcM) +import GHC.Tc.Types.Constraint (Ct (CDictCan, CNonCanonical), CtEvidence (CtWanted), CtLoc, ctPred) +import GHC.Tc.Utils.Env (tcGetInstEnvs) +import GHC.Tc.Utils.TcType (tcSplitTyConApp) + +#else +import Class (Class) +#if __GLASGOW_HASKELL__ >= 810 +import Constraint (Ct (CDictCan, CNonCanonical), CtEvidence (CtWanted), CtLoc, ctPred) +#endif +import GhcPlugins (Outputable (ppr), Plugin (pluginRecompile, tcPlugin), PredType, + Role (Nominal), TCvSubst, Type, defaultPlugin, eqType, fsLit, mkModuleName, + mkTcOcc, nonDetCmpType, purePlugin, showSDocUnsafe, splitAppTys, substTys, + tyConClass_maybe) +import InstEnv (InstEnvs, lookupInstEnv) +import TcEnv (tcGetInstEnvs) +import TcPluginM (tcLookupClass, tcPluginIO) +import TcRnTypes +import TcSMonad (newWantedEq, runTcSDeriveds) +import TcType (tcSplitTyConApp) +import Unify (tcUnifyTy) +#endif + +-- | A list of unique, unambiguous Haskell names in the format of @(packageName, moduleName, identifier)@. +type Names = [(String, String, String)] + +-- | Make a @polysemy-plugin@-style effect disambiguation plugin that applies to all the "element-of" typeclasses +-- passed in. Each of the names passed in should have type @k -> [k] -> 'Data.Kind.Type'@ where @k@ can be either +-- polymorphic or monomorphic. +-- +-- Some examples include: +-- +-- @ +-- (\"cleff\", \"Cleff.Internal.Rec\", \":>\") +-- (\"polysemy\", \"Polysemy.Internal.Union\", \"Member\") +-- (\"effectful\", \"Effectful.Internal.Effect\", \":>\") +-- @ +-- +-- You can see the source code for notes on the implementation of the plugin. +makePlugin :: Names -> Plugin +makePlugin names = defaultPlugin + { tcPlugin = const (Just $ fakedep names) + , pluginRecompile = purePlugin + } + +fakedep :: Names -> TcPlugin +fakedep names = TcPlugin + { tcPluginInit = initFakedep names + , tcPluginSolve = solveFakedepForAllElemClasses + , tcPluginStop = const $ pure () + } + +liftTc :: TcM a -> TcPluginM a +liftTc = unsafeTcPluginTcM + +liftIo :: IO a -> TcPluginM a +liftIo = tcPluginIO +type VisitedSet = Set (OrdType, OrdType) + +initFakedep :: Names -> TcPluginM ([Class], IORef VisitedSet) +initFakedep names = do + classes <- for names \(packageName, elemModuleName, elemClassName) -> do + recMod <- lookupModule (mkModuleName elemModuleName) $ fsLit packageName + nm <- lookupName recMod $ mkTcOcc elemClassName + tcLookupClass nm + visited <- liftIo $ newIORef Set.empty + pure (classes, visited) + +data FakedepGiven = FakedepGiven + { givenEffHead :: Type + , givenEff :: Type + , givenEs :: Type + } + +instance Show FakedepGiven where + show (FakedepGiven _ e es) = "(Elem " <> showSDocUnsafe (ppr e) <> " " <> showSDocUnsafe (ppr es) <> ")" + +data FakedepWanted = FakedepWanted FakedepGiven CtLoc + +instance Show FakedepWanted where + show (FakedepWanted given _) = show given + +newtype OrdType = OrdType { unOrdType :: Type } + +instance Eq OrdType where + (==) = eqType `on` unOrdType + +instance Ord OrdType where + compare = nonDetCmpType `on` unOrdType + +solveFakedepForAllElemClasses :: ([Class], IORef VisitedSet) -> [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginResult +solveFakedepForAllElemClasses (elemClasses, visitedRef) givens _ wanteds = do + solns <- concat <$> for elemClasses \elemCls -> solveFakedep (elemCls, visitedRef) givens wanteds + pure $ TcPluginOk [] solns + +solveFakedep :: (Class, IORef VisitedSet) -> [Ct] -> [Ct] -> TcPluginM [Ct] +solveFakedep _ _ [] = pure [] +solveFakedep (elemCls, visitedRef) allGivens allWanteds = do + -- We're given two lists of constraints here: + -- - 'allGivens' are constraints already in our context, + -- - 'allWanteds' are constraints that need to be solved. + -- In the following notes, the words "give/given" and "want/wanted" all refer to this specific technical concept: + -- given constraints are those that we can use, and wanted constraints are those that we need to solve. + let + -- The only type of constraint we're interested in solving are 'Elem e es' constraints. Therefore, we extract these + -- constraints out of the 'allGivens' and 'allWanted's. + givens = mapMaybe relevantGiven allGivens + wanteds = mapMaybe relevantWanted allWanteds + -- We store a list of the types of all given constraints, which will be useful later. + allGivenTypes = ctPred <$> allGivens + -- We also store a list of wanted constraints that are /not/ 'Elem e es' for later use. + extraWanteds = ctPred <$> filter irrelevant allWanteds + + -- traceM $ "Givens: " <> show (showSDocUnsafe . ppr <$> allGivens) + -- traceM $ "Wanteds: " <> show (showSDocUnsafe . ppr <$> allWanteds) + + -- For each 'Elem e es' we /want/ to solve (the "goal"), we need to eventually correspond it to another unique + -- /given/ 'Elem e es' that will make the program typecheck (the "solution"). + globals <- liftTc tcGetInstEnvs -- Get the global instances environment for later use + let solns = mapMaybe (solve globals allGivenTypes extraWanteds givens) wanteds + + -- Now we need to tell GHC the solutions. The way we do this is to generate a new equality constraint, like + -- 'Elem (State e) es ~ Elem (State Int) es', so that GHC's constraint solver will know that 'e' must be 'Int'. + eqns <- for solns \(FakedepWanted (FakedepGiven _ goalEff _) loc, FakedepGiven _ solnEff _) -> do + (eqn, _) <- liftTc $ runTcSDeriveds $ newWantedEq loc Nominal goalEff solnEff + pure (CNonCanonical eqn, (OrdType goalEff, OrdType solnEff)) + + -- For any solution we've generated, we need to be careful not to generate it again, or we might end up generating + -- infinitely many solutions. So, we record any already generated solution in a set. + visitedSolnPairs <- liftIo $ readIORef visitedRef + let solnEqns = fst <$> flip filter eqns \(_, pair) -> Set.notMember pair visitedSolnPairs + liftIo $ modifyIORef visitedRef (Set.union $ Set.fromList $ snd <$> eqns) + + -- traceM $ "Emitting: " <> showSDocUnsafe (ppr solnEqns) + pure solnEqns -- Finally we tell GHC the solutions. + + where + + -- Determine if there is a unique solution to a goal from a set of candidates. + solve :: InstEnvs -> [PredType] -> [PredType] -> [FakedepGiven] -> FakedepWanted -> Maybe (FakedepWanted, FakedepGiven) + solve globals allGivenTypes extraWanteds givens goal@(FakedepWanted (FakedepGiven _ _ goalEs) _) = + let + -- Apart from 'Elem' constraints in the context, the effects already hardwired into the effect stack type, + -- like those in 'A : B : C : es', also need to be considered. So here we extract that for them to be considered + -- simultaneously with regular 'Elem' constraints. + cands = extractExtraGivens goalEs goalEs <> givens + -- The first criteria is that the candidate constraint must /unify/ with the goal. This means that the type + -- variables in the goal can be instantiated in a way so that the goal becomes equal to the candidate. + -- For example, the candidates 'Elem (State Int) es' and 'Elem (State String) es' both unify with the goal + -- 'Elem (State s) es'. + unifiableCands = mapMaybe (unifiableWith goal) cands + in case unifiableCands of + -- If there's already only one unique solution, commit to it; in the worst case where it doesn't actually match, + -- we get a cleaner error message like "Unable to match (State String) to (State Int)" instead of a type + -- ambiguity error. + [(soln, _)] -> Just (goal, soln) + _ -> + -- Otherwise, the second criteria comes in: the candidate must satisfy all other constraints we /want/ to solve. + -- For example, when we want to solve '(Elem (State a) es, Num a)`, the candidate 'Elem (State Int) es' will do + -- the job, because it satisfied 'Num a'; however 'Elem (State String) es' will be excluded. + let satisfiableCands = filter (satisfiable globals allGivenTypes extraWanteds) unifiableCands + -- Finally, if there is a unique candidate remaining, we use it as the solution; otherwise we don't solve anything. + in case satisfiableCands of + [(soln, _)] -> Just (goal, soln) + _ -> Nothing + + -- Extract the heads of a type like 'A : B : C : es' into 'FakedepGiven's. + extractExtraGivens :: Type -> Type -> [FakedepGiven] + extractExtraGivens fullEs es = case splitAppTys es of + (_colon, [_kind, e, es']) -> + let (dtHead, _tyArgs) = splitAppTys e + in FakedepGiven dtHead e fullEs : extractExtraGivens fullEs es' + _ -> [] + + -- Determine whether a given constraint is of form 'Elem e es'. + relevantGiven :: Ct -> Maybe FakedepGiven + relevantGiven (CDictCan _ cls [_kind, eff, es] _) -- Polymorphic case + | cls == elemCls = Just $ FakedepGiven (fst $ splitAppTys eff) eff es + relevantGiven (CDictCan _ cls [eff, es] _) -- Monomorphic case + | cls == elemCls = Just $ FakedepGiven (fst $ splitAppTys eff) eff es + relevantGiven _ = Nothing + + -- Determine whether a wanted constraint is of form 'Elem e es'. + relevantWanted :: Ct -> Maybe FakedepWanted + relevantWanted (CDictCan (CtWanted _ _ _ loc) cls [_kind, eff, es] _) -- Polymorphic case + | cls == elemCls = Just $ FakedepWanted (FakedepGiven (fst $ splitAppTys eff) eff es) loc + relevantWanted (CDictCan (CtWanted _ _ _ loc) cls [eff, es] _) -- Monomorphic case + | cls == elemCls = Just $ FakedepWanted (FakedepGiven (fst $ splitAppTys eff) eff es) loc + relevantWanted _ = Nothing + + -- Determine whether a constraint is /not/ of form 'Elem e es'. + irrelevant :: Ct -> Bool + irrelevant = isNothing . relevantGiven + + -- Given a wanted constraint and a given constraint, unify them and give back a substitution that can be applied + -- to the wanted to make it equal to the given. + unifiableWith :: FakedepWanted -> FakedepGiven -> Maybe (FakedepGiven, TCvSubst) + unifiableWith (FakedepWanted goal _) cand = + -- First, the 'es' type must be equal, and the datatype head of the effect must be equal too. + if givenEs goal `eqType` givenEs cand && givenEffHead goal `eqType` givenEffHead cand + then (cand, ) <$> tcUnifyTy (givenEff goal) (givenEff cand) -- Then the effect type must unify. + else Nothing + + -- Check whether a candidate can satisfy all tthe wanted constraints. + satisfiable :: InstEnvs -> [PredType] -> [PredType] -> (FakedepGiven, TCvSubst) -> Bool + satisfiable globals givens wanteds (_, subst) = + let + wantedsInst = substTys subst wanteds -- The wanteds after unification. + givensInst = Set.fromList $ OrdType <$> substTys subst givens -- The local given context after unification. + in flip all wantedsInst \want -> + if Set.member (OrdType want) givensInst then True -- Can we find this constraint in our local context? + else let (con, args) = tcSplitTyConApp want + in case tyConClass_maybe con of -- If not, lookup the global environment. + Nothing -> False + Just cls -> let (res, _, _) = lookupInstEnv False globals cls args in not $ null res diff --git a/test/CleffSpec.hs b/test/CleffSpec.hs new file mode 100644 --- /dev/null +++ b/test/CleffSpec.hs @@ -0,0 +1,117 @@ +-- Tests copied from `polysemy-plugin` (https://github.com/polysemy-research/polysemy/tree/master/polysemy-plugin/test) +-- (c) 2019 Sandy Maguire, licensed under BSD-3-Clause +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-foralls -fplugin=Cleff.Plugin #-} +module CleffSpec where + +import Cleff +import Cleff.Error +import Cleff.State +import Data.String (IsString) +import Unsafe.Coerce (unsafeCoerce) + +class MPTC a b where + mptc :: a -> b + +instance MPTC Bool Int where + mptc _ = 1000 + +uniquelyInt :: '[State Int, State String] :>> r => Eff r () +uniquelyInt = put 10 + +uniquelyA :: (Num a, '[State a, State b] :>> r) => Eff r () +uniquelyA = put 10 + +uniquelyString :: '[State Int, State String] :>> r => Eff r () +uniquelyString = put mempty + +uniquelyB :: (MPTC Bool b, '[State String, State b] :>> r) => Eff r () +uniquelyB = put $ mptc False + +uniquelyState' :: '[Error (), State ()] :>> r => Eff r () +uniquelyState' = pure () + +idState :: State s :> r => Eff r () +idState = do + s <- get + put s + +intState :: State Int :> r => Eff r () +intState = put 10 + +numState :: Num a => State a :> r => Eff r () +numState = put 10 + +strState :: State String :> r => Eff r () +strState = put "Hello" + +oStrState :: IsString a => State a :> r => Eff r () +oStrState = put "hello" + +err :: Error e :> r => Eff r Bool +err = + catchError + (throwError (error "")) + (\_ -> pure True) + +errState :: Num s => '[Error e, State s] :>> r => Eff r Bool +errState = do + numState + err + +newtype MyString = MyString String + deriving newtype (IsString, Eq, Show) + +data Janky = forall s. Janky (forall _i. Eff '[State s] ()) + +jankyState :: Janky +jankyState = Janky $ put True -- The plugin disambiguates effects for concrete rows too + +unsafeUnjank :: Janky -> Eff '[State Bool] () +unsafeUnjank (Janky m) = unsafeCoerce m + +data MoreJanky = forall y. MoreJanky (MPTC Bool y => Eff '[State (Bool, y), State (Char, y)] ()) + +mptcGet :: MPTC x Bool => x +mptcGet = undefined + +moreJankyState :: MoreJanky +moreJankyState = MoreJanky $ put (mptcGet, True) + +data TaggedState k s m a where + TaggedGet :: forall k s m. TaggedState k s m s + TaggedPut :: forall k s m. s -> TaggedState k s m () + +makeEffect ''TaggedState -- The plugin also disambiguates TH functions generated by 'makeEffect' + +runTaggedState :: forall k s r a + . s + -> Eff (TaggedState k s : r) a + -> Eff r (a, s) +runTaggedState s = + (runState s .) + $ reinterpret + $ \case + TaggedGet -> get + TaggedPut s' -> put s' + +test :: '[ + TaggedState Char Int + , TaggedState Bool Int + ] :>> r + => Eff r () +test = do + taggedPut @Bool 10 + taggedPut @Char (-10) + +newtype Select a = Select a + +data DBAction whichDb m a where + DoSelect :: Select a -> DBAction whichDb m (Maybe a) + +makeEffect ''DBAction + +runDBAction :: Eff (DBAction which ': r) a -> Eff r a +runDBAction = interpret $ \case + DoSelect (Select a) -> pure $ Just a diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +module Main where + +#ifdef CLEFF_PLUGIN_cleff +import qualified CleffSpec +#endif +#ifdef CLEFF_PLUGIN_effectful +import qualified EffectfulSpec +#endif + +main :: IO () +main = putStrLn "It compiles!"