mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-09-11 02:25:43 +03:00
polysemy-plugin: Reject ununifiable effect candidates early (#221)
* polysemy-plugin: Reject ununifiable effect candidates early * Bump version, update changelog, expand tests
This commit is contained in:
parent
3fe084d4ed
commit
7bda143878
@ -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
|
||||
|
@ -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"
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
62
polysemy-plugin/test/MultipleVarsSpec.hs
Normal file
62
polysemy-plugin/test/MultipleVarsSpec.hs
Normal file
@ -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, ()))
|
Loading…
Reference in New Issue
Block a user