Improved errors (#143)

This shuffles around the error messages so they are only connected to code generated via makeSem. This means that badly-typed interpreters will no longer set off the eager error messages!

src/Polysemy/Internal/CustomErrors.hs

@@ -7,7 +7,8 @@
 
 module Polysemy.Internal.CustomErrors
   ( AmbiguousSend
-  , Break
+  , IfStuck
+  , WhenStuck
   , FirstOrder
   , UnhandledEffect
   , DefiningModule
@@ -30,16 +31,13 @@ type family DefiningModuleForEffect (e :: k) :: Symbol where
 
 data T1 m a
 
-type family Break (c :: Constraint)
-                  (rep :: Effect) :: Constraint where
-  Break _ T1 = ((), ())
-  Break _ c  = ()
-
 
 type family IfStuck (tyvar :: k) (b :: k1) (c :: Exp k1) :: k1 where
   IfStuck T1 b c = b
   IfStuck a  b c = Eval c
 
+type WhenStuck a b = IfStuck a b (Pure (() :: Constraint))
+
 
 type AmbigousEffectMessage r e t vs =
         ( 'Text "Ambiguous use of effect '"

src/Polysemy/Internal/TH/Common.hs

@@ -31,7 +31,8 @@ import           Data.Tuple
 import           Language.Haskell.TH
 import           Language.Haskell.TH.Datatype
 import           Language.Haskell.TH.PprLib
-import           Polysemy.Internal (Sem, Member, send)
+import           Polysemy.Internal (Sem, send)
+import           Polysemy.Internal.Union (MemberWithError)
 
 #if __GLASGOW_HASKELL__ >= 804
 import           Prelude hiding ((<>))
@@ -66,7 +67,7 @@ makeEffectType cli
 -- | @'makeMemberConstraint'' r type@ will produce a @Member type r@
 -- constraint.
 makeMemberConstraint' :: Name -> Type -> Pred
-makeMemberConstraint' r eff = classPred ''Member [eff, VarT r]
+makeMemberConstraint' r eff = classPred ''MemberWithError [eff, VarT r]
 
 
 ------------------------------------------------------------------------------

src/Polysemy/Internal/Union.hs

@@ -15,6 +15,7 @@ module Polysemy.Internal.Union
   ( Union (..)
   , Yo (..)
   , Member
+  , MemberWithError
   , weave
   , hoist
   -- * Building Unions
@@ -106,12 +107,12 @@ hoist f' (Union w (Yo e s nt f v)) = Union w $ Yo e s (f' . nt) f v
 ------------------------------------------------------------------------------
 -- | A proof that the effect @e@ is available somewhere inside of the effect
 -- stack @r@.
-type Member e r = Member' e r
+type Member e r = MemberNoError e r
 
-type Member' e r =
+type MemberWithError e r =
   ( MemberNoError e r
 #ifndef NO_ERROR_MESSAGES
-  , Break (AmbiguousSend r e) (IndexOf r (Found r e))
+  , WhenStuck (IndexOf r (Found r e)) (AmbiguousSend r e)
 #endif
   )
 

test/TypeErrors.hs

@@ -10,6 +10,7 @@ module TypeErrors where
 -- >>> :m +Polysemy.Resource
 -- >>> :m +Polysemy.State
 -- >>> :m +Polysemy.Trace
+-- >>> :m +Data.Maybe
 
 
 --------------------------------------------------------------------------------
@@ -90,16 +91,12 @@ tooFewArgumentsReinterpret = ()
 --  in runM foo'''
 -- :}
 -- ...
--- ... Ambiguous use of effect 'Lift'
+-- ... Unhandled effect 'Lift IO'
 -- ...
--- ... add (Member (Lift IO) '[]) ...
+-- ... Expected type: Sem '[Lift m] (Bool, ())
+-- ... Actual type: Sem '[] (Bool, ())
 -- ...
---
+runningTooManyEffects = ()
--- PROBLEM: We're trying to run more effects than exist in the eff row. This is
--- indeed a problem, but the error message isn't helpful.
---
--- SOLUTION: Add a special case to `AmbiguousSend` when `r ~ '[]`.
-runningTooManyEffects'WRONG = ()
 
 
 --------------------------------------------------------------------------------
@@ -128,40 +125,22 @@ missingParens'WRONG = ()
 --  in runM $ runResourceInIO foo
 -- :}
 -- ...
--- ... Ambiguous use of effect 'Lift'
+-- ... Couldn't match expected type ...
+-- ... with actual type ...
+-- ... Probable cause: ... is applied to too few arguments
 -- ...
--- ... (Member (Lift IO) r0) ...
+missingArgumentToRunResourceInIO = ()
--- ...
--- ... Could not deduce: (Member Resource r1)
--- ...
---
--- PROBLEM: This error is totally bogus. We forgot to give an argument to
--- 'runResourceInIO'. For comparison, the standard error GHC gives in this case
--- is significantly more helpful:
---
---    <interactive>:192:13: error:
---        • Couldn't match expected type ‘Sem '[Lift m] a’
---                      with actual type ‘Sem (Resource : r0) a0 -> Sem r0 a0’
---        • Probable cause: ‘runResourceInIO’ is applied to too few arguments
---          In the second argument of ‘($)’, namely ‘runResourceInIO foo’
---          In the expression: runM $ runResourceInIO foo
---          In the expression:
---            let
---              foo :: Member Resource r => Sem r ()
---              foo = undefined
---            in runM $ runResourceInIO foo
---        • Relevant bindings include
---            it :: m a (bound at <interactive>:190:2)
---    <interactive>:192:29: error:
---        • Couldn't match expected type ‘Sem r0 x -> IO x’
---                      with actual type ‘Sem r1 ()’
---        • In the first argument of ‘runResourceInIO’, namely ‘foo’
---          In the second argument of ‘($)’, namely ‘runResourceInIO foo’
---          In the expression: runM $ runResourceInIO foo
---
---
--- SOLUTION: Honestly I'm not sure!
-missingArgumentToRunResourceInIO'WRONG = ()
 
 
+--------------------------------------------------------------------------------
+-- |
+-- >>> :{
+-- existsKV :: Member (State (Maybe Int)) r => Sem r Bool
+-- existsKV = isJust get
+-- :}
+-- ...
+-- ... Ambiguous use of effect 'State'
+-- ...
+--
+missingFmap'WRONG = ()