polysemy-plugin: Reject ununifiable effect candidates early (#221)

* polysemy-plugin: Reject ununifiable effect candidates early

* Bump version, update changelog, expand tests

polysemy-plugin/ChangeLog.md

@@ -1,5 +1,14 @@
 # Changelog for polysemy-plugin
 
+
+## 0.2.3.0 (TODO)
+- The plugin will now choose between given effects based on the ability to unify them.
+    This makes it possible for disambiguation to kick in even when using multiple
+    instances of the same effect with different type variables,
+    as long as type annotations/applications are used to
+    target a specific instance.
+- Updated the test suite to test against `polysemy-1.2.0.0`.
+
 ## 0.2.2.0 (2019-07-04)
 
 - The plugin will now prevent some false-positives in `polysemy`'s error

polysemy-plugin/package.yaml

@@ -1,5 +1,5 @@
 name:                polysemy-plugin
-version:             0.2.2.0
+version:             0.2.3.0
 github:              "isovector/polysemy"
 license:             BSD3
 author:              "Sandy Maguire"

polysemy-plugin/polysemy-plugin.cabal

@@ -4,10 +4,10 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: a3e70728f8ab4d2e3e7b2727e004b88a497852dd2b44df914418e070f5171e92
+-- hash: 01634ce3c7ac101e60c1a02f8ccad7ec499c02a04b66e5d9dd5993f314318097
 
 name:           polysemy-plugin
-version:        0.2.2.0
+version:        0.2.3.0
 synopsis:       Disambiguate obvious uses of effects.
 description:    Please see the README on GitHub at <https://github.com/isovector/polysemy/tree/master/polysemy-plugin#readme>
 category:       Polysemy
@@ -58,6 +58,7 @@ test-suite polysemy-plugin-test
       DoctestSpec
       ExampleSpec
       LegitimateTypeErrorSpec
+      MultipleVarsSpec
       PluginSpec
       TypeErrors
       VDQSpec

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

@@ -88,16 +88,17 @@ getFindConstraints (findClass -> cls) cts = do
 
 ------------------------------------------------------------------------------
 -- | If there's only a single @Member@ in the same @r@ whose effect name
--- matches, return its effect (including tyvars.)
+-- matches and could possibly unify, return its effect (including tyvars.)
 findMatchingEffectIfSingular
     :: FindConstraint
     -> [FindConstraint]
     -> Maybe Type
-findMatchingEffectIfSingular (FindConstraint _ eff_name _ r) ts =
+findMatchingEffectIfSingular (FindConstraint _ eff_name wanted r) ts =
   singleListToJust $ do
     FindConstraint _ eff_name' eff' r' <- ts
     guard $ eqType eff_name eff_name'
     guard $ eqType r r'
+    guard $ canUnifyRecursive FunctionDef wanted eff'
     pure eff'
 
 
@@ -107,6 +108,23 @@ getEffName :: Type -> Type
 getEffName t = fst $ splitAppTys t
 
 
+------------------------------------------------------------------------------
+-- | Generate a wanted unification for the effect described by the
+-- 'FindConstraint' and the given effect.
+mkWantedForce
+  :: FindConstraint
+  -> Type
+  -> TcPluginM (Unification, Ct)
+mkWantedForce fc given = do
+  (ev, _) <- unsafeTcPluginTcM
+           . runTcSDeriveds
+           $ newWantedEq (fcLoc fc) Nominal wanted given
+  pure ( Unification (OrdType wanted) (OrdType given)
+       , CNonCanonical ev
+       )
+  where
+    wanted = fcEffect fc
+
 ------------------------------------------------------------------------------
 -- | Generate a wanted unification for the effect described by the
 -- 'FindConstraint' and the given effect --- if they can be unified in this
@@ -117,13 +135,8 @@ mkWanted
     -> Type  -- ^ The given effect.
     -> TcPluginM (Maybe (Unification, Ct))
 mkWanted fc solve_ctx given =
-  whenA (not (mustUnify solve_ctx) || canUnifyRecursive solve_ctx wanted given) $ do
-    (ev, _) <- unsafeTcPluginTcM
-             . runTcSDeriveds
-             $ newWantedEq (fcLoc fc) Nominal wanted given
-    pure ( Unification (OrdType wanted) (OrdType given)
-         , CNonCanonical ev
-         )
+  whenA (not (mustUnify solve_ctx) || canUnifyRecursive solve_ctx wanted given) $
+    mkWantedForce fc given
   where
     wanted = fcEffect fc
 
@@ -202,8 +215,9 @@ solveFundep (ref, stuff) given _ wanted = do
     let r  = fcRow fc
     case findMatchingEffectIfSingular fc given_finds of
       -- We found a real given, therefore we are in the context of a function
-      -- with an explicit @Member e r@ constraint.
-      Just eff' -> mkWanted fc FunctionDef eff'
+      -- with an explicit @Member e r@ constraint. We also know it can
+      -- be unified (although it may generate unsatisfiable constraints).
+      Just eff' -> Just <$> mkWantedForce fc eff'
 
       -- Otherwise, check to see if @r ~ (e ': r')@. If so, pretend we're
       -- trying to solve a given @Member e r@. But this can only happen in the

polysemy-plugin/test/MultipleVarsSpec.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
+
+module MultipleVarsSpec where
+
+import Polysemy
+import Polysemy.State
+
+import Test.Hspec
+
+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 ()
+
+makeSem ''TaggedState
+
+runTaggedState :: forall k s r a
+                . s
+               -> Sem (TaggedState k s ': r) a
+               -> Sem r (s, a)
+runTaggedState s =
+    (runState s .)
+  $ reinterpret
+  $ \case
+    TaggedGet -> get
+    TaggedPut s -> put s
+
+test :: Members '[
+          TaggedState Char Int
+        , TaggedState Bool Int
+        ] r
+     => Sem r ()
+test = do
+  taggedPut @Bool 10
+  taggedPut @Char (-10)
+
+spec :: Spec
+spec = describe "Using multiple, but ununifiable instances\
+               \ of the same effect" $ do
+  it "should get disambiguated and compile, \
+     \and actions should target the right effects." $ do
+    let
+      res1 =
+          run
+        . runTaggedState @Char 0
+        . runTaggedState @Bool 7
+        $ test
+      res2 =
+          run
+        . runTaggedState @Bool 0
+        . runTaggedState @Char 7
+        $ test
+      res3 =
+          run
+        . runTaggedState @Bool 0
+        . runTaggedState @Char 7
+        $ do
+          taggedPut @Bool 10
+          taggedPut @Char (-10)
+    res1 `shouldBe` (-10, (10, ()))
+    res2 `shouldBe` (10, (-10, ()))
+    res3 `shouldBe` (10, (-10, ()))