diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,4 @@ +# Changelog for in-other-words-plugin + +## 0.1.0.0 (2021-01-30) +Initial Release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,72 @@ +# in-other-words-plugin +[![build GHC 8.6](https://github.com/KingoftheHomeless/in-other-words-plugin/workflows/build%20GHC%208.6/badge.svg)](https://github.com/KingoftheHomeless/in-other-words-plugin/actions?query=workflow%3A%22build+GHC+8.6%22) +[![build GHC 8.8](https://github.com/KingoftheHomeless/in-other-words-plugin/workflows/build%20GHC%208.8/badge.svg)](https://github.com/KingoftheHomeless/in-other-words-plugin/actions?query=workflow%3A%22build+GHC+8.8%22) +[![build GHC 8.10](https://github.com/KingoftheHomeless/in-other-words-plugin/workflows/build%20GHC%208.10/badge.svg)](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). + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/in-other-words-plugin.cabal b/in-other-words-plugin.cabal new file mode 100644 --- /dev/null +++ b/in-other-words-plugin.cabal @@ -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 +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 diff --git a/src/Control/Effect/Plugin.hs b/src/Control/Effect/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Plugin.hs @@ -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 + } diff --git a/src/Control/Effect/Plugin/Fundep.hs b/src/Control/Effect/Plugin/Fundep.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Plugin/Fundep.hs @@ -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 diff --git a/src/Control/Effect/Plugin/Fundep/Unification.hs b/src/Control/Effect/Plugin/Fundep/Unification.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Plugin/Fundep/Unification.hs @@ -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) + diff --git a/src/Control/Effect/Plugin/Fundep/Utils.hs b/src/Control/Effect/Plugin/Fundep/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Plugin/Fundep/Utils.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/PluginSpec.hs b/test/PluginSpec.hs new file mode 100644 --- /dev/null +++ b/test/PluginSpec.hs @@ -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