polysemy-plugin (empty) → 0.1.0.0

raw patch · 7 files changed

+492/−0 lines, 7 filesdep +basedep +ghcdep +ghc-tcplugins-extrasetup-changed

Dependencies added: base, ghc, ghc-tcplugins-extra, hspec, polysemy, polysemy-plugin

Files

ChangeLog.md +8/−0
LICENSE +30/−0
README.md +77/−0
Setup.hs +2/−0
polysemy-plugin.cabal +59/−0
src/Polysemy/Plugin.hs +182/−0
test/Spec.hs +134/−0

+ ChangeLog.md view

@@ -0,0 +1,8 @@+# Changelog for polysemy-plugin++## 0.1.0.0 (2019-04-27)++- Initial release+++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Sandy Maguire (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Sandy Maguire nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,77 @@+# polysemy-plugin++[![Build Status](https://api.travis-ci.org/isovector/polysemy.svg?branch=master)](https://travis-ci.org/isovector/polysemy)+[![Hackage](https://img.shields.io/hackage/v/polysemy-plugin.svg?logo=haskell)](https://hackage.haskell.org/package/polysemy-plugin)++## Dedication++> It doesn't matter how beautiful your theory is, it doesn't matter how smart+> you are. If it doesn't agree with experiment, it's wrong.+>+> Richard Feynman+++## Overview++A typechecker plugin that can disambiguate "obvious" uses of effects in+[`polysemy`](https://hackage.haskell.org/package/polysemy).+++## Example++Consider the following program:++```haskell+foo :: Member (State Int) r => Sem r ()+foo = put 10+```++What does this program do? Any human will tell you that it changes the state of+the `Int` to 10, which is clearly what's meant.++Unfortunately, `polysemy` can't work this out on its own. Its reasoning is+"maybe you wanted to change some other `State` effect which is *also* a `Num`,+but you just forgot to add a `Member` constraint for it."++This is obviously insane, but it's the way the cookie crumbles.+`polysemy-plugin` is a typechecker plugin which will disambiguate the above+program (and others) so the compiler will do what you want.+++## Usage++Add the following line to your package configuration:++```+ghc-options: -fplugin=Polysemy.Plugin+```+++## Limitations++The `polysemy-plugin` will only disambiguate effects if there is exactly one+relevant constraint in scope. For example, it will *not* disambiguate the+following program:++```haskell+bar :: Members '[ State Int+                , State Double+                ] r => Sem r ()+bar = put 10+```++because it is now unclear whether you're attempting to set the `Int` or the+`Double`. Instead, you can manually write a type application in this case.++```haskell+bar :: Members '[ State Int+                , State Double+                ] r => Sem r ()+bar = put @Int 10+```+++## Acknowledgments++This plugin is copied almost verbatim from [`simple-effects`](https://hackage.haskell.org/package/simple-effects).+

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ polysemy-plugin.cabal view

@@ -0,0 +1,59 @@+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+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+    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++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

+ src/Polysemy/Plugin.hs view

