mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-09-11 10:36:40 +03:00
Remove custom type errors from Member (#429)
* Remove Member type errors * Remove unused custom type errors * Deprecate MemberWithError * Remove readme notes about type errors * Remove MemberWithError
This commit is contained in:
Sandy Maguire
GitHub
parent
ac431a17b4
commit
55150644c4
@ -195,12 +195,6 @@ makes the helpful suggestion:
|
||||
$ \case
|
||||
```
|
||||
|
||||
Likewise it will give you tips on what to do if you forget a `TypeApplication`
|
||||
or forget to handle an effect.
|
||||
|
||||
Don't like helpful errors? That's OK too - just flip the `error-messages`
|
||||
flag and enjoy the raw, unadulterated fury of the typesystem.
|
||||
|
||||
## Necessary Language Extensions
|
||||
|
||||
You're going to want to stick all of this into your `package.yaml` file.
|
||||
|
||||
11
package.yaml
11
package.yaml
@ -63,10 +63,6 @@ flags:
|
||||
description: Dump HTML for the core generated by GHC during compilation
|
||||
default: False
|
||||
manual: True
|
||||
error-messages:
|
||||
description: Provide custom error messages
|
||||
default: True
|
||||
manual: True
|
||||
|
||||
library:
|
||||
ghc-options: -Wall
|
||||
@ -87,13 +83,6 @@ library:
|
||||
dependencies:
|
||||
- unsupported-ghc-version > 1 && < 1
|
||||
|
||||
- condition: flag(error-messages)
|
||||
then:
|
||||
# dummy value because cabal is stupid
|
||||
cpp-options: -DCABAL_SERIOUSLY_CMON_MATE
|
||||
else:
|
||||
cpp-options: -DNO_ERROR_MESSAGES
|
||||
|
||||
tests:
|
||||
polysemy-test:
|
||||
main: Main.hs
|
||||
|
||||
@ -78,7 +78,6 @@ test-suite polysemy-plugin-test
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
AmbiguousSpec
|
||||
BadSpec
|
||||
DoctestSpec
|
||||
ExampleSpec
|
||||
InsertSpec
|
||||
|
||||
@ -122,7 +122,7 @@ data FindConstraint = FindConstraint
|
||||
-- | Given a list of constraints, filter out the 'FindConstraint's.
|
||||
getFindConstraints :: PolysemyStuff 'Things -> [Ct] -> [FindConstraint]
|
||||
getFindConstraints (findClass -> cls) cts = do
|
||||
cd@CDictCan{cc_class = cls', cc_tyargs = [_, eff, r]} <- cts
|
||||
cd@CDictCan{cc_class = cls', cc_tyargs = [eff, r]} <- cts
|
||||
guard $ cls == cls'
|
||||
pure $ FindConstraint
|
||||
{ fcLoc = ctLoc cd
|
||||
@ -229,53 +229,6 @@ mkWanted fc solve_ctx given =
|
||||
wanted = fcEffect fc
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Given a list of 'Ct's, find any that are of the form
|
||||
-- @[Irred] Sem r a ~ Something@, and return their @r@s.
|
||||
getBogusRs :: PolysemyStuff 'Things -> [Ct] -> [Type]
|
||||
getBogusRs stuff wanteds = do
|
||||
CIrredCan ct _ <- wanteds
|
||||
(_, [_, _, a, b]) <- pure . splitAppTys $ ctev_pred ct
|
||||
maybeToList (extractRowFromSem stuff a)
|
||||
++ maybeToList (extractRowFromSem stuff b)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Take the @r@ out of @Sem r a@.
|
||||
extractRowFromSem :: PolysemyStuff 'Things -> Type -> Maybe Type
|
||||
extractRowFromSem (semTyCon -> sem) ty = do
|
||||
(tycon, [r, _]) <- splitTyConApp_maybe ty
|
||||
guard $ tycon == sem
|
||||
pure r
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Given a list of bogus @r@s, and the wanted constraints, produce bogus
|
||||
-- evidence terms that will prevent @IfStuck (LocateEffect _ r) _ _@ error messsages.
|
||||
solveBogusError :: PolysemyStuff 'Things -> [Ct] -> [(EvTerm, Ct)]
|
||||
solveBogusError stuff wanteds = do
|
||||
let splitTyConApp_list = maybeToList . splitTyConApp_maybe
|
||||
|
||||
let bogus = getBogusRs stuff wanteds
|
||||
ct@(CIrredCan ce _) <- wanteds
|
||||
(stuck, [_, _, expr, _, _]) <- splitTyConApp_list $ ctev_pred ce
|
||||
guard $ stuck == ifStuckTyCon stuff
|
||||
(idx, [_, _, r]) <- splitTyConApp_list expr
|
||||
guard $ idx == locateEffectTyCon stuff
|
||||
guard $ elem @[] (OrdType r) $ coerce bogus
|
||||
pure (error $ unlines
|
||||
[ "Bogus proof for stuck type family."
|
||||
, ""
|
||||
, "This means there's a type error in your program, but the fact that"
|
||||
, "you're seeing this message is a bug in `polysemy-plugin`."
|
||||
, ""
|
||||
, "Please file a bug at https://github.com/polysemy-research/polysemy"
|
||||
, "with a minimal reproduction for how you managed to get this error."
|
||||
]
|
||||
, ct
|
||||
)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Determine if there is exactly one wanted find for the @r@ in question.
|
||||
exactlyOneWantedForR
|
||||
@ -369,5 +322,5 @@ solveFundep (ref, stuff) given _ wanted = do
|
||||
let (unifications, new_wanteds) = unzipNewWanteds already_emitted $ catMaybes eqs
|
||||
tcPluginIO $ modifyIORef ref $ S.union $ S.fromList unifications
|
||||
|
||||
pure $ TcPluginOk (solveBogusError stuff wanted) new_wanteds
|
||||
pure $ TcPluginOk [] new_wanteds
|
||||
|
||||
|
||||
@ -15,14 +15,14 @@ import GHC.Types.Name.Occurrence (mkTcOcc)
|
||||
import GHC.Tc.Plugin (TcPluginM, tcLookupClass, tcLookupTyCon, unsafeTcPluginTcM)
|
||||
import GHC.Plugins (getDynFlags, unitState)
|
||||
import GHC.Unit.State (lookupModuleWithSuggestions, LookupResult (..))
|
||||
import GHC.Utils.Outputable (pprPanic, empty, text, (<+>), ($$))
|
||||
import GHC.Utils.Outputable (pprPanic, text, (<+>), ($$))
|
||||
#else
|
||||
import FastString (fsLit)
|
||||
import OccName (mkTcOcc)
|
||||
import TcPluginM (TcPluginM, tcLookupClass, tcLookupTyCon, unsafeTcPluginTcM)
|
||||
import GhcPlugins (getDynFlags)
|
||||
import Packages (lookupModuleWithSuggestions, LookupResult (..))
|
||||
import Outputable (pprPanic, empty, text, (<+>), ($$))
|
||||
import Outputable (pprPanic, text, (<+>), ($$))
|
||||
#endif
|
||||
|
||||
|
||||
@ -34,8 +34,6 @@ import Outputable (pprPanic, empty, text, (<+>), ($$))
|
||||
data PolysemyStuff (l :: LookupState) = PolysemyStuff
|
||||
{ findClass :: ThingOf l Class
|
||||
, semTyCon :: ThingOf l TyCon
|
||||
, ifStuckTyCon :: ThingOf l TyCon
|
||||
, locateEffectTyCon :: ThingOf l TyCon
|
||||
}
|
||||
|
||||
|
||||
@ -43,10 +41,8 @@ data PolysemyStuff (l :: LookupState) = PolysemyStuff
|
||||
-- | All of the things we need to lookup.
|
||||
polysemyStuffLocations :: PolysemyStuff 'Locations
|
||||
polysemyStuffLocations = PolysemyStuff
|
||||
{ findClass = ("Polysemy.Internal.Union", "Find")
|
||||
, semTyCon = ("Polysemy.Internal", "Sem")
|
||||
, ifStuckTyCon = ("Polysemy.Internal.CustomErrors.Redefined", "IfStuck")
|
||||
, locateEffectTyCon = ("Polysemy.Internal.Union", "LocateEffect")
|
||||
{ findClass = ("Polysemy.Internal.Union", "Member")
|
||||
, semTyCon = ("Polysemy.Internal", "Sem")
|
||||
}
|
||||
|
||||
|
||||
@ -79,11 +75,9 @@ polysemyStuff = do
|
||||
#endif
|
||||
_ -> pure ()
|
||||
|
||||
let PolysemyStuff a b c d = polysemyStuffLocations
|
||||
let PolysemyStuff a b = polysemyStuffLocations
|
||||
PolysemyStuff <$> doLookup a
|
||||
<*> doLookup b
|
||||
<*> doLookup c
|
||||
<*> doLookup d
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -1,9 +1,7 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
|
||||
{-# OPTIONS_GHC -fdefer-type-errors #-}
|
||||
{-# OPTIONS_GHC -fno-warn-deferred-type-errors #-}
|
||||
{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
|
||||
{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
|
||||
|
||||
module AmbiguousSpec where
|
||||
|
||||
@ -38,12 +36,6 @@ uniquelyB = put $ mptc False
|
||||
uniquelyIO :: Members '[Embed IO, Embed Identity] r => Sem r ()
|
||||
uniquelyIO = embed $ liftIO $ pure ()
|
||||
|
||||
ambiguous1 :: Members '[State (Sum Int), State String] r => Sem r ()
|
||||
ambiguous1 = put mempty
|
||||
|
||||
ambiguous2 :: (Num String, Members '[State Int, State String] r) => Sem r ()
|
||||
ambiguous2 = put 10
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "example" $ do
|
||||
@ -67,9 +59,3 @@ spec = describe "example" $ do
|
||||
z <- runM . runEmbedded @Identity (pure . runIdentity) $ uniquelyIO
|
||||
z `shouldBe` ()
|
||||
|
||||
it "should not typecheck ambiguous1" $ do
|
||||
shouldNotTypecheck ambiguous1
|
||||
|
||||
it "should not typecheck ambiguous2" $ do
|
||||
shouldNotTypecheck ambiguous2
|
||||
|
||||
|
||||
@ -1,38 +0,0 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{-# OPTIONS_GHC -fdefer-type-errors -fno-warn-deferred-type-errors #-}
|
||||
|
||||
module BadSpec where
|
||||
|
||||
import Polysemy
|
||||
import Polysemy.State
|
||||
import Test.Hspec
|
||||
import Test.ShouldNotTypecheck
|
||||
|
||||
data KVStore k v m a where
|
||||
GetKV :: k -> KVStore k v m (Maybe v)
|
||||
|
||||
makeSem ''KVStore
|
||||
|
||||
positivePos :: Member (KVStore k v) r => Sem r (Maybe v)
|
||||
positivePos = do
|
||||
getKV "hello"
|
||||
|
||||
negativePos :: Member (KVStore String v) r => Sem r (Maybe Bool)
|
||||
negativePos = do
|
||||
getKV "hello"
|
||||
|
||||
badState :: Member (State a) r => Sem r ()
|
||||
badState = put ()
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "incorrectly polymorphic constraint" $ do
|
||||
it "should not typecheck in positive position" $ do
|
||||
shouldNotTypecheck positivePos
|
||||
it "should not typecheck in negative position" $ do
|
||||
shouldNotTypecheck negativePos
|
||||
it "should not typecheck badly polymorphic State" $ do
|
||||
shouldNotTypecheck badState
|
||||
|
||||
@ -36,11 +36,6 @@ flag dump-core
|
||||
manual: True
|
||||
default: False
|
||||
|
||||
flag error-messages
|
||||
description: Provide custom error messages
|
||||
manual: True
|
||||
default: True
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Polysemy
|
||||
@ -132,10 +127,6 @@ library
|
||||
if impl(ghc < 8.2.2)
|
||||
build-depends:
|
||||
unsupported-ghc-version >1 && <1
|
||||
if flag(error-messages)
|
||||
cpp-options: -DCABAL_SERIOUSLY_CMON_MATE
|
||||
else
|
||||
cpp-options: -DNO_ERROR_MESSAGES
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite polysemy-test
|
||||
|
||||
@ -2,7 +2,6 @@ module Polysemy
|
||||
( -- * Core Types
|
||||
Sem ()
|
||||
, Member
|
||||
, MemberWithError
|
||||
, Members
|
||||
|
||||
-- * Running Sem
|
||||
|
||||
@ -11,7 +11,6 @@
|
||||
module Polysemy.Internal
|
||||
( Sem (..)
|
||||
, Member
|
||||
, MemberWithError
|
||||
, Members
|
||||
, send
|
||||
, sendUsing
|
||||
|
||||
@ -7,12 +7,8 @@
|
||||
{-# OPTIONS_HADDOCK not-home #-}
|
||||
|
||||
module Polysemy.Internal.CustomErrors
|
||||
( AmbiguousSend
|
||||
, WhenStuck
|
||||
( WhenStuck
|
||||
, FirstOrder
|
||||
, UnhandledEffect
|
||||
, DefiningModule
|
||||
, DefiningModuleForEffect
|
||||
, type (<>)
|
||||
, type (%)
|
||||
) where
|
||||
@ -25,18 +21,6 @@ import Polysemy.Internal.CustomErrors.Redefined
|
||||
import Type.Errors hiding (IfStuck, WhenStuck, UnlessStuck)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | The module this effect was originally defined in. This type family is used
|
||||
-- only for providing better error messages.
|
||||
--
|
||||
-- Calls to 'Polysemy.Internal.TH.Effect.makeSem' will automatically give
|
||||
-- instances of 'DefiningModule'.
|
||||
type family DefiningModule (t :: k) :: Symbol
|
||||
|
||||
type family DefiningModuleForEffect (e :: k) :: Symbol where
|
||||
DefiningModuleForEffect (e a) = DefiningModuleForEffect e
|
||||
DefiningModuleForEffect e = DefiningModule e
|
||||
|
||||
-- These are taken from type-errors-pretty because it's not in stackage for 9.0.1
|
||||
-- See https://github.com/polysemy-research/polysemy/issues/401
|
||||
type family ToErrorMessage (t :: k) :: ErrorMessage where
|
||||
@ -77,51 +61,6 @@ type family ShowRQuoted (rstate :: EffectRowCtor) (r :: EffectRow) :: ErrorMessa
|
||||
ShowRQuoted 'ConsR r = ShowTypeBracketed r
|
||||
|
||||
|
||||
type AmbigousEffectMessage (rstate :: EffectRowCtor)
|
||||
(r :: EffectRow)
|
||||
(e :: k)
|
||||
(t :: Effect)
|
||||
(vs :: [Type])
|
||||
= "Ambiguous use of effect '" <> e <> "'"
|
||||
% "Possible fix:"
|
||||
% " add (Member (" <> t <> ") " <> ShowRQuoted rstate r <> ") to the context of "
|
||||
% " the type signature"
|
||||
% "If you already have the constraint you want, instead"
|
||||
% " add a type application to specify"
|
||||
% " " <> PrettyPrintList vs <> " directly, or activate polysemy-plugin which"
|
||||
% " can usually infer the type correctly."
|
||||
|
||||
type AmbiguousSend e r =
|
||||
(IfStuck r
|
||||
(AmbiguousSendError 'TyVarR r e)
|
||||
(Pure (AmbiguousSendError (UnstuckRState r) r e)))
|
||||
|
||||
|
||||
type family AmbiguousSendError rstate r e where
|
||||
AmbiguousSendError rstate r (e a b c d f) =
|
||||
TypeError (AmbigousEffectMessage rstate r e (e a b c d f) '[a, b c d f])
|
||||
|
||||
AmbiguousSendError rstate r (e a b c d) =
|
||||
TypeError (AmbigousEffectMessage rstate r e (e a b c d) '[a, b c d])
|
||||
|
||||
AmbiguousSendError rstate r (e a b c) =
|
||||
TypeError (AmbigousEffectMessage rstate r e (e a b c) '[a, b c])
|
||||
|
||||
AmbiguousSendError rstate r (e a b) =
|
||||
TypeError (AmbigousEffectMessage rstate r e (e a b) '[a, b])
|
||||
|
||||
AmbiguousSendError rstate r (e a) =
|
||||
TypeError (AmbigousEffectMessage rstate r e (e a) '[a])
|
||||
|
||||
AmbiguousSendError rstate r e =
|
||||
TypeError
|
||||
( "Could not deduce: (Member " <> e <> " " <> ShowRQuoted rstate r <> ") "
|
||||
% "Fix:"
|
||||
% " add (Member " <> e <> " " <> r <> ") to the context of"
|
||||
% " the type signature"
|
||||
)
|
||||
|
||||
|
||||
data FirstOrderErrorFcf :: k -> Symbol -> Exp Constraint
|
||||
type instance Eval (FirstOrderErrorFcf e fn) = $(te[t|
|
||||
UnlessPhantom
|
||||
@ -138,23 +77,5 @@ type instance Eval (FirstOrderErrorFcf e fn) = $(te[t|
|
||||
type FirstOrder (e :: Effect) fn = UnlessStuck e (FirstOrderErrorFcf e fn)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Unhandled effects
|
||||
type UnhandledEffectMsg e
|
||||
= "Unhandled effect '" <> e <> "'"
|
||||
% "Probable fix:"
|
||||
% " add an interpretation for '" <> e <> "'"
|
||||
|
||||
type CheckDocumentation e
|
||||
= " If you are looking for inspiration, try consulting"
|
||||
% " the documentation for module '" <> DefiningModuleForEffect e <> "'"
|
||||
|
||||
type family UnhandledEffect e where
|
||||
UnhandledEffect e =
|
||||
IfStuck (DefiningModule e)
|
||||
(TypeError (UnhandledEffectMsg e))
|
||||
(DoError (UnhandledEffectMsg e ':$$: CheckDocumentation e))
|
||||
|
||||
|
||||
data DoError :: ErrorMessage -> Exp k
|
||||
type instance Eval (DoError a) = TypeError a
|
||||
|
||||
@ -33,7 +33,7 @@ import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Datatype
|
||||
import Language.Haskell.TH.PprLib
|
||||
import Polysemy.Internal (Sem, send)
|
||||
import Polysemy.Internal.Union (MemberWithError)
|
||||
import Polysemy.Internal.Union (Member)
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 804
|
||||
import Prelude hiding ((<>))
|
||||
@ -71,11 +71,11 @@ data ConLiftInfo = CLInfo
|
||||
------------------------------------------------------------------------------
|
||||
-- | Given an name of datatype or some of it's constructors/fields, return
|
||||
-- datatype's name together with info about it's constructors.
|
||||
getEffectMetadata :: Name -> Q (Name, [ConLiftInfo])
|
||||
getEffectMetadata :: Name -> Q [ConLiftInfo]
|
||||
getEffectMetadata type_name = do
|
||||
dt_info <- reifyDatatype type_name
|
||||
cl_infos <- traverse makeCLInfo $ constructorName <$> datatypeCons dt_info
|
||||
pure (datatypeName dt_info, cl_infos)
|
||||
pure cl_infos
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -157,7 +157,7 @@ makeMemberConstraint r cli = makeMemberConstraint' r $ makeEffectType cli
|
||||
-- | @'makeMemberConstraint'' r type@ will produce a @Member type r@
|
||||
-- constraint.
|
||||
makeMemberConstraint' :: Name -> Type -> Pred
|
||||
makeMemberConstraint' r eff = classPred ''MemberWithError [eff, VarT r]
|
||||
makeMemberConstraint' r eff = classPred ''Member [eff, VarT r]
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -32,7 +32,6 @@ module Polysemy.Internal.TH.Effect
|
||||
import Control.Monad
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Datatype
|
||||
import Polysemy.Internal.CustomErrors (DefiningModule)
|
||||
import Polysemy.Internal.TH.Common
|
||||
|
||||
|
||||
@ -123,20 +122,11 @@ makeSem_ = genFreer False
|
||||
genFreer :: Bool -> Name -> Q [Dec]
|
||||
genFreer should_mk_sigs type_name = do
|
||||
checkExtensions [ScopedTypeVariables, FlexibleContexts, DataKinds]
|
||||
(dt_name, cl_infos) <- getEffectMetadata type_name
|
||||
tyfams_on <- isExtEnabled TypeFamilies
|
||||
def_mod_fi <- sequence [ tySynInstDCompat
|
||||
''DefiningModule
|
||||
Nothing
|
||||
[pure $ ConT dt_name]
|
||||
(LitT . StrTyLit . loc_module <$> location)
|
||||
| tyfams_on
|
||||
]
|
||||
cl_infos <- getEffectMetadata type_name
|
||||
decs <- traverse (genDec should_mk_sigs) cl_infos
|
||||
|
||||
let sigs = if should_mk_sigs then genSig <$> cl_infos else []
|
||||
|
||||
pure $ join $ def_mod_fi : sigs ++ decs
|
||||
pure $ join $ sigs ++ decs
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -20,7 +20,6 @@ module Polysemy.Internal.Union
|
||||
( Union (..)
|
||||
, Weaving (..)
|
||||
, Member
|
||||
, MemberWithError
|
||||
, weave
|
||||
, hoist
|
||||
-- * Building Unions
|
||||
@ -58,10 +57,6 @@ import {-# SOURCE #-} Polysemy.Internal
|
||||
import Polysemy.Internal.Sing (SList (SEnd, SCons))
|
||||
import Unsafe.Coerce (unsafeCoerce)
|
||||
|
||||
#ifndef NO_ERROR_MESSAGES
|
||||
import Polysemy.Internal.CustomErrors
|
||||
#endif
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | An extensible, type-safe union. The @r@ type parameter is a type-level
|
||||
@ -137,42 +132,6 @@ hoist f' (Union w (Weaving e s nt f v)) =
|
||||
Union w $ Weaving e s (f' . nt) f v
|
||||
{-# INLINE hoist #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A proof that the effect @e@ is available somewhere inside of the effect
|
||||
-- stack @r@.
|
||||
type Member e r = MemberNoError e r
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Like 'Member', but will produce an error message if the types are
|
||||
-- ambiguous. This is the constraint used for actions generated by
|
||||
-- 'Polysemy.makeSem'.
|
||||
--
|
||||
-- /Be careful with this./ Due to quirks of 'GHC.TypeLits.TypeError',
|
||||
-- the custom error messages emitted by this can potentially override other,
|
||||
-- more helpful error messages.
|
||||
-- See the discussion in
|
||||
-- <https://github.com/polysemy-research/polysemy/issues/227 Issue #227>.
|
||||
--
|
||||
-- @since 1.2.3.0
|
||||
type MemberWithError e r =
|
||||
( MemberNoError e r
|
||||
#ifndef NO_ERROR_MESSAGES
|
||||
-- NOTE: The plugin explicitly pattern matches on
|
||||
-- `WhenStuck (LocateEffect _ r) _`, so if you change this, make sure to change
|
||||
-- the corresponding implementation in
|
||||
-- Polysemy.Plugin.Fundep.solveBogusError
|
||||
, WhenStuck (LocateEffect e r) (AmbiguousSend e r)
|
||||
#endif
|
||||
)
|
||||
|
||||
type MemberNoError e r =
|
||||
( Find e r
|
||||
#ifndef NO_ERROR_MESSAGES
|
||||
, LocateEffect e r ~ '()
|
||||
#endif
|
||||
)
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A proof that @e@ is an element of @r@.
|
||||
--
|
||||
@ -229,26 +188,15 @@ sameMember _ _ =
|
||||
Nothing
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Used to detect ambiguous uses of effects. If @r@ isn't concrete,
|
||||
-- and we haven't been given @'LocateEffect' e r ~ '()@ from a
|
||||
-- @'Member' e r@ constraint, then @'LocateEffect' e r@ will get stuck.
|
||||
type family LocateEffect (t :: k) (ts :: [k]) :: () where
|
||||
#ifndef NO_ERROR_MESSAGES
|
||||
LocateEffect t '[] = UnhandledEffect t
|
||||
#endif
|
||||
LocateEffect t (t ': ts) = '()
|
||||
LocateEffect t (u ': ts) = LocateEffect t ts
|
||||
|
||||
class Find (t :: k) (r :: [k]) where
|
||||
class Member (t :: Effect) (r :: EffectRow) where
|
||||
membership' :: ElemOf t r
|
||||
|
||||
instance {-# OVERLAPPING #-} Find t (t ': z) where
|
||||
instance {-# OVERLAPPING #-} Member t (t ': z) where
|
||||
membership' = Here
|
||||
{-# INLINE membership' #-}
|
||||
|
||||
instance Find t z => Find t (_1 ': z) where
|
||||
membership' = There $ membership' @_ @t @z
|
||||
instance Member t z => Member t (_1 ': z) where
|
||||
membership' = There $ membership' @t @z
|
||||
{-# INLINE membership' #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -13,36 +13,6 @@ module TypeErrors where
|
||||
-- >>> :m +Data.Maybe
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- |
|
||||
-- >>> :{
|
||||
-- foo :: Sem r ()
|
||||
-- foo = put ()
|
||||
-- :}
|
||||
-- ...
|
||||
-- ... Ambiguous use of effect 'State'
|
||||
-- ...
|
||||
-- ... (Member (State ()) r) ...
|
||||
-- ...
|
||||
ambiguousMonoState = ()
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- |
|
||||
-- >>> :{
|
||||
-- foo :: Sem r ()
|
||||
-- foo = put 5
|
||||
-- :}
|
||||
-- ...
|
||||
-- ... Ambiguous use of effect 'State'
|
||||
-- ...
|
||||
-- ... (Member (State s0) r) ...
|
||||
-- ...
|
||||
-- ... 's0' directly...
|
||||
-- ...
|
||||
ambiguousPolyState = ()
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- |
|
||||
-- >>> :{
|
||||
@ -76,41 +46,6 @@ interpretBadFirstOrder = ()
|
||||
tooFewArgumentsReinterpret = ()
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- |
|
||||
-- >>> :{
|
||||
-- let reinterpretScrub :: Sem (Output Int ': m) a -> Sem (State Bool ': Trace ': m) a
|
||||
-- reinterpretScrub = undefined
|
||||
-- foo :: Sem '[Output Int] ()
|
||||
-- foo = pure ()
|
||||
-- foo' = reinterpretScrub foo
|
||||
-- foo'' = runState True foo'
|
||||
-- foo''' = traceToIO foo''
|
||||
-- in runM foo'''
|
||||
-- :}
|
||||
-- ...
|
||||
-- ... Unhandled effect 'Embed IO'
|
||||
-- ...
|
||||
-- ... Expected... Sem '[Embed m] (Bool, ())
|
||||
-- ... Actual... Sem '[] (Bool, ())
|
||||
-- ...
|
||||
runningTooManyEffects = ()
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- |
|
||||
-- >>> :{
|
||||
-- foo :: Sem (State Int ': r) ()
|
||||
-- foo = put ()
|
||||
-- :}
|
||||
-- ...
|
||||
-- ... Ambiguous use of effect 'State'
|
||||
-- ...
|
||||
-- ... (Member (State ()) (State Int : r)) ...
|
||||
-- ...
|
||||
ambiguousSendInConcreteR = ()
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- |
|
||||
-- >>> :{
|
||||
@ -125,30 +60,3 @@ ambiguousSendInConcreteR = ()
|
||||
-- ...
|
||||
missingArgumentToRunResourceInIO = ()
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- |
|
||||
-- >>> :{
|
||||
-- existsKV :: Member (State (Maybe Int)) r => Sem r Bool
|
||||
-- existsKV = isJust get
|
||||
-- :}
|
||||
-- ...
|
||||
-- ... Ambiguous use of effect 'State'
|
||||
-- ...
|
||||
--
|
||||
-- NOTE: This is fixed by enabling the plugin!
|
||||
missingFmap'PLUGIN = ()
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- |
|
||||
-- >>> :{
|
||||
-- foo :: Sem '[State Int, Embed IO] ()
|
||||
-- foo = output ()
|
||||
-- :}
|
||||
-- ...
|
||||
-- ... Unhandled effect 'Output ()'
|
||||
-- ...
|
||||
-- ... add an interpretation for 'Output ()'
|
||||
-- ...
|
||||
missingEffectInStack'WRONG = ()
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user