Remove custom type errors from Member

README.md

@@ -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.

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

polysemy-plugin/polysemy-plugin.cabal

@@ -78,7 +78,6 @@ test-suite polysemy-plugin-test
   main-is: Main.hs
   other-modules:
       AmbiguousSpec
-      BadSpec
       DoctestSpec
       ExampleSpec
       InsertSpec

polysemy-plugin/src/Polysemy/Plugin/Fundep.hs

@@ -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
 

polysemy-plugin/src/Polysemy/Plugin/Fundep/Stuff.hs

@@ -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,19 +34,15 @@ 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
   }
 
 
 ------------------------------------------------------------------------------
 -- | 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
 
 
 ------------------------------------------------------------------------------

polysemy-plugin/test/AmbiguousSpec.hs

@@ -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
-

polysemy.cabal

@@ -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

src/Polysemy.hs

@@ -2,7 +2,6 @@ module Polysemy
   ( -- * Core Types
     Sem ()
   , Member
-  , MemberWithError
   , Members
 
     -- * Running Sem

src/Polysemy/Internal.hs

@@ -11,7 +11,6 @@
 module Polysemy.Internal
   ( Sem (..)
   , Member
-  , MemberWithError
   , Members
   , send
   , sendUsing

src/Polysemy/Internal/CustomErrors.hs

@@ -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