polysemy-plugin 0.1.0.0 → 0.1.0.1
raw patch · 6 files changed
+280/−208 lines, 6 filesdep +should-not-typecheckdep ~hspecdep ~polysemyPVP ok
version bump matches the API change (PVP)
Dependencies added: should-not-typecheck
Dependency ranges changed: hspec, polysemy
API changes (from Hackage documentation)
Files
- polysemy-plugin.cabal +54/−49
- src/Polysemy/Plugin.hs +61/−25
- test/BadSpec.hs +32/−0
- test/Main.hs +1/−0
- test/PluginSpec.hs +132/−0
- test/Spec.hs +0/−134
polysemy-plugin.cabal view
@@ -1,59 +1,64 @@ cabal-version: 1.12-name: polysemy-plugin-version: 0.1.0.0-license: BSD3-license-file: LICENSE-copyright: 2019 Sandy Maguire-maintainer: sandy@sandymaguire.me-author: Sandy Maguire-homepage: https://github.com/isovector/polysemy#readme-bug-reports: https://github.com/isovector/polysemy/issues-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-build-type: Simple++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: b2f1b5ca3df4cb55d14d21f847975a2eb82809c4b569f214f7ff29a88bd9d65d++name: polysemy-plugin+version: 0.1.0.1+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+homepage: https://github.com/isovector/polysemy#readme+bug-reports: https://github.com/isovector/polysemy/issues+author: Sandy Maguire+maintainer: sandy@sandymaguire.me+copyright: 2019 Sandy Maguire+license: BSD3+license-file: LICENSE+build-type: Simple extra-source-files: README.md ChangeLog.md source-repository head- type: git- location: https://github.com/isovector/polysemy+ type: git+ location: https://github.com/isovector/polysemy library- exposed-modules:- Polysemy.Plugin- hs-source-dirs: src- other-modules:- Paths_polysemy_plugin- default-language: Haskell2010- default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs- LambdaCase PolyKinds RankNTypes ScopedTypeVariables- StandaloneDeriving TypeApplications TypeOperators TypeFamilies- UnicodeSyntax- build-depends:- base >=4.7 && <5,- ghc >=8.6.3 && <8.7,- ghc-tcplugins-extra ==0.3.*,- polysemy >=0.1.2.0 && <0.2+ exposed-modules:+ Polysemy.Plugin+ other-modules:+ Paths_polysemy_plugin+ hs-source-dirs:+ src+ default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UnicodeSyntax+ build-depends:+ base >=4.7 && <5+ , ghc >=8.6.3 && <8.7+ , ghc-tcplugins-extra >=0.3 && <0.4+ , polysemy >=0.1+ default-language: Haskell2010 test-suite polysemy-plugin-test- type: exitcode-stdio-1.0- main-is: Spec.hs- hs-source-dirs: test- other-modules:- Paths_polysemy_plugin- default-language: Haskell2010- default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs- LambdaCase PolyKinds RankNTypes ScopedTypeVariables- StandaloneDeriving TypeApplications TypeOperators TypeFamilies- UnicodeSyntax- ghc-options: -threaded -rtsopts -with-rtsopts=-N- build-depends:- base >=4.7 && <5,- ghc >=8.6.3 && <8.7,- ghc-tcplugins-extra ==0.3.*,- hspec >=2.6.0 && <2.7,- polysemy >=0.1.2.0 && <0.2,- polysemy-plugin -any+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ BadSpec+ PluginSpec+ Paths_polysemy_plugin+ hs-source-dirs:+ test+ default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UnicodeSyntax+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -fplugin=Polysemy.Plugin+ build-depends:+ base >=4.7 && <5+ , ghc >=8.6.3 && <8.7+ , ghc-tcplugins-extra >=0.3 && <0.4+ , hspec >=2.6.0 && <3+ , polysemy >=0.1+ , polysemy-plugin+ , should-not-typecheck >=2.1.0 && <3+ default-language: Haskell2010
src/Polysemy/Plugin.hs view
@@ -1,5 +1,5 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ -- The MIT License (MIT)@@ -92,42 +92,64 @@ ( plugin ) where --- external-import GHC.TcPluginM.Extra (lookupModule, lookupName)---- GHC API+import Class+import CoAxiom+import Control.Monad+import CoreMonad+import Data.Maybe+import DynFlags import FastString (fsLit)-import Module (mkModuleName)+import GHC (ModuleName, moduleName)+import GHC.TcPluginM.Extra (lookupModule, lookupName)+import Module (mkModuleName, moduleSetElts) import OccName (mkTcOcc)+import Outputable+import TcPluginM (TcPluginM, tcLookupClass)+import TcRnTypes+import TcSMonad hiding (tcLookupClass)+import TyCoRep (Type (..))+import Type+ import Plugins (Plugin (..), defaultPlugin #if __GLASGOW_HASKELL__ >= 806 , PluginRecompile(..) #endif )-import TcPluginM (TcPluginM, tcLookupClass)-import TcRnTypes-import TyCoRep (Type (..))-import Control.Monad-import Class-import Type-import Data.Maybe-import TcSMonad hiding (tcLookupClass)-import CoAxiom-import Outputable plugin :: Plugin plugin = defaultPlugin- { tcPlugin = const (Just fundepPlugin)+ { tcPlugin = const $ Just fundepPlugin+#if __GLASGOW_HASKELL__ >= 810+ , installCoreToDos = const installTodos+#endif #if __GLASGOW_HASKELL__ >= 806- , pluginRecompile = const (return NoForceRecompile)+ , pluginRecompile = const $ pure NoForceRecompile #endif } +polysemyInternal :: ModuleName+polysemyInternal = mkModuleName "Polysemy.Internal"++polysemyInternalUnion :: ModuleName+polysemyInternalUnion = mkModuleName "Polysemy.Internal.Union"++installTodos :: [CoreToDo] -> CoreM [CoreToDo]+installTodos todos = do+ dynFlags <- getDynFlags+ case optLevel dynFlags of+ 2 -> do+ mods <- moduleSetElts <$> getVisibleOrphanMods+ case any ((== polysemyInternal) . moduleName) mods of+ -- TODO(sandy): install extra passes+ True -> pure todos+ False -> pure todos+ _ -> pure todos+ fundepPlugin :: TcPlugin fundepPlugin = TcPlugin { tcPluginInit = do- md <- lookupModule (mkModuleName "Polysemy.Internal.Union") (fsLit "polysemy")+ md <- lookupModule polysemyInternalUnion (fsLit "polysemy") monadEffectTcNm <- lookupName md (mkTcOcc "Find") tcLookupClass monadEffectTcNm , tcPluginSolve = solveFundep@@ -156,11 +178,25 @@ getEffName t = fst $ splitAppTys t -mkWanted :: CtLoc -> Type -> Type -> TcPluginM (Maybe Ct)-mkWanted loc eff eff' = do- if eqType (getEffName eff) (getEffName eff')+-- isTyVar :: Type -> Bool+-- isTyVar = isJust . getTyVar_maybe+++canUnify :: Type -> Type -> Bool+canUnify wanted given =+ let (w, ws) = splitAppTys wanted+ (g, gs) = splitAppTys given+ in (&& eqType w g) . flip all (zip ws gs) $ \(wt, gt) ->+ if isTyVarTy gt+ then isTyVarTy wt+ else True+++mkWanted :: Bool -> CtLoc -> Type -> Type -> TcPluginM (Maybe Ct)+mkWanted mustUnify loc wanted given = do+ if (not mustUnify || canUnify wanted given) then do- (ev, _) <- unsafeTcPluginTcM $ runTcSDeriveds $ newWantedEq loc Nominal eff eff'+ (ev, _) <- unsafeTcPluginTcM $ runTcSDeriveds $ newWantedEq loc Nominal wanted given pure $ Just (CNonCanonical ev) else pure Nothing@@ -174,9 +210,9 @@ case findMatchingEffectIfSingular e givenEffs of Nothing -> do case splitAppTys r of- (_, [_, eff', _]) -> mkWanted loc eff eff'+ (_, [_, eff', _]) -> mkWanted False loc eff eff' _ -> pure Nothing- Just eff' -> mkWanted loc eff eff'+ Just eff' -> mkWanted True loc eff eff' return (TcPluginOk [] (catMaybes eqs))
+ test/BadSpec.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE TemplateHaskell #-}++{-# OPTIONS_GHC -fdefer-type-errors -fno-warn-deferred-type-errors #-}++module BadSpec where++import Polysemy+import Test.Hspec+import Test.ShouldNotTypecheck++data KVStore k v m a where+ GetKV :: k -> KVStore k v m (Maybe v)++makeSem ''KVStore++positivePos :: Member (KVStore k v) r => Sem r (Maybe v)+positivePos = do+ getKV "hello"++negativePos :: Member (KVStore String v) r => Sem r (Maybe Bool)+negativePos = do+ getKV "hello"+++spec :: Spec+spec = do+ describe "incorrectly polymorphic constraint" $ do+ it "should not typecheck in positive position" $ do+ shouldNotTypecheck positivePos+ it "should not typecheck in negative position" $ do+ shouldNotTypecheck negativePos+
+ test/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/PluginSpec.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}++module PluginSpec where++import Data.Functor.Identity+import GHC.Exts+import Polysemy+import Polysemy.Error+import Polysemy.State+import Test.Hspec++++idState :: Member (State s) r => Sem r ()+idState = do+ s <- get+ put s++intState :: Member (State Int) r => Sem r ()+intState = put 10++numState :: Num a => Member (State a) r => Sem r ()+numState = put 10++strState :: Member (State String) r => Sem r ()+strState = put "hello"++oStrState :: IsString a => Member (State a) r => Sem r ()+oStrState = put "hello"+++err :: Member (Error e) r => Sem r Bool+err =+ catch+ do+ throw undefined+ \_ -> pure True+++errState :: Num s => Members '[Error e, State s] r => Sem r Bool+errState = do+ numState+ err+++lifted :: Monad m => Member (Lift m) r => Sem r ()+lifted = sendM $ pure ()+++newtype MyString = MyString String+ deriving (IsString, Eq, Show)+++spec :: Spec+spec = do+ describe "State effect" $ do+ describe "get/put" $ do+ it "should work in simple cases" $ do+ flipShouldBe (True, ()) . run $ runState True idState++ it "should, when polymorphic, eliminate the first matching effect" $ do+ flipShouldBe (False, (True, ())) . run $ runState False $ runState True idState++ it "should, when polymorphic, not eliminate unmatching effects" $ do+ flipShouldBe (True, Right @Int ()) . run $ runState True $ runError idState++ describe "numbers" $ do+ it "should interpret against concrete Int" $ do+ flipShouldBe (10, ()) . run $ runState 0 intState++ describe "polymorphic Num constraint" $ do+ it "should interpret against Int" $ do+ flipShouldBe (10 :: Int, ()) . run $ runState 0 numState++ it "should interpret against Float" $ do+ flipShouldBe (10 :: Float, ()) . run $ runState 0 numState++ it "should interpret against Double" $ do+ flipShouldBe (10 :: Double, ()) . run $ runState 0 numState++ it "should interpret against Integer" $ do+ flipShouldBe (10 :: Integer, ()) . run $ runState 0 numState++ describe "strings" $ do+ it "concrete interpret against concrete String" $ do+ flipShouldBe ("hello", ()) . run $ runState "nothing" strState++ describe "polymorphic IsString constraint" $ do+ it "should interpret against String" $ do+ flipShouldBe ("hello" :: String, ()) . run $ runState "nothing" oStrState++ it "should interpret against MyString" $ do+ flipShouldBe ("hello" :: MyString, ()) . run $ runState "nothing" oStrState+++ describe "Error effect" $ do+ it "should interpret against Int" $ do+ flipShouldBe (Right @Int True) . run $ runError err+ it "should interpret against Bool" $ do+ flipShouldBe (Right @Bool True) . run $ runError err+++ describe "State/Error effect" $ do+ it "should interpret against Int/String" $ do+ flipShouldBe (10 :: Int, Right @String True) . run $ runState 0 $ runError errState+ it "should interpret against Float/Bool" $ do+ flipShouldBe (10 :: Float, Right @Bool True) . run $ runState 0 $ runError errState+++ describe "Error/State effect" $ do+ it "should interpret against String/Int" $ do+ flipShouldBe (Right @String (10 :: Int, True)) . run $ runError $ runState 0 errState+ it "should interpret against Bool/Float" $ do+ flipShouldBe (Right @Bool (10 :: Float, True)) . run $ runError $ runState 0 errState+++ describe "Lift effect" $ do+ it "should interpret against IO" $ do+ res <- runM lifted+ res `shouldBe` ()++ it "should interpret against Identity" $ do+ let res = runM lifted+ res `shouldBe` Identity ()+++flipShouldBe :: (Show a, Eq a) => a -> a -> Expectation+flipShouldBe = flip shouldBe+
− test/Spec.hs
@@ -1,134 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}--{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}--module Main where--import Data.Functor.Identity-import GHC.Exts-import Polysemy-import Polysemy.Error-import Polysemy.State-import Test.Hspec----idState :: Member (State s) r => Sem r ()-idState = do- s <- get- put s--intState :: Member (State Int) r => Sem r ()-intState = put 10--numState :: Num a => Member (State a) r => Sem r ()-numState = put 10--strState :: Member (State String) r => Sem r ()-strState = put "hello"--oStrState :: IsString a => Member (State a) r => Sem r ()-oStrState = put "hello"---err :: Member (Error e) r => Sem r Bool-err =- catch- do- throw undefined- \_ -> pure True---errState :: Num s => Members '[Error e, State s] r => Sem r Bool-errState = do- numState- err---lifted :: Monad m => Member (Lift m) r => Sem r ()-lifted = sendM $ pure ()---newtype MyString = MyString String- deriving (IsString, Eq, Show)---main :: IO ()-main = hspec $ do- describe "State effect" $ do- describe "get/put" $ do- it "should work in simple cases" $ do- flipShouldBe (True, ()) . run $ runState True idState-- it "should, when polymorphic, eliminate the first matching effect" $ do- flipShouldBe (False, (True, ())) . run $ runState False $ runState True idState-- it "should, when polymorphic, not eliminate unmatching effects" $ do- flipShouldBe (True, Right @Int ()) . run $ runState True $ runError idState-- describe "numbers" $ do- it "should interpret against concrete Int" $ do- flipShouldBe (10, ()) . run $ runState 0 intState-- describe "polymorphic Num constraint" $ do- it "should interpret against Int" $ do- flipShouldBe (10 :: Int, ()) . run $ runState 0 numState-- it "should interpret against Float" $ do- flipShouldBe (10 :: Float, ()) . run $ runState 0 numState-- it "should interpret against Double" $ do- flipShouldBe (10 :: Double, ()) . run $ runState 0 numState-- it "should interpret against Integer" $ do- flipShouldBe (10 :: Integer, ()) . run $ runState 0 numState-- describe "strings" $ do- it "concrete interpret against concrete String" $ do- flipShouldBe ("hello", ()) . run $ runState "nothing" strState-- describe "polymorphic IsString constraint" $ do- it "should interpret against String" $ do- flipShouldBe ("hello" :: String, ()) . run $ runState "nothing" oStrState-- it "should interpret against MyString" $ do- flipShouldBe ("hello" :: MyString, ()) . run $ runState "nothing" oStrState--- describe "Error effect" $ do- it "should interpret against Int" $ do- flipShouldBe (Right @Int True) . run $ runError err- it "should interpret against Bool" $ do- flipShouldBe (Right @Bool True) . run $ runError err--- describe "State/Error effect" $ do- it "should interpret against Int/String" $ do- flipShouldBe (10 :: Int, Right @String True) . run $ runState 0 $ runError errState- it "should interpret against Float/Bool" $ do- flipShouldBe (10 :: Float, Right @Bool True) . run $ runState 0 $ runError errState--- describe "Error/State effect" $ do- it "should interpret against String/Int" $ do- flipShouldBe (Right @String (10 :: Int, True)) . run $ runError $ runState 0 errState- it "should interpret against Bool/Float" $ do- flipShouldBe (Right @Bool (10 :: Float, True)) . run $ runError $ runState 0 errState--- describe "Lift effect" $ do- it "should interpret against IO" $ do- res <- runM lifted- res `shouldBe` ()-- it "should interpret against Identity" $ do- let res = runM lifted- res `shouldBe` Identity ()---flipShouldBe :: (Show a, Eq a) => a -> a -> Expectation-flipShouldBe = flip shouldBe-