polysemy-plugin 0.2.0.2 → 0.2.0.3
raw patch · 6 files changed
+98/−27 lines, 6 filesdep +containersdep ~inspection-testingdep ~polysemy
Dependencies added: containers
Dependency ranges changed: inspection-testing, polysemy
Files
- ChangeLog.md +7/−0
- polysemy-plugin.cabal +6/−4
- src/Polysemy/Plugin/Fundep.hs +64/−22
- test/BadSpec.hs +6/−0
- test/ExampleSpec.hs +1/−1
- test/PluginSpec.hs +14/−0
ChangeLog.md view
@@ -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
polysemy-plugin.cabal view
@@ -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 <https://github.com/isovector/polysemy/tree/master/polysemy-plugin#readme> 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
src/Polysemy/Plugin/Fundep.hs view
@@ -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
test/BadSpec.hs view
@@ -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
test/ExampleSpec.hs view
@@ -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
test/PluginSpec.hs view
@@ -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