diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for polysemy-plugin +## 0.2.2.0 (2019-07-04) + +- The plugin will now prevent some false-positives in `polysemy`'s error + messages +- Updated the lower bounds to `polysemy-0.6.0.0` + ## 0.2.1.1 (2019-06-26) - Updated the test suite to test against `polysemy-0.5.0.0` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # polysemy-plugin -[![Build Status](https://api.travis-ci.org/isovector/polysemy.svg?branch=master)](https://travis-ci.org/isovector/polysemy) +[![Build Status](https://api.travis-ci.org/polysemy-research/polysemy.svg?branch=master)](https://travis-ci.org/isovector/polysemy-research) [![Hackage](https://img.shields.io/hackage/v/polysemy-plugin.svg?logo=haskell)](https://hackage.haskell.org/package/polysemy-plugin) ## Dedication 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: df45f7f2f338b1cac819daf739829c387626de2fb09a1e1c2424004faf90d6b8 +-- hash: 63b03550f0fe1e13941505a11116fac8e6eef8a871dff51b30d2bca2263b2a75 name: polysemy-plugin -version: 0.2.1.1 +version: 0.2.2.0 synopsis: Disambiguate obvious uses of effects. description: Please see the README on GitHub at category: Polysemy @@ -31,7 +31,6 @@ exposed-modules: Polysemy.Plugin Polysemy.Plugin.Fundep - Polysemy.Plugin.InlineRecursiveCalls Polysemy.Plugin.Phases other-modules: Paths_polysemy_plugin @@ -43,7 +42,7 @@ , containers >=0.5 && <0.7 , ghc >=8.4.4 && <9 , ghc-tcplugins-extra >=0.3 && <0.4 - , polysemy >=0.1 + , polysemy >=0.6 , syb >=0.7 && <0.8 , transformers >=0.5.2.0 && <0.6 default-language: Haskell2010 @@ -53,10 +52,11 @@ main-is: Main.hs other-modules: BadSpec + DoctestSpec ExampleSpec - InlineRecursiveCallsSpec LegitimateTypeErrorSpec PluginSpec + TypeErrors VDQSpec Paths_polysemy_plugin hs-source-dirs: @@ -68,11 +68,12 @@ build-depends: base >=4.9 && <5 , containers >=0.5 && <0.7 + , doctest >=0.16.0.1 && <0.17 , ghc >=8.4.4 && <9 , ghc-tcplugins-extra >=0.3 && <0.4 , hspec >=2.6.0 && <3 , inspection-testing >=0.4.2 && <0.5 - , polysemy >=0.5.0.0 + , polysemy >=0.6.0.0 , polysemy-plugin , should-not-typecheck >=2.1.0 && <3 , syb >=0.7 && <0.8 diff --git a/src/Polysemy/Plugin.hs b/src/Polysemy/Plugin.hs --- a/src/Polysemy/Plugin.hs +++ b/src/Polysemy/Plugin.hs @@ -61,37 +61,31 @@ ( plugin ) where -import CoreMonad -import DynFlags -import GHC (ModuleName, moduleName) -import Module (mkModuleName, moduleSetElts) import Polysemy.Plugin.Fundep -import Polysemy.Plugin.InlineRecursiveCalls - #if __GLASGOW_HASKELL__ >= 810 import Polysemy.Plugin.Phases #endif -import Plugins (Plugin (..), defaultPlugin) -#if __GLASGOW_HASKELL__ >= 806 -import Plugins (PluginRecompile(..)) -#endif +import GhcPlugins +------------------------------------------------------------------------------ plugin :: Plugin plugin = defaultPlugin { tcPlugin = const $ Just fundepPlugin , installCoreToDos = const installTodos #if __GLASGOW_HASKELL__ >= 806 - , pluginRecompile = const $ pure NoForceRecompile + , pluginRecompile = purePlugin #endif } - +------------------------------------------------------------------------------ +#if __GLASGOW_HASKELL__ >= 810 polysemyInternal :: ModuleName polysemyInternal = mkModuleName "Polysemy.Internal" - +#endif +------------------------------------------------------------------------------ installTodos :: [CoreToDo] -> CoreM [CoreToDo] installTodos todos = do dflags <- getDynFlags @@ -99,13 +93,11 @@ case optLevel dflags of 0 -> pure todos _ -> do - mods <- moduleSetElts <$> getVisibleOrphanMods - pure $ case any ((== polysemyInternal) . moduleName) mods of - True -> CoreDoPluginPass "Inline Recursive Calls" inlineRecursiveCalls - : todos #if __GLASGOW_HASKELL__ >= 810 - ++ extraPhases dflags + mods <- moduleSetElts <$> getVisibleOrphanMods + pure $ todos ++ bool [] + (extraPhases dflags) + (any ((== polysemyInternal) . moduleName) mods) +#else + pure todos #endif - False -> todos - - 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,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------ -- The MIT License (MIT) @@ -38,38 +39,88 @@ import Control.Monad import Data.Bifunctor import Data.Bool +import Data.Coerce import Data.Function (on) import Data.IORef +import qualified Data.Kind as K import Data.List import Data.Maybe import qualified Data.Set as S import FastString (fsLit) -import GHC (ModuleName) +import GHC (TyCon, Name) import GHC.TcPluginM.Extra (lookupModule, lookupName) import Module (mkModuleName) import OccName (mkTcOcc) -import TcPluginM (TcPluginM, tcLookupClass, tcPluginIO) +import TcEvidence +import TcPluginM (TcPluginM, tcLookupClass, tcLookupTyCon, tcPluginIO) import TcRnTypes import TcSMonad hiding (tcLookupClass) import TyCoRep (Type (..)) import Type -polysemyInternalUnion :: ModuleName -polysemyInternalUnion = mkModuleName "Polysemy.Internal.Union" +data LookupState + = Locations + | Things + +type family ThingOf (l :: LookupState) (a :: K.Type) :: K.Type where + ThingOf 'Locations _ = (String, String) + ThingOf 'Things a = a + + +data PolysemyStuff (l :: LookupState) = PolysemyStuff + { findClass :: ThingOf l Class + , semTyCon :: ThingOf l TyCon + , ifStuckTyCon :: ThingOf l TyCon + , indexOfTyCon :: ThingOf l TyCon + } + + +class CanLookup a where + lookupStrategy :: Name -> TcPluginM a + +instance CanLookup Class where + lookupStrategy = tcLookupClass + +instance CanLookup TyCon where + lookupStrategy = tcLookupTyCon + + +doLookup :: CanLookup a => ThingOf 'Locations a -> TcPluginM (ThingOf 'Things a) +doLookup (mdname, name) = do + md <- lookupModule (mkModuleName mdname) $ fsLit "polysemy" + nm <- lookupName md $ mkTcOcc name + lookupStrategy nm + + +lookupEverything :: PolysemyStuff 'Locations -> TcPluginM (PolysemyStuff 'Things) +lookupEverything (PolysemyStuff a b c d) = + PolysemyStuff <$> doLookup a + <*> doLookup b + <*> doLookup c + <*> doLookup d + + +polysemyStuffLocations :: PolysemyStuff 'Locations +polysemyStuffLocations = PolysemyStuff + { findClass = ("Polysemy.Internal.Union", "Find") + , semTyCon = ("Polysemy.Internal", "Sem") + , ifStuckTyCon = ("Polysemy.Internal.CustomErrors.Redefined", "IfStuck") + , indexOfTyCon = ("Polysemy.Internal.Union", "IndexOf") + } + + fundepPlugin :: TcPlugin fundepPlugin = TcPlugin - { tcPluginInit = do - md <- lookupModule polysemyInternalUnion (fsLit "polysemy") - monadEffectTcNm <- lookupName md (mkTcOcc "Find") + { tcPluginInit = (,) <$> tcPluginIO (newIORef S.empty) - <*> tcLookupClass monadEffectTcNm + <*> lookupEverything polysemyStuffLocations , tcPluginSolve = solveFundep , tcPluginStop = const (return ()) } -allMonadEffectConstraints :: Class -> [Ct] -> [(CtLoc, (Type, Type, Type))] -allMonadEffectConstraints cls cts = +allMonadEffectConstraints :: PolysemyStuff 'Things -> [Ct] -> [(CtLoc, (Type, Type, Type))] +allMonadEffectConstraints (findClass -> cls) cts = [ (ctLoc cd, (effName, eff, r)) | cd@CDictCan{cc_class = cls', cc_tyargs = [_, r, eff]} <- cts , cls == cls' @@ -189,16 +240,57 @@ mustUnify (InterpreterUse b) = b +------------------------------------------------------------------------------ +-- | Given a list of 'Ct's, find any that are of the form +-- @[Irred] Sem r a ~ Something@, and return their @r@s. +getBogusRs :: PolysemyStuff 'Things -> [Ct] -> [Type] +getBogusRs stuff wanteds = do + CIrredCan ct _ <- wanteds + case splitAppTys $ ctev_pred ct of + (_, [_, _, a, b]) -> + maybeToList (getRIfSem stuff a) ++ maybeToList (getRIfSem stuff b) + (_, _) -> [] + + +------------------------------------------------------------------------------ +-- | Take the @r@ out of @Sem r a@. +getRIfSem :: PolysemyStuff 'Things -> Type -> Maybe Type +getRIfSem (semTyCon -> sem) ty = + case splitTyConApp_maybe ty of + Just (tycon, [r, _]) | tycon == sem -> pure r + _ -> Nothing + + +------------------------------------------------------------------------------ +-- | Given a list of bogus @r@s, and the wanted constraints, produce bogus +-- evidence terms that will prevent @IfStuck (IndexOf r _) _ _@ error messsages. +solveBogusError :: PolysemyStuff 'Things -> [Type] -> [Ct] -> [(EvTerm, Ct)] +solveBogusError stuff bogus wanteds = do + ct@(CIrredCan ce _) <- wanteds + case splitTyConApp_maybe $ ctev_pred ce of + Just (stuck, [_, _, expr, _, _]) | stuck == ifStuckTyCon stuff -> do + case splitTyConApp_maybe expr of + Just (idx, [_, r, _]) | idx == indexOfTyCon stuff -> do + case elem @[] (OrdType r) $ coerce bogus of + True -> pure (error "bogus proof for stuck type family", ct) + False -> [] + _ -> [] + _ -> [] + + solveFundep - :: (IORef (S.Set (OrdType, OrdType)), Class) + :: (IORef (S.Set (OrdType, OrdType)), PolysemyStuff 'Things) -> [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginResult solveFundep _ _ _ [] = pure $ TcPluginOk [] [] -solveFundep (ref, effCls) giv _ want = do - let wantedEffs = allMonadEffectConstraints effCls want - givenEffs = snd <$> allMonadEffectConstraints effCls giv +solveFundep (ref, stuff) giv _ want = do + let bogus = getBogusRs stuff want + solved_bogus = solveBogusError stuff bogus want + + let wantedEffs = allMonadEffectConstraints stuff want + givenEffs = snd <$> allMonadEffectConstraints stuff giv num_wanteds_by_r = countLength eqType $ fmap (thd . snd) wantedEffs must_unify r = let Just num_wanted = find (eqType r . fst) num_wanteds_by_r @@ -217,5 +309,5 @@ $ catMaybes eqs tcPluginIO $ modifyIORef ref $ S.union $ S.fromList $ fmap fst new_wanteds - pure . TcPluginOk [] $ fmap snd new_wanteds + pure . TcPluginOk solved_bogus $ fmap snd new_wanteds diff --git a/src/Polysemy/Plugin/InlineRecursiveCalls.hs b/src/Polysemy/Plugin/InlineRecursiveCalls.hs deleted file mode 100644 --- a/src/Polysemy/Plugin/InlineRecursiveCalls.hs +++ /dev/null @@ -1,91 +0,0 @@ -module Polysemy.Plugin.InlineRecursiveCalls - ( inlineRecursiveCalls - ) where - -import BasicTypes -import Control.Monad -import Control.Monad.Trans.State -import CoreMonad -import CoreSyn -import Data.Monoid -import Data.Traversable -import GHC -import Generics.SYB -import HscTypes -import IdInfo -import Name -import UniqSupply -import Unique -import Var - - -inlineRecursiveCalls :: ModGuts -> CoreM ModGuts -inlineRecursiveCalls mg = do - uniqSupply <- liftIO $ mkSplitUniqSupply '\x264a' - flip evalStateT uniqSupply $ do - bs <- traverse loopbreakBinds $ mg_binds mg - pure $ mg { mg_binds = bs } - - -type CoreSupplyM = StateT UniqSupply CoreM - - -getUniq :: CoreSupplyM Unique -getUniq = do - (u, s) <- gets takeUniqFromSupply - put s - pure u - - -containsName :: CoreBndr -> CoreExpr -> Bool -containsName n e = - getAny $ - everything - mappend - (mkQ (Any False) $ matches n) - e - - -matches :: CoreBndr -> CoreExpr -> Any -matches n (Var n') | n == n' = Any True -matches _ _ = Any False - - -replace :: Id -> Id -> Expr CoreBndr -> Expr CoreBndr -replace n n' = everywhere $ mkT go - where - go :: Expr CoreBndr -> Expr CoreBndr - go v@(Var nn) - | nn == n = Var n' - | otherwise = v - go x = x - - -loopbreaker :: CoreBndr -> CoreExpr -> CoreSupplyM [(Var, CoreExpr)] -loopbreaker n b = do - u <- getUniq - let Just info = zapUsageInfo $ idInfo n - info' = setInlinePragInfo info alwaysInlinePragma - n' = mkLocalVar - (idDetails n) - (mkInternalName u (occName n) noSrcSpan) - (idType n) - $ setInlinePragInfo vanillaIdInfo neverInlinePragma - pure [ (lazySetIdInfo n info', replace n n' b) - , (n', Var n) - ] - - --- TODO(sandy): Make this only break loops in functions whose type ends in `Sem --- * * -> Sem * *` for wildcards `*` -loopbreakBinds - :: Bind CoreBndr - -> CoreSupplyM (Bind CoreBndr) -loopbreakBinds nr@(NonRec n b) - | containsName n b = Rec <$> loopbreaker n b - | otherwise = pure nr -loopbreakBinds (Rec bs) = fmap (Rec . join) . for bs $ \(n, b) -> - case containsName n b of - False -> pure [(n, b)] - True -> loopbreaker n b - diff --git a/test/DoctestSpec.hs b/test/DoctestSpec.hs new file mode 100644 --- /dev/null +++ b/test/DoctestSpec.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE CPP #-} + +module DoctestSpec where + +import Test.Hspec +import Test.DocTest + +spec :: Spec +spec = parallel $ describe "Error messages" $ it "should pass the doctest" $ doctest + [ "--fast" + , "-fobject-code" + , "-XDataKinds" + , "-XDeriveFunctor" + , "-XFlexibleContexts" + , "-XGADTs" + , "-XLambdaCase" + , "-XPolyKinds" + , "-XRankNTypes" + , "-XScopedTypeVariables" + , "-XStandaloneDeriving" + , "-XTypeApplications" + , "-XTypeFamilies" + , "-XTypeOperators" + , "-XUnicodeSyntax" + +#if __GLASGOW_HASKELL__ < 806 + , "-XMonadFailDesugaring" + , "-XTypeInType" +#endif + + , "test/TypeErrors.hs" + ] diff --git a/test/InlineRecursiveCallsSpec.hs b/test/InlineRecursiveCallsSpec.hs deleted file mode 100644 --- a/test/InlineRecursiveCallsSpec.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} - -{-# OPTIONS_GHC -O2 #-} - -#if __GLASGOW_HASKELL__ < 804 -{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin #-} -#endif - -module InlineRecursiveCallsSpec - ( spec - ) where - -import qualified Control.Monad.Trans.State as S -import Data.Tuple -import Polysemy.Internal -import Polysemy.Internal.Union -import Test.Hspec -import Test.Inspection - - -spec :: Spec -spec = describe "inlining recursive calls" $ do - it "should explicitly break recursion" $ do - shouldSucceed $(inspectTest $ 'recursive === 'mutual) - - -isSuccess :: Result -> Bool -isSuccess (Success _) = True -isSuccess (Failure e) = error e - - -shouldSucceed :: Result -> Expectation -shouldSucceed r = r `shouldSatisfy` isSuccess - - ------------------------------------------------------------------------------- -recursive - :: (∀ x m. e m x -> S.StateT s (Sem r) x) - -> s - -> Sem (e ': r) a - -> Sem r (s, a) -recursive f s (Sem m) = Sem $ \k -> - fmap swap $ flip S.runStateT s $ m $ \u -> - case decomp u of - Left x -> S.StateT $ \s' -> - k . fmap swap - . weave (s', ()) - (uncurry $ recursive f) - (Just . snd) - $ x - Right (Yo e z _ y _) -> - fmap (y . (<$ z)) $ S.mapStateT (usingSem k) $ f e - - ------------------------------------------------------------------------------- -mutual - :: (∀ x m. e m x -> S.StateT s (Sem r) x) - -> s - -> Sem (e ': r) a - -> Sem r (s, a) -mutual f s (Sem m) = Sem $ \k -> - fmap swap $ flip S.runStateT s $ m $ \u -> - case decomp u of - Left x -> S.StateT $ \s' -> - k . fmap swap - . weave (s', ()) - (uncurry $ mutual2 f) - (Just . snd) - $ x - Right (Yo e z _ y _) -> - fmap (y . (<$ z)) $ S.mapStateT (usingSem k) $ f e -{-# INLINE mutual #-} - -mutual2 - :: (∀ x m. e m x -> S.StateT s (Sem r) x) - -> s - -> Sem (e ': r) a - -> Sem r (s, a) -mutual2 = mutual -{-# NOINLINE mutual2 #-} - diff --git a/test/TypeErrors.hs b/test/TypeErrors.hs new file mode 100644 --- /dev/null +++ b/test/TypeErrors.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module TypeErrors where + +-- $setup +-- >>> default () +-- >>> :set -package polysemy-plugin +-- ... +-- >>> :set -fplugin=Polysemy.Plugin +-- >>> :m +Polysemy +-- >>> :m +Polysemy.State +-- >>> :m +Data.Maybe + + +-------------------------------------------------------------------------------- +-- | +-- >>> :{ +-- existsKV :: Member (State (Maybe Int)) r => Sem r Bool +-- existsKV = isJust get +-- :} +-- ... +-- ... Couldn't match expected type ...Sem r Bool... with actual type ...Bool... +-- ... +-- ... Couldn't match expected type ...Maybe a0... +-- ... with actual type ...Sem r0 a1... +-- ... +missingFmap = () +