@@ -0,0 +1,182 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE CPP #-}++------------------------------------------------------------------------------+-- The MIT License (MIT)+--+-- Copyright (c) 2017 Luka Horvat+--+-- Permission is hereby granted, free of charge, to any person obtaining a copy+-- of this software and associated documentation files (the "Software"), to+-- deal in the Software without restriction, including without limitation the+-- rights to use, copy, modify, merge, publish, distribute, sublicense, and/or+-- sell copies of the Software, and to permit persons to whom the Software is+-- furnished to do so, subject to the following conditions:+--+-- The above copyright notice and this permission notice shall be included in+-- all copies or substantial portions of the Software.+--+-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+-- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS+-- IN THE SOFTWARE.+--+------------------------------------------------------------------------------+--+-- This module is heavily based on 'Control.Effects.Plugin' from the+-- 'simple-effects' package, originally by Luka Horvat.+--+-- https://gitlab.com/LukaHorvat/simple-effects/commit/966ce80b8b5777a4bd8f87ffd443f5fa80cc8845#f51c1641c95dfaa4827f641013f8017e8cd02aab+++------------------------------------------------------------------------------+-- | A typechecker plugin that can disambiguate "obvious" uses of effects in+-- Polysemy.+--+-- __Example:__+--+-- Consider the following program:+--+-- @+-- foo :: 'Polysemy.Member' ('Polysemy.State.State' Int) r => 'Polysemy.Sem' r ()+-- foo = 'Polysemy.State.put' 10+-- @+--+-- What does this program do? Any human will tell you that it changes the state+-- of the 'Int' to 10, which is clearly what's meant.+--+-- Unfortunately, Polysemy can't work this out on its own. Its reasoning is+-- "maybe you wanted to change some other 'Polysemy.State.State' effect which+-- is /also/ a 'Num', but you just forgot to add a 'Polysemy.Member' constraint+-- for it."+--+-- This is obviously insane, but it's the way the cookie crumbles.+-- 'Polysemy.Plugin' is a typechecker plugin which will disambiguate the above+-- program (and others) so the compiler will do what you want.+--+-- __Usage:__+--+-- Add the following line to your package configuration:+--+-- @+-- ghc-options: -fplugin=Polysemy.Plugin+-- @+--+-- __Limitations:__+--+-- The 'Polysemy.Plugin' will only disambiguate effects if there is exactly one+-- relevant constraint in scope. For example, it will /not/ disambiguate the+-- following program:+--+-- @+-- bar :: 'Polysemy.Members' \'[ 'Polysemy.State.State' Int+--                 , 'Polysemy.State.State' Double+--                 ] r => 'Polysemy.Sem' r ()+-- bar = 'Polysemy.State.put' 10+-- @+--+-- because it is now unclear whether you're attempting to set the 'Int' or the+-- 'Double'. Instead, you can manually write a type application in this case.+--+-- @+-- bar :: 'Polysemy.Members' \'[ 'Polysemy.State.State' Int+--                 , 'Polysemy.State.State' Double+--                 ] r => 'Polysemy.Sem' r ()+-- bar = 'Polysemy.State.put' @Int 10+-- @+--+module Polysemy.Plugin+  ( plugin+  ) where++-- external+import GHC.TcPluginM.Extra (lookupModule, lookupName)++-- GHC API+import FastString (fsLit)+import Module     (mkModuleName)+import OccName    (mkTcOcc)+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)+#if __GLASGOW_HASKELL__ >= 806+    , pluginRecompile = const (return NoForceRecompile)+#endif+    }++fundepPlugin :: TcPlugin+fundepPlugin = TcPlugin+    { tcPluginInit = do+        md <- lookupModule (mkModuleName "Polysemy.Internal.Union") (fsLit "polysemy")+        monadEffectTcNm <- lookupName md (mkTcOcc "Find")+        tcLookupClass monadEffectTcNm+    , tcPluginSolve = solveFundep+    , tcPluginStop = const (return ()) }++allMonadEffectConstraints :: Class -> [Ct] -> [(CtLoc, (Type, Type, Type))]+allMonadEffectConstraints cls cts =+    [ (ctLoc cd, (effName, eff, r))+        | cd@CDictCan{cc_class = cls', cc_tyargs = [_, r, eff]} <- cts+        , cls == cls'+        , let effName = getEffName eff+              ]++singleListToJust :: [a] -> Maybe a+singleListToJust [a] = Just a+singleListToJust _ = Nothing++findMatchingEffectIfSingular :: (Type, Type, Type) -> [(Type, Type, Type)] -> Maybe Type+findMatchingEffectIfSingular (effName, _, mon) ts = singleListToJust+    [ eff'+        | (effName', eff', mon') <- ts+        , eqType effName effName'+        , eqType mon mon' ]++getEffName :: Type -> Type+getEffName t = fst $ splitAppTys t+++mkWanted :: CtLoc -> Type -> Type -> TcPluginM (Maybe Ct)+mkWanted loc eff eff' = do+  if eqType (getEffName eff) (getEffName eff')+     then do+       (ev, _) <- unsafeTcPluginTcM $ runTcSDeriveds $ newWantedEq loc Nominal eff eff'+       pure $ Just (CNonCanonical ev)+     else+       pure Nothing+++solveFundep :: Class -> [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginResult+solveFundep effCls giv _ want = do+    let wantedEffs = allMonadEffectConstraints effCls want+    let givenEffs = snd <$> allMonadEffectConstraints effCls giv+    eqs <- forM wantedEffs $ \(loc, e@(_, eff, r)) ->+      case findMatchingEffectIfSingular e givenEffs of+        Nothing -> do+          case splitAppTys r of+            (_, [_, eff', _]) -> mkWanted loc eff eff'+            _                 -> pure Nothing+        Just eff' -> mkWanted loc eff eff'++    return (TcPluginOk [] (catMaybes eqs))+

+ test/Spec.hs view

@@ -0,0 +1,134 @@+{-# 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+