diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Changelog for polysemy-plugin +## 0.2.0.3 (2019-06-13) + +- Fixed a bug where the plugin could (incorrectly) loop indefinitely attempting + to solve some constraints. +- Changed the lower-bound of `inspection-testing` to allow Cabal users to + successfully run the test-suite. + ## 0.2.0.2 (2019-06-09) - Fixed a bug where the plugin wouldn't attempt to unify effects recursively diff --git a/polysemy-plugin.cabal b/polysemy-plugin.cabal --- a/polysemy-plugin.cabal +++ b/polysemy-plugin.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 833a0e985a778fbc94a5830306c89c74928839bc5d967121db306b2744cfe1a5 +-- hash: 65e9d7abb09d631f2fc5d94e0710c5770b02658b1e699b39a00e2f673c81beb1 name: polysemy-plugin -version: 0.2.0.2 +version: 0.2.0.3 synopsis: Disambiguate obvious uses of effects. description: Please see the README on GitHub at category: Polysemy @@ -40,6 +40,7 @@ default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UnicodeSyntax build-depends: base >=4.7 && <5 + , containers >=0.6 && <=0.7 , ghc >=8.6.3 && <8.7 , ghc-tcplugins-extra >=0.3 && <0.4 , polysemy >=0.1 @@ -64,11 +65,12 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N -fplugin=Polysemy.Plugin -O2 build-depends: base >=4.7 && <5 + , containers >=0.6 && <=0.7 , ghc >=8.6.3 && <8.7 , ghc-tcplugins-extra >=0.3 && <0.4 , hspec >=2.6.0 && <3 - , inspection-testing >=0.4.1.1 && <0.5 - , polysemy >=0.1 + , inspection-testing >=0.4.2 && <0.5 + , polysemy >=0.3 , polysemy-plugin , should-not-typecheck >=2.1.0 && <3 , syb >=0.7 && <0.8 diff --git a/src/Polysemy/Plugin/Fundep.hs b/src/Polysemy/Plugin/Fundep.hs --- a/src/Polysemy/Plugin/Fundep.hs +++ b/src/Polysemy/Plugin/Fundep.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + ------------------------------------------------------------------------------ -- The MIT License (MIT) -- @@ -30,22 +32,25 @@ module Polysemy.Plugin.Fundep (fundepPlugin) where -import Class -import CoAxiom -import Control.Monad -import Data.Bifunctor -import Data.List -import Data.Maybe -import FastString (fsLit) -import GHC (ModuleName) -import GHC.TcPluginM.Extra (lookupModule, lookupName) -import Module (mkModuleName) -import OccName (mkTcOcc) -import TcPluginM (TcPluginM, tcLookupClass) -import TcRnTypes -import TcSMonad hiding (tcLookupClass) -import TyCoRep (Type (..)) -import Type +import Class +import CoAxiom +import Control.Monad +import Data.Bifunctor +import Data.Function (on) +import Data.IORef +import Data.List +import Data.Maybe +import qualified Data.Set as S +import FastString (fsLit) +import GHC (ModuleName) +import GHC.TcPluginM.Extra (lookupModule, lookupName) +import Module (mkModuleName) +import OccName (mkTcOcc) +import TcPluginM (TcPluginM, tcLookupClass, tcPluginIO) +import TcRnTypes +import TcSMonad hiding (tcLookupClass) +import TyCoRep (Type (..)) +import Type polysemyInternalUnion :: ModuleName @@ -56,7 +61,8 @@ { tcPluginInit = do md <- lookupModule polysemyInternalUnion (fsLit "polysemy") monadEffectTcNm <- lookupName md (mkTcOcc "Find") - tcLookupClass monadEffectTcNm + (,) <$> tcPluginIO (newIORef S.empty) + <*> tcLookupClass monadEffectTcNm , tcPluginSolve = solveFundep , tcPluginStop = const (return ()) } @@ -94,12 +100,21 @@ ] -mkWanted :: Bool -> CtLoc -> Type -> Type -> TcPluginM (Maybe Ct) +mkWanted + :: Bool + -> CtLoc + -> Type + -> Type + -> TcPluginM (Maybe ( (OrdType, OrdType) -- the types we want to unify + , Ct -- the constraint + )) mkWanted must_unify loc wanted given = if (not must_unify || canUnify wanted given) then do (ev, _) <- unsafeTcPluginTcM $ runTcSDeriveds $ newWantedEq loc Nominal wanted given - pure $ Just $ CNonCanonical ev + pure $ Just ( (OrdType wanted, OrdType given) + , CNonCanonical ev + ) else pure Nothing @@ -111,9 +126,31 @@ let grouped = groupBy eq as in zipWith (curry $ bimap head length) grouped grouped -solveFundep :: Class -> [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginResult + +------------------------------------------------------------------------------ +-- | 'Type's don't have 'Eq' or 'Ord' instances by default, even though there +-- are functions in GHC that implement these operations. This newtype gives us +-- those instances. +newtype OrdType = OrdType + { getOrdType :: Type + } + +instance Eq OrdType where + (==) = eqType `on` getOrdType + +instance Ord OrdType where + compare = nonDetCmpType `on` getOrdType + + + +solveFundep + :: (IORef (S.Set (OrdType, OrdType)), Class) + -> [Ct] + -> [Ct] + -> [Ct] + -> TcPluginM TcPluginResult solveFundep _ _ _ [] = pure $ TcPluginOk [] [] -solveFundep effCls giv _ want = do +solveFundep (ref, effCls) giv _ want = do let wantedEffs = allMonadEffectConstraints effCls want givenEffs = snd <$> allMonadEffectConstraints effCls giv num_wanteds_by_r = countLength eqType $ fmap (thd . snd) wantedEffs @@ -129,5 +166,10 @@ _ -> pure Nothing Just eff' -> mkWanted True loc eff eff' - pure $ TcPluginOk [] $ catMaybes eqs + already_emitted <- tcPluginIO $ readIORef ref + let new_wanteds = filter (not . flip S.member already_emitted . fst) + $ catMaybes eqs + + tcPluginIO $ modifyIORef ref $ S.union $ S.fromList $ fmap fst new_wanteds + pure . TcPluginOk [] $ fmap snd new_wanteds diff --git a/test/BadSpec.hs b/test/BadSpec.hs --- a/test/BadSpec.hs +++ b/test/BadSpec.hs @@ -5,6 +5,7 @@ module BadSpec where import Polysemy +import Polysemy.State import Test.Hspec import Test.ShouldNotTypecheck @@ -21,7 +22,10 @@ negativePos = do getKV "hello" +badState :: Member (State a) r => Sem r () +badState = put () + spec :: Spec spec = do describe "incorrectly polymorphic constraint" $ do @@ -29,4 +33,6 @@ shouldNotTypecheck positivePos it "should not typecheck in negative position" $ do shouldNotTypecheck negativePos + it "should not typecheck badly polymorphic State" $ do + shouldNotTypecheck badState diff --git a/test/ExampleSpec.hs b/test/ExampleSpec.hs --- a/test/ExampleSpec.hs +++ b/test/ExampleSpec.hs @@ -34,7 +34,7 @@ _ -> writeTTY i >> writeTTY "no exceptions" foo :: IO (Either CustomException ()) -foo = (runM .@ runResource .@@ runErrorInIO @CustomException) $ runTeletypeIO program +foo = (runM .@ runResourceInIO .@@ runErrorInIO @CustomException) $ runTeletypeIO program spec :: Spec spec = describe "example" $ do diff --git a/test/PluginSpec.hs b/test/PluginSpec.hs --- a/test/PluginSpec.hs +++ b/test/PluginSpec.hs @@ -12,6 +12,7 @@ import Polysemy.State import Polysemy.Output import Test.Hspec +import Unsafe.Coerce @@ -55,6 +56,15 @@ deriving (IsString, Eq, Show) +data Janky = forall s. Janky (forall i. Sem '[State s] ()) + +jankyState :: Janky +jankyState = Janky $ put True + +unsafeUnjank :: Janky -> Sem '[State Bool] () +unsafeUnjank (Janky sem) = unsafeCoerce sem + + spec :: Spec spec = do describe "State effect" $ do @@ -95,6 +105,10 @@ it "should interpret against MyString" $ do flipShouldBe ("hello" :: MyString, ()) . run $ runState "nothing" oStrState + + describe "existential state" $ do + it "JankyState should compile" $ do + flipShouldBe (True, ()) . run $ runState False $ unsafeUnjank jankyState describe "Error effect" $ do