in-other-words-plugin (empty) → 0.1.0.0
raw patch · 11 files changed
+826/−0 lines, 11 filesdep +basedep +containersdep +ghcsetup-changed
Dependencies added: base, containers, ghc, ghc-tcplugins-extra, hspec, in-other-words, in-other-words-plugin, syb, transformers
Files
- ChangeLog.md +4/−0
- LICENSE +30/−0
- README.md +72/−0
- Setup.hs +3/−0
- in-other-words-plugin.cabal +75/−0
- src/Control/Effect/Plugin.hs +71/−0
- src/Control/Effect/Plugin/Fundep.hs +233/−0
- src/Control/Effect/Plugin/Fundep/Unification.hs +144/−0
- src/Control/Effect/Plugin/Fundep/Utils.hs +32/−0
- test/Main.hs +1/−0
- test/PluginSpec.hs +161/−0
+ ChangeLog.md view
@@ -0,0 +1,4 @@+# Changelog for in-other-words-plugin++## 0.1.0.0 (2021-01-30)+Initial Release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Love Waern (c) 2021++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 Love Waern 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,72 @@+# in-other-words-plugin+[](https://github.com/KingoftheHomeless/in-other-words-plugin/actions?query=workflow%3A%22build+GHC+8.6%22)+[](https://github.com/KingoftheHomeless/in-other-words-plugin/actions?query=workflow%3A%22build+GHC+8.8%22)+[](https://github.com/KingoftheHomeless/in-other-words-plugin/actions?query=workflow%3A%22build+GHC+8.10%22)++## Overview++A typechecker plugin that can disambiguate "obvious" uses of effects when using+[`in-other-words`](https://hackage.haskell.org/package/in-other-words).+++## Example++Consider the following program:++```haskell+foo :: Eff (State Int) m => m ()+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, `in-other-words` 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 some `Eff`/`s` constraints for it."++This is obviously insane, but it's the way the cookie crumbles.+`in-other-words-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=Control.Effect.Plugin+```+++## Limitations++`in-other-words-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 :: Effs '[ State Int+ , State Double+ ] m+ => m ()+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 :: Effs '[ State Int+ , State Double+ ] m+ => m ()+bar = put @Int 10+```++## Acknowledgments++This plugin and this README is copied almost verbatim from+[`polysemy-plugin`](https://hackage.haskell.org/package/polysemy-plugin),+which itself is copied almost verbatim from [`simple-effects`](https://hackage.haskell.org/package/simple-effects).+
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ in-other-words-plugin.cabal view
@@ -0,0 +1,75 @@+cabal-version: 2.0 ++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: cac3988c3f4d02cb5c79aabd127b20ebe5c611c73ceae0fc62ab890773cda9f9++name: in-other-words-plugin+version: 0.1.0.0+synopsis: Disambiguate obvious uses of effects when using in-other-words.+description: Please see the README on GitHub at <https://github.com/KingoftheHomeless/in-other-words-plugin#readme>+category: Control Language+homepage: https://github.com/KingoftheHomeless/in-other-words-plugin#readme+bug-reports: https://github.com/KingoftheHomeless/in-other-words-plugin/issues+author: Love Waern+maintainer: combiner8761@gmail.com+copyright: 2021 Love Waern+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/KingoftheHomeless/in-other-words-plugin++library+ exposed-modules:+ Control.Effect.Plugin+ Control.Effect.Plugin.Fundep+ Control.Effect.Plugin.Fundep.Unification+ Control.Effect.Plugin.Fundep.Utils+ other-modules:+ Paths_in_other_words_plugin+ autogen-modules:+ Paths_in_other_words_plugin+ hs-source-dirs:+ src+ default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators OverloadedStrings TypeFamilies+ build-depends:+ base >=4.9 && <5+ , containers >=0.5 && <0.7+ , ghc >=8.4.4 && <9+ , ghc-tcplugins-extra >=0.3 && <0.5+ , in-other-words >=0.1 && <0.3+ , syb >=0.7 && <0.8+ , transformers >=0.5.2.0 && <0.6+ default-language: Haskell2010++test-suite in-other-words-plugin-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ PluginSpec+ Paths_in_other_words_plugin+ hs-source-dirs:+ test+ default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators OverloadedStrings TypeFamilies+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -fplugin=Control.Effect.Plugin+ build-tool-depends:+ hspec-discover:hspec-discover+ build-depends:+ base >=4.9 && <5+ , containers >=0.5 && <0.7+ , ghc >=8.4.4 && <9+ , ghc-tcplugins-extra >=0.3 && <0.5+ , hspec >=2.6.0 && <3+ , in-other-words >=0.1 && <0.3+ , in-other-words-plugin+ , syb >=0.7 && <0.8+ , transformers >=0.5.2.0 && <0.6+ default-language: Haskell2010
+ src/Control/Effect/Plugin.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++------------------------------------------------------------------------------+-- | A typechecker plugin that can disambiguate "obvious" uses of effects in+-- @in-other-words@.+--+-- __Example:__+--+-- Consider the following program:+--+-- @+-- foo :: 'Control.Effect.Eff' ('Control.Effect.State.State' Int) m => m ()+-- foo = 'Control.Effect.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, @in-other-words@ can't work this out on its own. Its reasoning is+-- "maybe you wanted to change some other 'Control.Effect.State.State' effect which+-- is /also/ a 'Num', but you just forgot to add a 'Eff' constraint+-- for it."+--+-- This is obviously insane, but it's the way the cookie crumbles.+-- 'Control.Effect.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=Control.Effect.Plugin+-- @+--+-- __Limitations:__+--+-- The 'Control.Effect.Plugin' will only disambiguate effects if there is exactly one+-- relevant constraint in scope. For example, it will /not/ disambiguate the+-- following program:+--+-- @+-- bar :: 'Control.Effect.Effs' \'[ 'Control.Effect.State.State' Int, 'Control.Effect.State.State' Double ] m => m ()+-- bar = 'Control.Effect.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 :: 'Control.Effect.Effs' \'[ 'Control.Effect.State.State' Int, 'Control.Effect.State.State' Double ] m => m ()+-- bar = 'Control.Effect.State.put' @Int 10+-- @+--+module Control.Effect.Plugin+ ( plugin+ ) where++import Control.Effect.Plugin.Fundep++import GhcPlugins++------------------------------------------------------------------------------+plugin :: Plugin+plugin = defaultPlugin+ { tcPlugin = const $ Just fundepPlugin+#if __GLASGOW_HASKELL__ >= 806+ , pluginRecompile = purePlugin+#endif+ }
+ src/Control/Effect/Plugin/Fundep.hs view
@@ -0,0 +1,233 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}++------------------------------------------------------------------------------+-- The MIT License (MIT)+--+-- Copyright (c) 2017 Luka Horvat, 2019 Sandy Maguire, 2021 Love Waern+--+-- 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 an adaptation of 'Polysemy.Plugin' from the 'polysemy-plugin' package,+-- by Sandy Maguire.+-- That module was, in turn, originally based on 'Control.Effects.Plugin' from the+-- 'simple-effects' package, by Luka Horvat.+--+-- https://gitlab.com/LukaHorvat/simple-effects/commit/966ce80b8b5777a4bd8f87ffd443f5fa80cc8845#f51c1641c95dfaa4827f641013f8017e8cd02aab++module Control.Effect.Plugin.Fundep (fundepPlugin) where++import Control.Monad+import Data.Bifunctor+import Data.IORef+import qualified Data.Map as M+import Data.Maybe+import qualified Data.Set as S+import Control.Effect.Plugin.Fundep.Unification+import Control.Effect.Plugin.Fundep.Utils+import TcEvidence+import TcPluginM (tcPluginIO, tcLookupClass)+import TcRnTypes+#if __GLASGOW_HASKELL__ >= 810+import Constraint+#endif+import TcSMonad hiding (tcLookupClass)+import Type++import GHC (Class, mkModuleName)+import GHC.TcPluginM.Extra (lookupName)+import OccName (mkTcOcc)+import Packages (lookupModuleWithSuggestions, LookupResult (..))+import Outputable (pprPanic, text, (<+>), ($$))++getMemberClass :: TcPluginM Class+getMemberClass = do+ dflags <- unsafeTcPluginTcM getDynFlags++ let error_msg = pprPanic "in-other-words-plugin"+ $ text ""+ $$ text "--------------------------------------------------------------------------------"+ $$ text "`in-other-words-plugin` is loaded, but"+ <+> text "`in-other-words` isn't available as a package."+ $$ text "Probable fix: add `in-other-words` to your cabal `build-depends`"+ $$ text "--------------------------------------------------------------------------------"+ $$ text ""+ let lookupRes = lookupModuleWithSuggestions+ dflags+ (mkModuleName "Control.Effect.Internal.Membership")+ (Just "in-other-words")+ case lookupRes of+ LookupFound md _ -> do+ nm <- lookupName md (mkTcOcc "Member")+ tcLookupClass nm+ _ -> error_msg++fundepPlugin :: TcPlugin+fundepPlugin = TcPlugin+ { tcPluginInit =+ (,) <$> tcPluginIO (newIORef S.empty)+ <*> getMemberClass+ , tcPluginSolve = solveFundep+ , tcPluginStop = const $ pure ()+ }+++------------------------------------------------------------------------------+-- | Corresponds to a 'Control.Effect.Internal.Membership.Member' constraint. For example,+-- given @Member (State s) r@, we would get:+data MemberConstraint = MemberConstraint+ { mcLoc :: CtLoc+ , mcEffectName :: Type -- ^ @State@+ , mcEffect :: Type -- ^ @State s@+ , mcRow :: Type -- ^ @r@+ }+++------------------------------------------------------------------------------+-- | Given a list of constraints, filter out the 'MemberConstraint's.+getMemberConstraints :: Class -> [Ct] -> [MemberConstraint]+getMemberConstraints cls cts = do+ cd@CDictCan{cc_class = cls', cc_tyargs = [_, eff, r]} <- cts+ guard $ cls == cls'+ pure $ MemberConstraint+ { mcLoc = ctLoc cd+ , mcEffectName = getEffName eff+ , mcEffect = eff+ , mcRow = r+ }+++------------------------------------------------------------------------------+-- | If there's only a single @Member@ in the same @r@ whose effect name+-- matches and could possibly unify, return its effect (including tyvars.)+findMatchingEffectIfSingular+ :: MemberConstraint+ -> [MemberConstraint]+ -> Maybe Type+findMatchingEffectIfSingular (MemberConstraint _ eff_name wanted r) ts =+ singleListToJust $ do+ MemberConstraint _ eff_name' eff' r' <- ts+ guard $ eqType eff_name eff_name'+ guard $ eqType r r'+ guard $ canUnifyRecursive FunctionDef wanted eff'+ pure eff'+++------------------------------------------------------------------------------+-- | Given an effect, compute its effect name.+getEffName :: Type -> Type+getEffName t = fst $ splitAppTys t+++------------------------------------------------------------------------------+-- | Generate a wanted unification for the effect described by the+-- 'MemberConstraint' and the given effect.+mkWantedForce+ :: MemberConstraint+ -> Type+ -> TcPluginM (Unification, Ct)+mkWantedForce mc given = do+ (ev, _) <- unsafeTcPluginTcM+ . runTcSDeriveds+ $ newWantedEq (mcLoc mc) Nominal wanted given+ pure ( Unification (OrdType wanted) (OrdType given)+ , CNonCanonical ev+ )+ where+ wanted = mcEffect mc++------------------------------------------------------------------------------+-- | Generate a wanted unification for the effect described by the+-- 'MemberConstraint' and the given effect --- if they can be unified in this+-- context.+mkWanted+ :: MemberConstraint+ -> SolveContext+ -> Type -- ^ The given effect.+ -> TcPluginM (Maybe (Unification, Ct))+mkWanted mc solve_ctx given =+ whenA (not (mustUnify solve_ctx) || canUnifyRecursive solve_ctx wanted given) $+ mkWantedForce mc given+ where+ wanted = mcEffect mc+++------------------------------------------------------------------------------+-- | Determine if there is exactly one wanted find for the @r@ in question.+exactlyOneWantedForR+ :: [MemberConstraint] -- ^ Wanted finds+ -> Type -- ^ Effect row+ -> Bool+exactlyOneWantedForR wanteds+ = fromMaybe False+ . flip M.lookup singular_r+ . OrdType+ where+ singular_r = M.fromList+ -- TODO(sandy)/(KingoftheHomeless):+ -- Nothing fails if this is just @second (const+ -- True)@. Why not? Incomplete test suite, or doing too much+ -- work?+ . fmap (second (/= 1))+ . countLength+ $ OrdType . mcRow <$> wanteds+++solveFundep+ :: ( IORef (S.Set Unification)+ , Class+ )+ -> [Ct]+ -> [Ct]+ -> [Ct]+ -> TcPluginM TcPluginResult+solveFundep _ _ _ [] = pure $ TcPluginOk [] []+solveFundep (ref, cls) given _ wanted = do+ let wanted_finds = getMemberConstraints cls wanted+ given_finds = getMemberConstraints cls given++ eqs <- forM wanted_finds $ \mc -> do+ let r = mcRow mc+ case findMatchingEffectIfSingular mc given_finds of+ -- We found a real given, therefore we are in the context of a function+ -- with an explicit @Member e r@ constraint. We also know it can+ -- be unified (although it may generate unsatisfiable constraints).+ Just eff' -> Just <$> mkWantedForce mc eff'++ -- Otherwise, check to see if @r ~ (e ': r')@. If so, pretend we're+ -- trying to solve a given @Member e r@. But this can only happen in the+ -- context of an interpreter!+ Nothing ->+ case splitAppTys r of+ (_, [_, eff', _]) ->+ mkWanted mc+ (InterpreterUse $ exactlyOneWantedForR wanted_finds r)+ eff'+ _ -> pure Nothing++ -- We only want to emit a unification wanted once, otherwise a type error can+ -- force the type checker to loop forever.+ already_emitted <- tcPluginIO $ readIORef ref+ let (unifications, new_wanteds) = unzipNewWanteds already_emitted $ catMaybes eqs+ tcPluginIO $ modifyIORef ref $ S.union $ S.fromList unifications++ pure $ TcPluginOk [] new_wanteds
+ src/Control/Effect/Plugin/Fundep/Unification.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE CPP #-}++module Control.Effect.Plugin.Fundep.Unification where++import Data.Bool+import Data.Function (on)+import qualified Data.Set as S+#if __GLASGOW_HASKELL__ >= 810+import Constraint+#else+import TcRnTypes+#endif++import Type+++------------------------------------------------------------------------------+-- | The context in which we're attempting to solve a constraint.+data SolveContext+ = -- | In the context of a function definition.+ FunctionDef+ -- | In the context of running an interpreter. The 'Bool' corresponds to+ -- whether we are only trying to solve a single 'Control.Effect.Member' constraint+ -- right now. If so, we *must* produce a unification wanted.+ | InterpreterUse Bool+ deriving (Eq, Ord, Show)+++------------------------------------------------------------------------------+-- | Depending on the context in which we're solving a constraint, we may or+-- may not want to force a unification of effects. For example, when defining+-- user code whose type is @Eff (State Int) m => ...@, if we see+-- @get :: Eff (State s) m => m s@,+-- we should unify @s ~ Int@.+mustUnify :: SolveContext -> Bool+mustUnify FunctionDef = True+mustUnify (InterpreterUse b) = b+++------------------------------------------------------------------------------+-- | Determine whether or not two effects are unifiable. This is nuanced.+--+-- There are several cases:+--+-- 1. [W] ∀ e1. e1 [G] ∀ e2. e2+-- Always fails, because we never want to unify two effects if effect names+-- are polymorphic.+--+-- 2. [W] State s [G] State Int+-- Always succeeds. It's safe to take our given as a fundep annotation.+--+-- 3. [W] State Int [G] State s+-- (when the [G] is a given that comes from a type signature)+--+-- This should fail, because it means we wrote the type signature @Eff+-- (State s) m => ...@, but are trying to use @s@ as an @Int@. Clearly+-- bogus!+--+-- 4. [W] State Int [G] State s+-- (when the [G] was generated by running an interpreter)+--+-- Sometimes OK, but only if the [G] is the only thing we're trying to solve+-- right now. Consider the case:+--+-- runState 5 $ get @Int+--+-- Here we have [G] forall a. Num a => State a and [W] State Int. Clearly+-- the typechecking should flow "backwards" here, out of the row and into+-- the type of 'runState'.+--+-- What happens if there are multiple [G]s in scope for the same @r@? Then+-- we'd emit multiple unification constraints for the same effect but with+-- different polymorphic variables, which would unify a bunch of effects+-- that shouldn't be!+canUnifyRecursive+ :: SolveContext+ -> Type -- ^ wanted+ -> Type -- ^ given+ -> Bool+canUnifyRecursive solve_ctx = go True+ where+ -- It's only OK to solve a polymorphic "given" if we're in the context of+ -- an interpreter, because it's not really a given!+ poly_given_ok :: Bool+ poly_given_ok =+ case solve_ctx of+ InterpreterUse _ -> True+ FunctionDef -> False++ -- On the first go around, we don't want to unify effects with tyvars, but+ -- we _do_ want to unify their arguments, thus 'is_first'.+ go :: Bool -> Type -> Type -> Bool+ go is_first wanted given =+ let (w, ws) = splitAppTys wanted+ (g, gs) = splitAppTys given+ in (&& bool (canUnify poly_given_ok) eqType is_first w g)+ . flip all (zip ws gs)+ $ \(wt, gt) -> canUnify poly_given_ok wt gt || go False wt gt+++------------------------------------------------------------------------------+-- | A non-recursive version of 'canUnifyRecursive'.+canUnify :: Bool -> Type -> Type -> Bool+canUnify poly_given_ok wt gt =+ or [ isTyVarTy wt+ , isTyVarTy gt && poly_given_ok+ , eqType wt gt+ ]+++------------------------------------------------------------------------------+-- | A wrapper for two types that we want to say have been unified.+data Unification = Unification+ { _unifyLHS :: OrdType+ , _unifyRHS :: OrdType+ }+ deriving (Eq, Ord)+++------------------------------------------------------------------------------+-- | '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+++------------------------------------------------------------------------------+-- | Filter out the unifications we've already emitted, and then give back the+-- things we should put into the @S.Set Unification@, and the new constraints+-- we should emit.+unzipNewWanteds+ :: S.Set Unification+ -> [(Unification, Ct)]+ -> ([Unification], [Ct])+unzipNewWanteds old = unzip . filter (not . flip S.member old . fst)+
+ src/Control/Effect/Plugin/Fundep/Utils.hs view
@@ -0,0 +1,32 @@+module Control.Effect.Plugin.Fundep.Utils where++import Control.Applicative+import Data.Bifunctor+import Data.List++++------------------------------------------------------------------------------+-- | Returns the head of the list iff there is exactly one element.+singleListToJust :: [a] -> Maybe a+singleListToJust [a] = Just a+singleListToJust _ = Nothing+++------------------------------------------------------------------------------+-- | Like 'Control.Monad.when', but in the context of an 'Alternative'.+whenA+ :: (Monad m, Alternative z)+ => Bool+ -> m a+ -> m (z a)+whenA False _ = pure empty+whenA True ma = pure <$> ma+++------------------------------------------------------------------------------+-- | Count the number of times 'a' is present in the list.+countLength :: Eq a => [a] -> [(a, Int)]+countLength as =+ let grouped = group as+ in zipWith (curry $ bimap head length) grouped grouped
+ test/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/PluginSpec.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module PluginSpec where + +import Data.Functor.Identity +import GHC.Exts +import Control.Effect +import Control.Effect.Reader +import Control.Effect.Error +import Control.Effect.State +import Control.Effect.Writer +import Control.Monad +import Test.Hspec + +data Count :: Effect where + Increment :: Count m () + +type CountC i = CompositionC + '[ ReinterpretSimpleC Count '[Throw (), State Int] + , ThrowC () + , StateC Int + ] + +runCount :: ( Carrier m + , Threaders '[ReaderThreads, ErrorThreads, StateThreads] m p + ) + => CountC i m a + -> m (Int, Maybe a) +runCount = + runState 0 + . fmap (either (const Nothing) Just) + . runThrow + . reinterpretSimple (\case + Increment -> do + i <- get + when (i >= 10) $ throw () + put $! i + 1 + ) + . runComposition + +idState :: Eff (State s) m => m () +idState = get >>= put + +intState :: Eff (State Int) m => m () +intState = put 10 + +numState :: Num a => Eff (State a) m => m () +numState = put 10 + +strState :: Eff (State String) m => m () +strState = put "hello" + +oStrState :: IsString a => Eff (State a) m => m () +oStrState = put "hello" + + +err :: Eff (Error e) m => m Bool +err = + catch + (throw undefined) + (\_ -> pure True) + + +errState :: Num s => Effs '[Error e, State s] m => m Bool +errState = do + numState + err + + +lifted :: Monad b => Eff (Embed b) m => m () +lifted = embed $ 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 "Tell effect" $ do + it "should unify recursively with tyvars" $ do + flipShouldBe 11 . sum . fst . run . runTell $ do + tell [1] + tell $ replicate 2 5 + + + describe "Embed 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