polysemy-plugin 0.2.1.1 → 0.2.2.0

raw patch · 9 files changed

+194/−216 lines, 9 filesdep +doctestdep ~polysemyPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: doctest

Dependency ranges changed: polysemy

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• README.md +1/−1
• polysemy-plugin.cabal +7/−6
• src/Polysemy/Plugin.hs +13/−21
• src/Polysemy/Plugin/Fundep.hs +107/−15
• src/Polysemy/Plugin/InlineRecursiveCalls.hs +0/−91
• test/DoctestSpec.hs +32/−0
• test/InlineRecursiveCallsSpec.hs +0/−82
• test/TypeErrors.hs +28/−0

@@ -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`

@@ -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

@@ -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 <https://github.com/isovector/polysemy/tree/master/polysemy-plugin#readme> 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

@@ -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--

@@ -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 

@@ -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-

@@ -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"+  ]

@@ -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 #-}-

@@ -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 = ()+