├── .gitignore ├── test ├── Main.hs ├── InterposeSpec.hs ├── HigherOrderSpec.hs ├── ErrorSpec.hs ├── ConcurrencySpec.hs ├── StateSpec.hs ├── ThSpec.hs └── MaskSpec.hs ├── .hlint.yaml ├── docs ├── img │ ├── benchmark-countdown.png │ └── benchmark-filesize.png └── plugin-spec.md ├── cleff-plugin ├── CHANGELOG.md ├── test │ ├── Main.hs │ └── CleffSpec.hs ├── src │ └── Cleff │ │ ├── Plugin.hs │ │ └── Plugin │ │ └── Internal.hs ├── LICENSE ├── README.md ├── package.yaml └── cleff-plugin.cabal ├── .github ├── stack-8.6.5.yaml ├── stack-8.8.4.yaml ├── stack-9.0.2.yaml ├── stack-8.10.7.yaml ├── stack-9.2.2.yaml └── workflows │ └── build.yaml ├── stack.yaml ├── example ├── Main.hs ├── Broker.hs ├── Filesystem.hs └── Teletype.hs ├── hie.yaml ├── stack.yaml.lock ├── src ├── Data │ ├── Any.hs │ ├── PrimVec.hs │ ├── ThreadVar.hs │ └── RadixVec.hs ├── Cleff │ ├── Fail.hs │ ├── Trace.hs │ ├── Reader.hs │ ├── Fresh.hs │ ├── Output.hs │ ├── Input.hs │ ├── Writer.hs │ ├── State.hs │ ├── Internal │ │ ├── Env.hs │ │ ├── Stack.hs │ │ ├── Monad.hs │ │ ├── TH.hs │ │ ├── Base.hs │ │ └── Interpret.hs │ ├── Mask.hs │ └── Error.hs └── Cleff.hs ├── .stylish-haskell.yaml ├── LICENSE ├── CHANGELOG.md ├── package.yaml ├── cleff.cabal └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | dist/ 3 | dist-newstyle/ 4 | *~ 5 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - ignore: "Redundant lambda" 2 | - ignore: "Eta reduce" 3 | -------------------------------------------------------------------------------- /docs/img/benchmark-countdown.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/re-xyr/cleff/HEAD/docs/img/benchmark-countdown.png -------------------------------------------------------------------------------- /docs/img/benchmark-filesize.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/re-xyr/cleff/HEAD/docs/img/benchmark-filesize.png -------------------------------------------------------------------------------- /cleff-plugin/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog for `cleff-plugin` 2 | 3 | ## Unreleased 4 | 5 | ## 0.1.0.0 (2022-03-13) 6 | 7 | - Initial release 8 | -------------------------------------------------------------------------------- /.github/stack-8.6.5.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.27 2 | 3 | packages: 4 | - . 5 | - ./cleff-plugin 6 | 7 | ghc-options: 8 | "$everything": -haddock 9 | -------------------------------------------------------------------------------- /.github/stack-8.8.4.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.31 2 | 3 | packages: 4 | - . 5 | - ./cleff-plugin 6 | 7 | ghc-options: 8 | "$everything": -haddock 9 | -------------------------------------------------------------------------------- /.github/stack-9.0.2.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-19.0 2 | 3 | packages: 4 | - . 5 | - ./cleff-plugin 6 | 7 | ghc-options: 8 | "$everything": -haddock 9 | -------------------------------------------------------------------------------- /.github/stack-8.10.7.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.28 2 | 3 | packages: 4 | - . 5 | - ./cleff-plugin 6 | 7 | ghc-options: 8 | "$everything": -haddock 9 | -------------------------------------------------------------------------------- /.github/stack-9.2.2.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2022-03-20 2 | 3 | packages: 4 | - . 5 | - ./cleff-plugin 6 | 7 | ghc-options: 8 | "$everything": -haddock 9 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.28 2 | 3 | packages: 4 | - . 5 | - ./cleff-plugin 6 | 7 | ghc-options: 8 | "$targets": -dynamic 9 | "$everything": -haddock 10 | -------------------------------------------------------------------------------- /example/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Broker (runProg) 4 | 5 | main :: IO () 6 | main = do 7 | putStrLn "This is cleff's example module! Browse /example to get started with the library." 8 | runProg 9 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | stack: 3 | - path: "./src" 4 | component: "cleff:lib" 5 | - path: "./test" 6 | component: "cleff:test:cleff-test" 7 | - path: "./example" 8 | component: "cleff:test:cleff-example" 9 | - path: "./cleff-plugin/src" 10 | component: "cleff-plugin:lib" 11 | - path: "./cleff-plugin/test" 12 | component: "cleff-plugin:test:cleff-plugin-test" 13 | -------------------------------------------------------------------------------- /cleff-plugin/test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# OPTIONS_GHC -Wno-unused-imports #-} 5 | module Main where 6 | 7 | #ifdef CLEFF_PLUGIN_cleff 8 | import qualified CleffSpec 9 | #endif 10 | #ifdef CLEFF_PLUGIN_effectful 11 | import qualified EffectfulSpec 12 | #endif 13 | 14 | main :: IO () 15 | main = putStrLn "It compiles!" 16 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 590100 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/28.yaml 11 | sha256: 428ec8d5ce932190d3cbe266b9eb3c175cd81e984babf876b64019e2cbe4ea68 12 | original: lts-18.28 13 | -------------------------------------------------------------------------------- /src/Data/Any.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright: (c) 2021 Xy Ren 3 | -- License: BSD3 4 | -- Maintainer: xy.r@outlook.com 5 | -- Stability: unstable 6 | -- Portability: non-portable (GHC only) 7 | module Data.Any (Any, pattern Any, fromAny) where 8 | 9 | import GHC.Exts (Any) 10 | import Unsafe.Coerce (unsafeCoerce) 11 | 12 | -- | A pattern synonym for coercing values to and from t'Any'. This is not any less unsafe but prevents possible 13 | -- misuses. 14 | pattern Any :: forall a. a -> Any 15 | pattern Any {fromAny} <- (unsafeCoerce -> fromAny) 16 | where Any = unsafeCoerce 17 | {-# COMPLETE Any #-} 18 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - module_header: 3 | indent: 2 4 | sort: false 5 | separate_lists: true 6 | break_where: inline 7 | open_bracket: next_line 8 | 9 | - simple_align: 10 | cases: always 11 | top_level_patterns: always 12 | records: always 13 | multi_way_if: always 14 | 15 | - imports: 16 | align: global 17 | list_align: after_alias 18 | pad_module_names: true 19 | long_list_align: inline 20 | empty_list_align: inherit 21 | list_padding: 2 22 | separate_lists: true 23 | space_surround: false 24 | post_qualify: false 25 | 26 | - language_pragmas: 27 | style: vertical 28 | align: true 29 | remove_redundant: true 30 | language_prefix: LANGUAGE 31 | 32 | - tabs: 33 | spaces: 2 34 | 35 | - trailing_whitespace: {} 36 | 37 | columns: 120 38 | newline: native 39 | cabal: true 40 | -------------------------------------------------------------------------------- /cleff-plugin/src/Cleff/Plugin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | Copyright: (c) 2022 Xy Ren 3 | -- License: BSD3 4 | -- Maintainer: xy.r@outlook.com 5 | -- Stability: experimental 6 | -- Portability: non-portable (GHC only) 7 | module Cleff.Plugin (plugin) where 8 | 9 | import Cleff.Plugin.Internal (Plugin, makePlugin) 10 | 11 | -- | The GHC typechecker plugin that disambiguates trivial uses of @cleff@ effects. Refer to the README for more info. 12 | plugin :: Plugin 13 | #if MIN_VERSION_cleff(0, 3, 4) 14 | plugin = makePlugin [("cleff", "Cleff.Internal.Stack", ":>")] 15 | #elif MIN_VERSION_cleff(0, 3, 2) 16 | plugin = makePlugin [("cleff", "Cleff.Internal.Rec", ":>")] 17 | #elif MIN_VERSION_cleff(0, 3, 1) 18 | plugin = makePlugin [("cleff", "Cleff.Internal.Rec", "Elem")] 19 | #elif MIN_VERSION_cleff(0, 2, 0) 20 | plugin = makePlugin [("rec-smallarray", "Data.Rec.SmallArray", "Elem")] 21 | #else 22 | plugin = makePlugin [("cleff", "Data.Rec", "Elem")] 23 | #endif 24 | -------------------------------------------------------------------------------- /test/InterposeSpec.hs: -------------------------------------------------------------------------------- 1 | module InterposeSpec where 2 | 3 | import Cleff 4 | import Cleff.Output 5 | import Cleff.Reader 6 | import Cleff.State 7 | import Cleff.Trace 8 | import Test.Hspec 9 | 10 | annoy :: ∀ es. '[Reader Int, Trace] :>> es => Eff es ~> Eff es 11 | annoy = interpose @(Reader Int) h 12 | where 13 | h :: Handler (Reader Int) es 14 | h = \case 15 | Ask -> do 16 | x <- ask 17 | trace $ show x 18 | pure x 19 | Local f m -> local f (toEff m) 20 | 21 | countdown :: Reader Int :> es => Eff es () 22 | countdown = do 23 | x <- asks (== (0 :: Int)) 24 | if x then pure () else local (subtract (1 :: Int)) countdown 25 | 26 | spec :: Spec 27 | spec = do 28 | it "should thread in effect environment correctly" do 29 | let (_, msgs) = runPure $ runState [] $ outputToListState $ traceToOutput $ runReader (100 :: Int) $ annoy countdown 30 | msgs `shouldBe` map show [0..100 :: Int] 31 | -------------------------------------------------------------------------------- /.github/workflows/build.yaml: -------------------------------------------------------------------------------- 1 | name: build 2 | 3 | on: 4 | workflow_dispatch: 5 | push: 6 | branches: 7 | - master 8 | pull_request: 9 | branches: 10 | - master 11 | 12 | jobs: 13 | build: 14 | strategy: 15 | matrix: 16 | ghc: 17 | - 8.6.5 18 | - 8.8.4 19 | - 8.10.7 20 | - 9.0.2 21 | - 9.2.2 22 | runs-on: ubuntu-latest 23 | steps: 24 | - uses: actions/checkout@v2 25 | - name: Copy stack.yaml 26 | run: | 27 | rm stack.yaml 28 | rm stack.yaml.lock 29 | cp .github/stack-${{ matrix.ghc }}.yaml stack.yaml 30 | - uses: actions/cache@v2 31 | name: Cache ~/.stack/ 32 | with: 33 | path: ~/.stack 34 | key: ${{ matrix.ghc }}-stack-root 35 | - uses: actions/cache@v2 36 | name: Cache .stack-work/ 37 | with: 38 | path: .stack-work 39 | key: ${{ matrix.ghc }}-stack-work 40 | - name: Build 41 | run: stack build 42 | - name: Run tests 43 | run: stack test 44 | -------------------------------------------------------------------------------- /example/Broker.hs: -------------------------------------------------------------------------------- 1 | module Broker where 2 | 3 | import Cleff 4 | import Control.Concurrent (forkIO, threadDelay) 5 | import Control.Monad (void) 6 | 7 | nestedImpl :: Int -> (String -> (Bool -> IO ()) -> IO ()) -> IO () 8 | nestedImpl i cb = void . forkIO $ do 9 | threadDelay $ 1 * 1000 * 1000 10 | cb (show i) \b -> putStrLn $ "result " ++ show b 11 | 12 | data Broker :: Effect where 13 | Subscribe :: Int -> (String -> m Bool) -> Broker m () 14 | 15 | subscribe :: Broker :> es => Int -> (String -> Eff es Bool) -> Eff es () 16 | subscribe channel = send . Subscribe channel 17 | 18 | runBroker :: IOE :> es => Eff (Broker : es) a -> Eff es a 19 | runBroker = interpret \case 20 | Subscribe channel cb -> withToIO \toIO -> do 21 | putStrLn $ "Subscribe: " ++ show channel 22 | nestedImpl channel \s icb -> icb =<< toIO (cb s) 23 | 24 | prog :: (IOE :> es, Broker :> es) => Eff es () 25 | prog = do 26 | subscribe 1 \_ -> pure True 27 | subscribe 2 \_ -> pure False 28 | liftIO $ threadDelay $ 3 * 1000 * 1000 29 | 30 | runProg :: IO () 31 | runProg = runIOE $ runBroker prog 32 | -------------------------------------------------------------------------------- /src/Cleff/Fail.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | -- | 4 | -- Copyright: (c) 2021 Xy Ren 5 | -- License: BSD3 6 | -- Maintainer: xy.r@outlook.com 7 | -- Stability: experimental 8 | -- Portability: non-portable (GHC only) 9 | module Cleff.Fail 10 | ( -- * Effect 11 | Fail (..) 12 | -- * Interpretations 13 | , runFail 14 | , runFailIO 15 | ) where 16 | 17 | import Cleff 18 | import Cleff.Error 19 | import qualified Control.Monad.Fail as Fail 20 | 21 | -- * Effect 22 | 23 | -- | An effect that expresses failure with a message. This effect allows the use of the 'MonadFail' class. 24 | data Fail :: Effect where 25 | Fail :: String -> Fail m a 26 | 27 | instance Fail :> es => Fail.MonadFail (Eff es) where 28 | fail = send . Fail 29 | 30 | -- * Interpretations 31 | 32 | -- | Run a 'Fail' effect in terms of 'Error'. 33 | runFail :: Eff (Fail : es) a -> Eff es (Either String a) 34 | runFail = runError . reinterpret \case 35 | Fail msg -> throwError msg 36 | 37 | -- | Run a 'Fail' effect in terms of throwing exceptions in 'IO'. 38 | runFailIO :: IOE :> es => Eff (Fail : es) ~> Eff es 39 | runFailIO = interpret \case 40 | Fail msg -> liftIO $ Fail.fail msg 41 | -------------------------------------------------------------------------------- /test/HigherOrderSpec.hs: -------------------------------------------------------------------------------- 1 | -- | This module is adapted from https://github.com/polysemy-research/polysemy/blob/master/test/HigherOrderSpec.hs, 2 | -- originally BSD3 license, authors Sandy Maguire et al. 3 | module HigherOrderSpec where 4 | 5 | import Cleff 6 | import Cleff.Error 7 | import Cleff.Reader 8 | import Test.Hspec 9 | 10 | data SomeEff :: Effect where 11 | SomeAction :: SomeEff m String 12 | makeEffect ''SomeEff 13 | 14 | data Ex = Ex 15 | deriving stock (Eq, Show) 16 | 17 | spec :: Spec 18 | spec = describe "Reader local" $ do 19 | it "should nest with itself" $ do 20 | let foo = runPure . runReader "hello" $ do 21 | local (++ " world") $ do 22 | local (++ "!") $ do 23 | ask 24 | foo `shouldBe` "hello world!" 25 | 26 | it "should local for other interpreted effects" do 27 | let 28 | localed = runPure $ runReader "unlocaled" $ interpret (\SomeAction -> ask) do 29 | local (const "localed") someAction 30 | localed `shouldBe` "localed" 31 | 32 | it "should catch errors indirectly thrown from interpreted effects" do 33 | let 34 | caught = runPure $ runError @Ex $ interpret (\SomeAction -> throwError Ex) do 35 | someAction `catchError` \Ex -> return "caught" 36 | caught `shouldBe` Right "caught" 37 | -------------------------------------------------------------------------------- /test/ErrorSpec.hs: -------------------------------------------------------------------------------- 1 | -- | This module is adapted from https://github.com/polysemy-research/polysemy/blob/master/test/ErrorSpec.hs, 2 | -- originally BSD3 license, authors Sandy Maguire et al. 3 | module ErrorSpec where 4 | 5 | import Cleff 6 | import Cleff.Error 7 | import Cleff.Fail 8 | import Cleff.Mask 9 | import Control.Monad.Fail (fail) 10 | import Prelude hiding (fail) 11 | import Test.Hspec 12 | import qualified UnliftIO.Exception as Exc 13 | 14 | newtype MyExc = MyExc String 15 | deriving stock (Show, Eq) 16 | deriving anyclass (Exc.Exception) 17 | 18 | spec :: Spec 19 | spec = parallel do 20 | it "should catch exceptions" do 21 | a <- runIOE $ runError $ fromException @MyExc do 22 | _ <- Exc.throwIO $ MyExc "hello" 23 | pure () 24 | a `shouldBe` Left (MyExc "hello") 25 | 26 | it "should not catch non-exceptions" do 27 | a <- runIOE $ runError @MyExc $ fromException @MyExc $ pure () 28 | a `shouldBe` Right () 29 | 30 | it "should interact well with Mask" do 31 | a <- runIOE $ runMask $ runError @MyExc $ onError (do 32 | _ <- throwError $ MyExc "hello" 33 | pure ()) $ throwError (MyExc "goodbye") 34 | a `shouldBe` Left (MyExc "hello") 35 | 36 | it "should not catch prematurely" do 37 | b <- runIOE $ runFail $ runError @String $ fail "Boom" >> pure () 38 | b `shouldBe` Left "Boom" 39 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Xy Ren (c) 2021 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Xy Ren nor the names of other contributors 17 | may be used to endorse or promote products derived from this 18 | software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /cleff-plugin/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Xy Ren (c) 2022 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Xy Ren nor the names of other contributors 17 | may be used to endorse or promote products derived from this 18 | software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /cleff-plugin/README.md: -------------------------------------------------------------------------------- 1 | # `cleff-plugin` 2 | 3 | This GHC typechecking plugin disambiguates obvious usages of effects for the extensible effect framework `cleff`. 4 | 5 | ## Usage 6 | 7 | This plugin works with GHC 8.6 through 9.2 and `cleff >= 0.1 && < 0.4`. To use the plugin: 8 | 9 | 1. Add this plugin as your package's dependency. 10 | - If you use `stack`, then you also need to add these lines your `stack.yaml`: 11 | ```yaml 12 | extra-deps: 13 | - cleff-plugin-0.1.0.0 14 | ``` 15 | 2. Enable the plugin by adding the following GHC option to your project file: 16 | ``` 17 | ghc-options: -fplugin=Cleff.Plugin 18 | ``` 19 | 20 | ## What it does 21 | 22 | When using `cleff`, the following code would not compile: 23 | 24 | ```haskell 25 | action :: '[State Int, State String] :>> es => Eff es () 26 | action = do 27 | x <- get 28 | put (x + 1) 29 | -- • Could not deduce (Cleff.Internal.Rec.Elem (State s0) es) 30 | -- arising from a use of ‘get’ 31 | ``` 32 | 33 | This is because GHC is unable to determine which `State` effect we're trying to operate on, although the only viable choice is `State Int`. We had to write: 34 | 35 | ```haskell 36 | action :: '[State Int, State String] :>> es => Eff es () 37 | action = do 38 | x <- get @Int 39 | put (x + 1) 40 | ``` 41 | 42 | This is quite unwieldy. This plugin tells GHC extra information so code like this can typecheck without requiring manually annotating which effect to use. 43 | 44 | ## References 45 | 46 | This plugin's design is largely inspired by [`polysemy-plugin`](https://hackage.haskell.org/package/polysemy-plugin), which is in turn based on [`simple-effects`](https://hackage.haskell.org/package/simple-effects). 47 | 48 | Refer to [`docs/plugin-spec.md`](https://github.com/re-xyr/cleff/tree/master/docs/plugin-spec.md) for details on the disambiguation algorithm this typecheck plugin uses. 49 | -------------------------------------------------------------------------------- /src/Cleff/Trace.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | -- | 3 | -- Copyright: (c) 2021 Xy Ren 4 | -- License: BSD3 5 | -- Maintainer: xy.r@outlook.com 6 | -- Stability: experimental 7 | -- Portability: non-portable (GHC only) 8 | module Cleff.Trace 9 | ( -- * Effect 10 | Trace (..) 11 | -- * Operations 12 | , trace 13 | -- * Interpretations 14 | , runTraceHandle 15 | , runTraceStdout 16 | , runTraceStderr 17 | , ignoreTrace 18 | , traceToOutput 19 | ) where 20 | 21 | import Cleff 22 | import Cleff.Output 23 | import System.IO (Handle, hPutStrLn, stderr, stdout) 24 | 25 | -- * Effect 26 | 27 | -- | An effect capable of logging messages, mostly for debugging purposes. 28 | data Trace :: Effect where 29 | Trace :: String -> Trace m () 30 | 31 | -- * Operations 32 | 33 | makeEffect_ ''Trace 34 | 35 | -- | Output a trace message. 36 | trace :: Trace :> es => String -> Eff es () 37 | 38 | -- * Interpretations 39 | 40 | -- | Run the 'Trace' effect by writing to a 'Handle'. 41 | runTraceHandle :: IOE :> es => Handle -> Eff (Trace : es) a -> Eff es a 42 | runTraceHandle h = interpretIO \case 43 | Trace s -> hPutStrLn h s 44 | 45 | -- | Run the 'Trace' effect by writing to 'stdout'. 46 | runTraceStdout :: IOE :> es => Eff (Trace : es) ~> Eff es 47 | runTraceStdout = runTraceHandle stdout 48 | 49 | -- | Run the 'Trace' effect by writing to 'stderr'. 50 | runTraceStderr :: IOE :> es => Eff (Trace : es) ~> Eff es 51 | runTraceStderr = runTraceHandle stderr 52 | 53 | -- | Run the 'Trace' effect by ignoring all outputs altogether. 54 | ignoreTrace :: Eff (Trace : es) ~> Eff es 55 | ignoreTrace = interpret \case 56 | Trace _ -> pure () 57 | 58 | -- | Transform the 'Trace' effect into an @'Output' 'String'@ effect. 59 | traceToOutput :: Eff (Trace : es) ~> Eff (Output String : es) 60 | traceToOutput = reinterpret \case 61 | Trace s -> output s 62 | -------------------------------------------------------------------------------- /docs/plugin-spec.md: -------------------------------------------------------------------------------- 1 | # Specification of the disambiguation algorithm used in `cleff-plugin` 2 | 3 | ## Notations 4 | 5 | - Concrete type and type constructors are written in capital letters (`E`) 6 | - Type variables are written in lower case (`e`) 7 | - A type that can have any form is written in curly braces (`{e}`) 8 | 9 | ## The algorithm 10 | 11 | - Given the set of already solved constraints *Given*, and the set of constraints that GHC is unable to solve *Wanted*. 12 | - Take the set of constraints of form `E {x1 ... xn} :> {es}` separately from *Given* and *Wanted*, call them respectively *RelevantGiven* and *RelevantWanted*. 13 | - Take the set of constraints *not* of form `E {x1 ... xn} :> {es}` from *Wanted*, call it *ExtraWanted*. 14 | - For each constraint in *RelevantWanted* `E {x1 ... xn} :> {es}`: 15 | - If `{es}` is of form `E1 {...} : E2 {...} : ... : es`, *i.e.* has concrete elements on its head: 16 | - Extract them as constraints in the form of `E1 ... :> {es}`, `E2 ... :> {es}` etc, then merge this set with *RelevantGiven* into a new set *Candidate*. 17 | - Otherwise, *Candidate* is the same as *RelevantGiven*. 18 | - For each constraint in the set *Candidate* `E' {b1 ... bn} :> {es'}`, if the following criteria are all met, add it to a new set *UnifiableCandidate*: 19 | - `E` and `E'` are the same type; 20 | - `{es}` and `{es'}` are the same type; 21 | - There is a substitution **s** that unifies `E {a1 ... an}` and `E' {b1 ... bn}`. 22 | - If there is only one *UnifiableCandidate*, use it as the solution. 23 | - Otherwise, for each constraint in the set *UnifiableCandidate* of form `E' {b1 ... bn} :> {es'}` and corresponding substitution **s**: 24 | - If **s**(*Given*) satisfies all constraints in **s**(*ExtraWanted*), add it to a new set *SatisfiableCandidate*. 25 | - If there is only one *SatisfiableCandidate*, use it as the solution. 26 | - Otherwise, we're unable to produce a unique solution. 27 | -------------------------------------------------------------------------------- /src/Cleff/Reader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | -- | 3 | -- Copyright: (c) 2021 Xy Ren 4 | -- License: BSD3 5 | -- Maintainer: xy.r@outlook.com 6 | -- Stability: experimental 7 | -- Portability: non-portable (GHC only) 8 | module Cleff.Reader 9 | ( -- * Effect 10 | Reader (..) 11 | -- * Operations 12 | , ask 13 | , local 14 | , asks 15 | -- * Interpretations 16 | , runReader 17 | , magnify 18 | ) where 19 | 20 | import Cleff 21 | import Lens.Micro (Lens', (%~), (&), (^.)) 22 | 23 | -- * Effect 24 | 25 | -- | An effect capable of providing an immutable environment @r@ that can be read. This roughly corresponds to the 26 | -- @MonadReader@ typeclass and @ReaderT@ monad transformer in the @mtl@ library. 27 | data Reader r :: Effect where 28 | Ask :: Reader r m r 29 | Local :: (r -> r) -> m a -> Reader r m a 30 | 31 | -- * Operations 32 | 33 | makeEffect_ ''Reader 34 | 35 | -- | Obtain the environment value. 36 | ask :: Reader r :> es => Eff es r 37 | 38 | -- | Modify the environment value temporarily for a computation. 39 | local :: Reader r :> es 40 | => (r -> r) -- ^ The function that modifies the environment 41 | -> Eff es a -- ^ The computation to run with the modified environment 42 | -> Eff es a 43 | 44 | -- | Apply a function to the result of 'ask'. 45 | asks :: Reader r :> es => (r -> s) -> Eff es s 46 | asks = (<$> ask) 47 | 48 | -- * Interpretations 49 | 50 | -- | Run a 'Reader' effect with a given environment value. 51 | runReader :: r -> Eff (Reader r : es) ~> Eff es 52 | runReader x = interpret (handle x) 53 | where 54 | handle :: r -> Handler (Reader r) es 55 | handle r = \case 56 | Ask -> pure r 57 | Local f m -> toEffWith (handle (f r)) m 58 | 59 | -- | Run a 'Reader' effect in terms of a larger 'Reader' via a 'Lens''. 60 | magnify :: Reader t :> es => Lens' t r -> Eff (Reader r : es) ~> Eff es 61 | magnify field = interpret \case 62 | Ask -> asks (^. field) 63 | Local f m -> local (& field %~ f) $ toEff m 64 | -------------------------------------------------------------------------------- /test/ConcurrencySpec.hs: -------------------------------------------------------------------------------- 1 | module ConcurrencySpec where 2 | 3 | import Cleff 4 | import Cleff.Error (runError, throwError) 5 | import Cleff.State 6 | import Control.Monad (void, when) 7 | import Data.Set (Set) 8 | import qualified Data.Set as Set 9 | import Test.Hspec 10 | import UnliftIO (concurrently_, replicateConcurrently_) 11 | import UnliftIO.Concurrent (threadDelay) 12 | 13 | spec :: Spec 14 | spec = do 15 | sharedState 16 | localState 17 | errorHandling 18 | 19 | sharedState :: Spec 20 | sharedState = it "should have shared state" do 21 | (_, set) <- runIOE $ runState (Set.empty @Int) do 22 | concurrently_ (addWhen even x) (addWhen odd x) 23 | set `shouldBe` Set.fromList [1..x] 24 | where 25 | x :: Int = 100 26 | addWhen :: State (Set Int) :> es => (Int -> Bool) -> Int -> Eff es () 27 | addWhen f = \case 28 | 0 -> pure () 29 | n -> do 30 | when (f n) $ do 31 | modify $ Set.insert n 32 | addWhen f $ n - 1 33 | 34 | localState :: Spec 35 | localState = it "should have local state" $ 36 | void $ runIOE $ runStateLocal x $ do 37 | replicateConcurrently_ 2 $ do 38 | r <- goDownward 0 39 | liftIO $ r `shouldBe` x 40 | where 41 | x :: Int 42 | x = 100000 43 | 44 | goDownward :: State Int :> es => Int -> Eff es Int 45 | goDownward acc = do 46 | end <- state @Int $ \case 47 | 0 -> (True, 0) 48 | n -> (False, n - 1) 49 | if end 50 | then pure acc 51 | else goDownward $ acc + 1 52 | 53 | errorHandling :: Spec 54 | errorHandling = it "should handle errors properly" do 55 | (r, s) <- runIOE $ runState (0 :: Int) $ runError @String $ concurrently_ 56 | (liftIO (threadDelay 10000) >> throwError err) 57 | (modify (+x)) 58 | case r of 59 | Left e -> e `shouldBe` err 60 | Right _ -> expectationFailure "no error caught - or error escaped" 61 | s `shouldBe` x 62 | where 63 | x :: Int = 67 64 | err = "error" 65 | -------------------------------------------------------------------------------- /example/Filesystem.hs: -------------------------------------------------------------------------------- 1 | -- | This module is adapted from https://github.com/arybczak/effectful/blob/master/effectful/examples/FileSystem.hs, 2 | -- originally BSD3 license, authors Andrzej Rybczak et al. 3 | module Filesystem where 4 | 5 | import Cleff 6 | import Cleff.Error 7 | import Cleff.State 8 | import Control.Monad.Extra (maybeM) 9 | import Data.Map.Strict (Map) 10 | import qualified Data.Map.Strict as M 11 | import qualified System.IO as IO 12 | import UnliftIO.Exception 13 | 14 | -- * Effect 15 | 16 | -- | An effect for reading and writing files. 17 | data Filesystem :: Effect where 18 | ReadFile :: FilePath -> Filesystem m String 19 | WriteFile :: FilePath -> String -> Filesystem m () 20 | 21 | -- * Operations 22 | 23 | makeEffect ''Filesystem 24 | 25 | -- * Interpretations 26 | 27 | -- | File system error. 28 | newtype FsError = FsError String 29 | deriving stock (Show) 30 | deriving anyclass (Exception) 31 | 32 | -- | Run the 'Filesystem' effect with actual file IO. 33 | runFilesystemIO :: '[IOE, Error FsError] :>> es => Eff (Filesystem : es) a -> Eff es a 34 | runFilesystemIO = interpret \case 35 | ReadFile path -> adapt $ IO.readFile path 36 | WriteFile path contents -> adapt $ IO.writeFile path contents 37 | where 38 | adapt m = liftIO m `catch` \(e :: IOException) -> throwError $ FsError $ show e 39 | 40 | -- | Run the 'Filesystem' effect with a faked filesystem. 41 | runFilesystemPure :: Error FsError :> es => Map FilePath String -> Eff (Filesystem : es) a -> Eff es a 42 | runFilesystemPure fs = fmap fst . runState fs . reinterpret \case 43 | ReadFile path -> maybeM (throwError $ FsError $ "File not found: " ++ show path) pure $ gets (M.lookup path) 44 | WriteFile path contents -> modify $ M.insert path contents 45 | 46 | f :: Either FsError (Either FsError String) 47 | f = runPure $ runError @FsError $ runFilesystemPure M.empty $ runError @FsError $ Filesystem.readFile "nonexistent" 48 | 49 | -- >>> f 50 | -- Left (FsError "File not found: \"nonexistent\"") 51 | -------------------------------------------------------------------------------- /cleff-plugin/package.yaml: -------------------------------------------------------------------------------- 1 | name: cleff-plugin 2 | version: 0.1.1.0 3 | github: "re-xyr/cleff" 4 | license: BSD3 5 | author: "Xy Ren" 6 | maintainer: "xy.r@outlook.com" 7 | copyright: "2022 Xy Ren" 8 | 9 | tested-with: 10 | - GHC == 8.6.5 11 | - GHC == 8.8.4 12 | - GHC == 8.10.7 13 | - GHC == 9.0.2 14 | - GHC == 9.2.2 15 | 16 | extra-source-files: 17 | - CHANGELOG.md 18 | - README.md 19 | 20 | synopsis: Automatic disambiguation for extensible effects 21 | category: Control, Effect, Language 22 | 23 | description: Please see the README on GitHub at 24 | 25 | dependencies: 26 | - base >= 4.12 && < 4.17 27 | - cleff >= 0.1 && < 0.4 28 | - containers >= 0.5 && < 0.7 29 | - ghc >= 8.6 && < 9.3 30 | - ghc-tcplugins-extra >= 0.3 && < 0.5 31 | 32 | ghc-options: 33 | - -Wall 34 | - -Widentities 35 | - -Wincomplete-record-updates 36 | - -Wincomplete-uni-patterns 37 | - -Wno-unticked-promoted-constructors 38 | - -Wpartial-fields 39 | - -Wunused-type-patterns 40 | # - -ddump-simpl 41 | # - -ddump-hi 42 | # - -ddump-to-file 43 | # - -dsuppress-all 44 | # - -dsuppress-uniques 45 | 46 | when: 47 | - condition: impl(ghc >= 8.8) 48 | ghc-options: 49 | - -Wmissing-deriving-strategies 50 | 51 | default-extensions: 52 | - BangPatterns 53 | - BlockArguments 54 | - DerivingStrategies 55 | - EmptyCase 56 | - FlexibleContexts 57 | - FlexibleInstances 58 | - LambdaCase 59 | - NoStarIsType 60 | - PolyKinds 61 | - ScopedTypeVariables 62 | - TupleSections 63 | - UnicodeSyntax 64 | 65 | library: 66 | source-dirs: src 67 | ghc-options: 68 | - -Wmissing-export-lists 69 | 70 | tests: 71 | cleff-plugin-test: 72 | main: Main.hs 73 | source-dirs: test 74 | ghc-options: 75 | - -threaded 76 | - -rtsopts 77 | - -with-rtsopts=-N 78 | dependencies: 79 | - cleff 80 | - cleff-plugin 81 | default-extensions: 82 | - DataKinds 83 | - FunctionalDependencies 84 | - TemplateHaskell 85 | - GADTs 86 | - GeneralizedNewtypeDeriving 87 | - KindSignatures 88 | - RankNTypes 89 | - TypeApplications 90 | - TypeFamilies 91 | - TypeOperators 92 | - UndecidableInstances 93 | -------------------------------------------------------------------------------- /src/Cleff/Fresh.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | -- | 3 | -- Copyright: (c) 2021 Xy Ren 4 | -- License: BSD3 5 | -- Maintainer: xy.r@outlook.com 6 | -- Stability: experimental 7 | -- Portability: non-portable (GHC only) 8 | module Cleff.Fresh 9 | ( -- * Effect 10 | Fresh (..) 11 | -- * Operations 12 | , fresh 13 | -- * Interpretations 14 | , freshIntToState 15 | , freshEnumToState 16 | , runFreshAtomicCounter 17 | , runFreshUnique 18 | ) where 19 | 20 | import Cleff 21 | import Cleff.Internal.Base (thisIsPureTrustMe) 22 | import Cleff.State 23 | import Data.Atomics.Counter (incrCounter, newCounter) 24 | import Data.Unique (Unique, newUnique) 25 | 26 | -- * Effect 27 | 28 | -- | An effect capable of generating unique values. This effect can be useful in generating variable indices. 29 | data Fresh u :: Effect where 30 | Fresh :: Fresh u m u 31 | 32 | -- * Operations 33 | 34 | makeEffect_ ''Fresh 35 | 36 | -- | Obtain a fresh unique value. 37 | fresh :: Fresh u :> es => Eff es u 38 | 39 | -- * Interpretations 40 | 41 | -- | Interpret a @'Fresh' a@ in terms of @'State' a@ for any 'Enum'. Every time 'succ' is called to generate the next 42 | -- value. 43 | -- 44 | -- @since 0.2.1.0 45 | freshEnumToState :: Enum a => Eff (Fresh a : es) ~> Eff (State a : es) 46 | freshEnumToState = reinterpret \case 47 | Fresh -> state \s -> (s, succ s) 48 | 49 | -- | Interpret a @'Fresh' 'Int'@ effect in terms of @'State' 'Int'@. This is a specialized version of 50 | -- 'freshEnumToState'. 51 | freshIntToState :: Eff (Fresh Int : es) ~> Eff (State Int : es) 52 | freshIntToState = freshEnumToState 53 | 54 | -- | Interpret a @'Fresh' 'Int'@ effect in terms of a 'Data.Atomics.Counter.AtomicCounter'. This is usually faster 55 | -- than 'runFreshUnique'. 56 | -- 57 | -- @since 0.2.1.0 58 | runFreshAtomicCounter :: Eff (Fresh Int : es) ~> Eff es 59 | runFreshAtomicCounter m = thisIsPureTrustMe do 60 | counter <- liftIO $ newCounter minBound 61 | reinterpret (\case 62 | Fresh -> liftIO $ incrCounter 1 counter) m 63 | 64 | -- | Interpret a @'Fresh' 'Unique'@ effect in terms of IO actions. This is slower than 'runFreshAtomicCounter', but it 65 | -- won't overflow on @'maxBound' :: 'Int'@. 66 | runFreshUnique :: IOE :> es => Eff (Fresh Unique : es) ~> Eff es 67 | runFreshUnique = interpret \case 68 | Fresh -> liftIO newUnique 69 | -------------------------------------------------------------------------------- /src/Cleff/Output.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | -- | 3 | -- Copyright: (c) 2021 Xy Ren 4 | -- License: BSD3 5 | -- Maintainer: xy.r@outlook.com 6 | -- Stability: experimental 7 | -- Portability: non-portable (GHC only) 8 | module Cleff.Output 9 | ( -- * Effect 10 | Output (..) 11 | -- * Operations 12 | , output 13 | -- * Interpretations 14 | , outputToListState 15 | , outputToWriter 16 | , ignoreOutput 17 | , runOutputEff 18 | , mapOutput 19 | , bindOutput 20 | ) where 21 | 22 | import Cleff 23 | import Cleff.State 24 | import Cleff.Writer 25 | 26 | -- * Effect 27 | 28 | -- | An effect that is capable of producing outputs, for example writing to a log file or an output stream. 29 | data Output o :: Effect where 30 | Output :: o -> Output o m () 31 | 32 | -- * Operations 33 | 34 | makeEffect_ ''Output 35 | 36 | -- | Produce an output value. 37 | output :: Output o :> es => o -> Eff es () 38 | 39 | -- * Interpretations 40 | 41 | -- | Run an 'Output' effect by accumulating a list. Note that outputs are being prepended to the head of the list, so 42 | -- in many cases you would want to 'reverse' the result. 43 | outputToListState :: Eff (Output o : es) ~> Eff (State [o] : es) 44 | outputToListState = reinterpret \case 45 | Output x -> modify (x :) 46 | 47 | -- | Run an 'Output' effect by translating it into a 'Writer'. 48 | outputToWriter :: (o -> o') -> Eff (Output o : es) ~> Eff (Writer o' : es) 49 | outputToWriter f = reinterpret \case 50 | Output x -> tell $ f x 51 | 52 | -- | Ignore outputs of an 'Output' effect altogether. 53 | ignoreOutput :: Eff (Output o : es) ~> Eff es 54 | ignoreOutput = interpret \case 55 | Output _ -> pure () 56 | 57 | -- | Run an 'Output' effect by performing a computation for each output. 58 | runOutputEff :: (o -> Eff es ()) -> Eff (Output o : es) ~> Eff es 59 | runOutputEff m = interpret \case 60 | Output x -> m x 61 | 62 | -- | Transform an 'Output' effect into another one already in the effect stack, by a pure function. 63 | -- 64 | -- @since 0.2.1.0 65 | mapOutput :: Output o' :> es => (o -> o') -> Eff (Output o : es) ~> Eff es 66 | mapOutput f = interpret \case 67 | Output x -> output $ f x 68 | 69 | -- | Transform an 'Output' effect into another one already in the effect stack, by an effectful computation. 70 | -- 71 | -- @since 0.2.1.0 72 | bindOutput :: Output o' :> es => (o -> Eff es o') -> Eff (Output o : es) ~> Eff es 73 | bindOutput f = interpret \case 74 | Output x -> output =<< f x 75 | -------------------------------------------------------------------------------- /src/Cleff/Input.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | -- | 3 | -- Copyright: (c) 2021 Xy Ren 4 | -- License: BSD3 5 | -- Maintainer: xy.r@outlook.com 6 | -- Stability: experimental 7 | -- Portability: non-portable (GHC only) 8 | module Cleff.Input 9 | ( -- * Effect 10 | Input (..) 11 | -- * Operations 12 | , input 13 | , inputs 14 | -- * Interpretations 15 | , runInputConst 16 | , inputToListState 17 | , inputToReader 18 | , runInputEff 19 | , mapInput 20 | , bindInput 21 | ) where 22 | 23 | import Cleff 24 | import Cleff.Reader 25 | import Cleff.State 26 | 27 | -- * Effect 28 | 29 | -- | An effect that is capable of reading from some input source, such as an input stream. 30 | data Input i :: Effect where 31 | Input :: Input i m i 32 | 33 | -- * Operations 34 | 35 | makeEffect_ ''Input 36 | 37 | -- | Read an input value from an input source. 38 | input :: Input i :> es => Eff es i 39 | 40 | -- | Apply a function to the result of 'input'. 41 | inputs :: Input i :> es => (i -> i') -> Eff es i' 42 | inputs f = f <$> input 43 | 44 | -- * Interpretations 45 | 46 | -- | Run an 'Input' effect by giving a constant input value. 47 | runInputConst :: i -> Eff (Input i : es) ~> Eff es 48 | runInputConst x = interpret \case 49 | Input -> pure x 50 | 51 | -- | Run an 'Input' effect by going through a list of values. 52 | inputToListState :: Eff (Input (Maybe i) : es) ~> Eff (State [i] : es) 53 | inputToListState = reinterpret \case 54 | Input -> state \case 55 | [] -> (Nothing, []) 56 | x : xs -> (Just x, xs) 57 | 58 | -- | Run an 'Input' in terms of a 'Reader'. 59 | -- 60 | -- @since 0.2.1.0 61 | inputToReader :: Eff (Input i : es) ~> Eff (Reader i : es) 62 | inputToReader = reinterpret \case 63 | Input -> ask 64 | 65 | -- | Run an 'Input' effect by performing a computation for each input request. 66 | runInputEff :: Eff es i -> Eff (Input i : es) ~> Eff es 67 | runInputEff m = interpret \case 68 | Input -> m 69 | 70 | -- | Transform an 'Input' effect into another one already in the effect stack, by a pure function. 71 | -- 72 | -- @since 0.2.1.0 73 | mapInput :: Input i' :> es => (i' -> i) -> Eff (Input i : es) ~> Eff es 74 | mapInput f = interpret \case 75 | Input -> f <$> input 76 | 77 | -- | Transform an 'Input' effect into another one already in the effect stack, by an effectful computation. 78 | -- 79 | -- @since 0.2.1.0 80 | bindInput :: Input i' :> es => (i' -> Eff es i) -> Eff (Input i : es) ~> Eff es 81 | bindInput f = interpret \case 82 | Input -> f =<< input 83 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog for `cleff` 2 | 3 | ## Unreleased 4 | 5 | ### Changed 6 | 7 | - Internal overhaul 8 | 9 | ## 0.3.3.0 (2022-05-21) 10 | 11 | ### Changed 12 | 13 | - Slight performance improvements 14 | 15 | ### Added 16 | 17 | - `runStateLocal` that runs the `State` effect with thread-local semantics 18 | 19 | ## 0.3.2.0 (2022-03-13) 20 | 21 | ### Changed 22 | 23 | - Slight performance improvements 24 | - `(:>)` is now a typeclass by itself instead of a type synonym 25 | 26 | ## 0.3.1.0 (2022-02-28) 27 | 28 | ### Added 29 | 30 | - `makeEffect` is now capable of generating sending functions for operations using concrete `Eff`s for the monad type 31 | 32 | ### Removed 33 | 34 | - Dependency on `rec-smallarray` 35 | 36 | ## 0.3.0.1 (2022-02-21) 37 | 38 | Clarify changelog: new features that are listed "Unreleased" in 0.3.0.0 changelog are in fact *released* 39 | 40 | ## 0.3.0.0 (2022-02-21) 41 | 42 | ### Changed 43 | 44 | - **[BREAKING]** Introduces an `OnException` primitive for `Mask` that replaces `Bracket` and `BracketOnError` 45 | (note that this only affects the effect datatype; there is still `bracket` and `bracketOnError` *functions* with the same semantics) 46 | - `runError` and `mapError` are slightly (but observably) faster now 47 | 48 | ### Added 49 | 50 | - `freshEnumToState` for `Fresh` 51 | - `onException` and `bracketOnError_` for `Mask` 52 | 53 | ## 0.2.1.0 (2022-02-13) 54 | 55 | ### Added 56 | 57 | - Lifted convenience instances of `Bounded`, `Num`, `Fractional`, `Floating` and `IsString` for `Eff` 58 | - `MonadZip` instance from the `MonadComprehensions` extension for `Eff` 59 | - `runFreshAtomicCounter` for `Fresh` 60 | - `inputToReader`, `mapInput` and `bindInput` for `Input` 61 | - `mapOutput` and `bindOutput` for `Output` 62 | - `runStateIORef`, `runStateMVar` and `runStateTVar` for `State` 63 | 64 | ## 0.2.0.0 (2022-02-06) 65 | 66 | ### Changed 67 | 68 | - **[BREAKING]** Changed parameter order of `Handling` class from `e es esSend` to `esSend e es` 69 | - **[BREAKING]** Relaxed fundep of `Handling` to `esSend -> e es` (HO combinators may require `TypeApplication` more often) 70 | - Moved `Data.*` modules to `Cleff.Internal.*` so as not to pollute common namespaces 71 | 72 | ### Added 73 | 74 | - `Trustworthy` flags for non-internal modules 75 | - `sendVia` for sending an effect operation along a transformation between effect stacks 76 | - `raiseUnder`, `raiseNUnder`, `raiseUnderN`, `raiseNUnderN` for introducing effects under other effects in the effect stack 77 | - `runWriterBatch` as a more efficient `Writer` interpreter that writes `listen`ed values in batch instead of in real time 78 | 79 | ## 0.1.0.0 (2022-01-31) 80 | 81 | - Initial API 82 | -------------------------------------------------------------------------------- /example/Teletype.hs: -------------------------------------------------------------------------------- 1 | -- | This module is adapted from https://github.com/polysemy-research/polysemy/blob/master/README.md, 2 | -- originally BSD3 license, authors Sandy Maguire et al. 3 | module Teletype where 4 | 5 | import Cleff 6 | import Cleff.Error 7 | import Cleff.Input 8 | import Cleff.Mask 9 | import Cleff.Output 10 | import Cleff.State 11 | import Control.Exception (Exception) 12 | import Control.Monad (unless) 13 | import Data.Maybe (fromMaybe) 14 | 15 | -- * Effect 16 | 17 | -- | An effect for reading and writing lines to a tty. 18 | data Teletype :: Effect where 19 | ReadTTY :: Teletype m String 20 | WriteTTY :: String -> Teletype m () 21 | 22 | -- * Operations 23 | 24 | makeEffect ''Teletype 25 | 26 | -- * Interpretations 27 | 28 | -- | Run 'Teletype' via stdio. 29 | runTeletypeIO :: IOE :> es => Eff (Teletype : es) a -> Eff es a 30 | runTeletypeIO = interpretIO \case 31 | ReadTTY -> getLine 32 | WriteTTY s -> putStrLn s 33 | 34 | -- | Run 'Teletype' from a fixed input list. 35 | runTeletypePure :: [String] -> Eff (Teletype : es) w -> Eff es [String] 36 | runTeletypePure tty = fmap (reverse . snd) 37 | . runState [] . outputToListState 38 | . runState tty . inputToListState 39 | . reinterpret2 \case 40 | ReadTTY -> fromMaybe "" <$> input 41 | WriteTTY msg -> output msg 42 | 43 | -- * Examples 44 | 45 | -- | An echoing program. 46 | echo :: Teletype :> es => Eff es () 47 | echo = do 48 | x <- readTTY 49 | unless (null x) $ 50 | writeTTY x >> echo 51 | 52 | -- | The pure interpretation of 'echo', via 'runTeletypePure'. 53 | -- >>> echoPure ["abc", "def", "ghci"] 54 | -- ["abc","def","ghci"] 55 | echoPure :: [String] -> [String] 56 | echoPure tty = runPure $ runTeletypePure tty echo 57 | 58 | -- | The impure interpretation of 'echo', via 'runTeletypeIO'. 59 | echoIO :: IO () 60 | echoIO = runIOE $ runTeletypeIO echo 61 | 62 | data CustomException = ThisException | ThatException 63 | deriving stock (Show) 64 | deriving anyclass (Exception) 65 | 66 | program :: '[Mask, Teletype, Error CustomException] :>> es => Eff es () 67 | program = catchError @CustomException work \e -> writeTTY $ "Caught " ++ show e 68 | where 69 | work = bracket readTTY (const $ writeTTY "exiting bracket") \next -> do 70 | writeTTY "entering bracket" 71 | case next of 72 | "explode" -> throwError ThisException 73 | "weird stuff" -> writeTTY next *> throwError ThatException 74 | _ -> writeTTY next *> writeTTY "no exceptions" 75 | 76 | main :: IO (Either CustomException ()) 77 | main = runIOE $ runMask $ runError @CustomException $ runTeletypeIO program 78 | -------------------------------------------------------------------------------- /src/Data/PrimVec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UnboxedTuples #-} 2 | {-# OPTIONS_HADDOCK not-home #-} 3 | -- | 4 | -- Copyright: (c) 2021 Xy Ren 5 | -- License: BSD3 6 | -- Maintainer: xy.r@outlook.com 7 | -- Stability: unstable 8 | -- Portability: non-portable (GHC only) 9 | module Data.PrimVec (PrimVec, empty, head, tail, take, drop, index, cons, concat, pick, update) where 10 | 11 | import Data.Foldable (for_) 12 | import Data.Primitive (Prim, indexPrimArray) 13 | import Data.Primitive.PrimArray (MutablePrimArray (MutablePrimArray), PrimArray (PrimArray), copyPrimArray, 14 | newPrimArray, writePrimArray) 15 | import GHC.Exts (runRW#, unsafeFreezeByteArray#) 16 | import GHC.ST (ST (ST)) 17 | import Prelude hiding (concat, drop, head, tail, take) 18 | 19 | -- | Slices of 'PrimArray'. 20 | data PrimVec a = PrimVec 21 | {-# UNPACK #-} !Int 22 | {-# UNPACK #-} !Int 23 | {-# UNPACK #-} !(PrimArray a) 24 | 25 | runPrimArray :: (∀ s. ST s (MutablePrimArray s a)) -> PrimArray a 26 | runPrimArray (ST f) = let 27 | !(# _, ba# #) = runRW# \s1 -> 28 | let !(# s2, MutablePrimArray mba# #) = f s1 29 | in unsafeFreezeByteArray# mba# s2 30 | in PrimArray ba# 31 | 32 | empty :: Prim a => PrimVec a 33 | empty = PrimVec 0 0 $ runPrimArray $ newPrimArray 0 34 | 35 | head :: Prim a => PrimVec a -> a 36 | head (PrimVec off _ arr) = indexPrimArray arr off 37 | 38 | tail :: PrimVec a -> PrimVec a 39 | tail (PrimVec off len arr) = PrimVec (off + 1) (len - 1) arr 40 | 41 | take :: Prim a => Int -> PrimVec a -> PrimVec a 42 | take n (PrimVec off _ arr) = PrimVec 0 n $ runPrimArray do 43 | marr <- newPrimArray n 44 | copyPrimArray marr 0 arr off n 45 | pure marr 46 | 47 | drop :: Int -> PrimVec a -> PrimVec a 48 | drop n (PrimVec off len arr) = PrimVec (off + n) (len - n) arr 49 | 50 | index :: Prim a => Int -> PrimVec a -> a 51 | index n (PrimVec off _ arr) = indexPrimArray arr (off + n) 52 | 53 | cons :: Prim a => a -> PrimVec a -> PrimVec a 54 | cons x (PrimVec off len arr) = PrimVec 0 (len + 1) $ runPrimArray do 55 | marr <- newPrimArray (len + 1) 56 | writePrimArray marr 0 x 57 | copyPrimArray marr 1 arr off len 58 | pure marr 59 | 60 | concat :: Prim a => PrimVec a -> PrimVec a -> PrimVec a 61 | concat (PrimVec off len arr) (PrimVec off' len' arr') = PrimVec 0 (len + len') $ runPrimArray do 62 | marr <- newPrimArray (len + len') 63 | copyPrimArray marr 0 arr off len 64 | copyPrimArray marr len arr' off' len' 65 | pure marr 66 | 67 | pick :: Prim a => Int -> [Int] -> PrimVec a -> PrimVec a 68 | pick len' ns (PrimVec off _ arr) = PrimVec 0 len' $ runPrimArray do 69 | marr <- newPrimArray len' 70 | for_ (zip [0 ..] ns) \(new, old) -> 71 | writePrimArray marr new (indexPrimArray arr (off + old)) 72 | pure marr 73 | 74 | update :: Prim a => Int -> a -> PrimVec a -> PrimVec a 75 | update n x (PrimVec off len arr) = PrimVec 0 len $ runPrimArray do 76 | marr <- newPrimArray len 77 | copyPrimArray marr 0 arr off len 78 | writePrimArray marr n x 79 | pure marr 80 | -------------------------------------------------------------------------------- /cleff-plugin/cleff-plugin.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.4. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: cleff-plugin 8 | version: 0.1.1.0 9 | synopsis: Automatic disambiguation for extensible effects 10 | description: Please see the README on GitHub at 11 | category: Control, Effect, Language 12 | homepage: https://github.com/re-xyr/cleff#readme 13 | bug-reports: https://github.com/re-xyr/cleff/issues 14 | author: Xy Ren 15 | maintainer: xy.r@outlook.com 16 | copyright: 2022 Xy Ren 17 | license: BSD3 18 | license-file: LICENSE 19 | build-type: Simple 20 | tested-with: 21 | GHC == 8.6.5 22 | , GHC == 8.8.4 23 | , GHC == 8.10.7 24 | , GHC == 9.0.2 25 | , GHC == 9.2.2 26 | extra-source-files: 27 | CHANGELOG.md 28 | README.md 29 | 30 | source-repository head 31 | type: git 32 | location: https://github.com/re-xyr/cleff 33 | 34 | library 35 | exposed-modules: 36 | Cleff.Plugin 37 | Cleff.Plugin.Internal 38 | other-modules: 39 | Paths_cleff_plugin 40 | hs-source-dirs: 41 | src 42 | default-extensions: 43 | BangPatterns 44 | BlockArguments 45 | DerivingStrategies 46 | EmptyCase 47 | FlexibleContexts 48 | FlexibleInstances 49 | LambdaCase 50 | NoStarIsType 51 | PolyKinds 52 | ScopedTypeVariables 53 | TupleSections 54 | UnicodeSyntax 55 | ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors -Wpartial-fields -Wunused-type-patterns -Wmissing-export-lists 56 | build-depends: 57 | base >=4.12 && <4.17 58 | , cleff >=0.1 && <0.4 59 | , containers >=0.5 && <0.7 60 | , ghc >=8.6 && <9.3 61 | , ghc-tcplugins-extra >=0.3 && <0.5 62 | if impl(ghc >= 8.8) 63 | ghc-options: -Wmissing-deriving-strategies 64 | default-language: Haskell2010 65 | 66 | test-suite cleff-plugin-test 67 | type: exitcode-stdio-1.0 68 | main-is: Main.hs 69 | other-modules: 70 | CleffSpec 71 | Paths_cleff_plugin 72 | hs-source-dirs: 73 | test 74 | default-extensions: 75 | BangPatterns 76 | BlockArguments 77 | DerivingStrategies 78 | EmptyCase 79 | FlexibleContexts 80 | FlexibleInstances 81 | LambdaCase 82 | NoStarIsType 83 | PolyKinds 84 | ScopedTypeVariables 85 | TupleSections 86 | UnicodeSyntax 87 | DataKinds 88 | FunctionalDependencies 89 | TemplateHaskell 90 | GADTs 91 | GeneralizedNewtypeDeriving 92 | KindSignatures 93 | RankNTypes 94 | TypeApplications 95 | TypeFamilies 96 | TypeOperators 97 | UndecidableInstances 98 | ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors -Wpartial-fields -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-N 99 | build-depends: 100 | base >=4.12 && <4.17 101 | , cleff 102 | , cleff-plugin 103 | , containers >=0.5 && <0.7 104 | , ghc >=8.6 && <9.3 105 | , ghc-tcplugins-extra >=0.3 && <0.5 106 | if impl(ghc >= 8.8) 107 | ghc-options: -Wmissing-deriving-strategies 108 | default-language: Haskell2010 109 | -------------------------------------------------------------------------------- /cleff-plugin/test/CleffSpec.hs: -------------------------------------------------------------------------------- 1 | -- Tests copied from `polysemy-plugin` (https://github.com/polysemy-research/polysemy/tree/master/polysemy-plugin/test) 2 | -- (c) 2019 Sandy Maguire, licensed under BSD-3-Clause 3 | {-# LANGUAGE AllowAmbiguousTypes #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# OPTIONS_GHC -Wno-unused-foralls -fplugin=Cleff.Plugin #-} 6 | module CleffSpec where 7 | 8 | import Cleff 9 | import Cleff.Error 10 | import Cleff.State 11 | import Data.String (IsString) 12 | import Unsafe.Coerce (unsafeCoerce) 13 | 14 | class MPTC a b where 15 | mptc :: a -> b 16 | 17 | instance MPTC Bool Int where 18 | mptc _ = 1000 19 | 20 | uniquelyInt :: '[State Int, State String] :>> r => Eff r () 21 | uniquelyInt = put 10 22 | 23 | uniquelyA :: (Num a, '[State a, State b] :>> r) => Eff r () 24 | uniquelyA = put 10 25 | 26 | uniquelyString :: '[State Int, State String] :>> r => Eff r () 27 | uniquelyString = put mempty 28 | 29 | uniquelyB :: (MPTC Bool b, '[State String, State b] :>> r) => Eff r () 30 | uniquelyB = put $ mptc False 31 | 32 | uniquelyState' :: '[Error (), State ()] :>> r => Eff r () 33 | uniquelyState' = pure () 34 | 35 | idState :: State s :> r => Eff r () 36 | idState = do 37 | s <- get 38 | put s 39 | 40 | intState :: State Int :> r => Eff r () 41 | intState = put 10 42 | 43 | numState :: Num a => State a :> r => Eff r () 44 | numState = put 10 45 | 46 | strState :: State String :> r => Eff r () 47 | strState = put "Hello" 48 | 49 | oStrState :: IsString a => State a :> r => Eff r () 50 | oStrState = put "hello" 51 | 52 | err :: Error e :> r => Eff r Bool 53 | err = 54 | catchError 55 | (throwError (error "")) 56 | (\_ -> pure True) 57 | 58 | errState :: Num s => '[Error e, State s] :>> r => Eff r Bool 59 | errState = do 60 | numState 61 | err 62 | 63 | newtype MyString = MyString String 64 | deriving newtype (IsString, Eq, Show) 65 | 66 | data Janky = forall s. Janky (forall _i. Eff '[State s] ()) 67 | 68 | jankyState :: Janky 69 | jankyState = Janky $ put True -- The plugin disambiguates effects for concrete rows too 70 | 71 | unsafeUnjank :: Janky -> Eff '[State Bool] () 72 | unsafeUnjank (Janky m) = unsafeCoerce m 73 | 74 | data MoreJanky = forall y. MoreJanky (MPTC Bool y => Eff '[State (Bool, y), State (Char, y)] ()) 75 | 76 | mptcGet :: MPTC x Bool => x 77 | mptcGet = undefined 78 | 79 | moreJankyState :: MoreJanky 80 | moreJankyState = MoreJanky $ put (mptcGet, True) 81 | 82 | data TaggedState k s m a where 83 | TaggedGet :: forall k s m. TaggedState k s m s 84 | TaggedPut :: forall k s m. s -> TaggedState k s m () 85 | 86 | makeEffect ''TaggedState -- The plugin also disambiguates TH functions generated by 'makeEffect' 87 | 88 | runTaggedState :: forall k s r a 89 | . s 90 | -> Eff (TaggedState k s : r) a 91 | -> Eff r (a, s) 92 | runTaggedState s = 93 | (runState s .) 94 | $ reinterpret 95 | $ \case 96 | TaggedGet -> get 97 | TaggedPut s' -> put s' 98 | 99 | test :: '[ 100 | TaggedState Char Int 101 | , TaggedState Bool Int 102 | ] :>> r 103 | => Eff r () 104 | test = do 105 | taggedPut @Bool 10 106 | taggedPut @Char (-10) 107 | 108 | newtype Select a = Select a 109 | 110 | data DBAction whichDb m a where 111 | DoSelect :: Select a -> DBAction whichDb m (Maybe a) 112 | 113 | makeEffect ''DBAction 114 | 115 | runDBAction :: Eff (DBAction which ': r) a -> Eff r a 116 | runDBAction = interpret $ \case 117 | DoSelect (Select a) -> pure $ Just a 118 | -------------------------------------------------------------------------------- /src/Data/ThreadVar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE UnboxedTuples #-} 3 | {-# OPTIONS_HADDOCK not-home #-} 4 | -- | 5 | -- Copyright: (c) 2021 Xy Ren 6 | -- License: BSD3 7 | -- Maintainer: xy.r@outlook.com 8 | -- Stability: unstable 9 | -- Portability: non-portable (GHC only) 10 | -- 11 | -- This module contains a contention-free thread-local variable datatype. 12 | -- 13 | -- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be 14 | -- extra careful if you're to depend on this module. 15 | module Data.ThreadVar (ThreadVar, newThreadVar, getThreadVar) where 16 | 17 | import Control.Concurrent (myThreadId) 18 | import Control.Monad.IO.Class (MonadIO (liftIO)) 19 | import Data.Atomics (atomicModifyIORefCAS_) 20 | import Data.IntMap.Strict (IntMap) 21 | import qualified Data.IntMap.Strict as Map 22 | import Data.IORef (IORef, newIORef, readIORef) 23 | import Foreign.C.Types 24 | import GHC.Base (noinline) 25 | import GHC.Conc (ThreadId (ThreadId)) 26 | import GHC.Exts (ThreadId#, mkWeak#) 27 | import GHC.IO (IO (IO)) 28 | 29 | -- | Get the hash for a 'ThreadId' in terms of C types (RTS function). 30 | #if __GLASGOW_HASKELL__ >= 903 31 | foreign import ccall unsafe "rts_getThreadId" 32 | getThreadId :: ThreadId# -> CULLong 33 | #elif __GLASGOW_HASKELL__ >= 900 34 | foreign import ccall unsafe "rts_getThreadId" 35 | getThreadId :: ThreadId# -> CLong 36 | #else 37 | foreign import ccall unsafe "rts_getThreadId" 38 | getThreadId :: ThreadId# -> CInt 39 | #endif 40 | 41 | -- | Generates a numeric hash for a 'ThreadId'. Before GHC 9.4, this function has a practical possibility of hash 42 | -- collision on 32-bit or Windows platforms, if threads are created rapidly and thread count exceeds 2^32. After GHC 43 | -- 9.4, this function practically won't produce collision as the hash is extended to 64-bit on all platforms. 44 | hashThreadId :: ThreadId -> Int 45 | hashThreadId (ThreadId tid#) = fromIntegral (getThreadId tid#) 46 | 47 | -- | Attach a finalizer (an 'IO' computation) to a thread. 48 | attachFinalizer :: ThreadId -> IO () -> IO () 49 | attachFinalizer (ThreadId tid#) (IO finalize#) = IO \s1 -> let 50 | !(# s2, _ #) = mkWeak# tid# () finalize# s1 51 | in (# s2, () #) 52 | 53 | -- | A thread-local variable. It is designed so that any operation originating from existing threads produce no 54 | -- contention; thread contention only occurs when multiple new threads attempt to first-time access the variable 55 | -- at the same time. 56 | data ThreadVar a = ThreadVar a {-# UNPACK #-} !(IORef (IntMap (IORef a))) 57 | 58 | -- | Create a thread variable with a same initial value for each thread. 59 | newThreadVar :: a -> IO (ThreadVar a) 60 | newThreadVar x = ThreadVar x <$> newIORef Map.empty 61 | 62 | -- | Get the variable local to this thread, in the form of an 'IORef'. It is guaranteed that the returned 'IORef' 63 | -- will not be read or mutated by other threads inadvertently. 64 | getThreadVar :: ThreadVar a -> IO (IORef a) 65 | getThreadVar (ThreadVar x0 table) = do 66 | tid <- myThreadId 67 | let thash = hashThreadId tid 68 | maybeRef <- Map.lookup thash <$> readIORef table 69 | case maybeRef of 70 | Nothing -> do 71 | ref <- newIORef x0 72 | liftIO $ noinline atomicModifyIORefCAS_ table (Map.insert thash ref) 73 | liftIO $ attachFinalizer tid $ 74 | noinline atomicModifyIORefCAS_ table (Map.delete thash) 75 | pure ref 76 | Just ref -> pure ref 77 | {-# INLINE getThreadVar #-} 78 | -------------------------------------------------------------------------------- /test/StateSpec.hs: -------------------------------------------------------------------------------- 1 | -- | This module is adapted from https://github.com/arybczak/effectful/blob/master/effectful/tests/StateTests.hs, 2 | -- originally BSD3 license, authors Andrzej Rybczak et al. 3 | module StateSpec where 4 | 5 | import Cleff 6 | import Cleff.State 7 | import qualified Control.Exception.Lifted as LE 8 | import qualified Control.Monad.Catch as E 9 | import Test.Hspec 10 | import UnliftIO.Exception 11 | import qualified UnliftIO.Exception as UE 12 | 13 | spec :: Spec 14 | spec = parallel do 15 | it "should run with correct results" basic 16 | it "should run in a deep stack" deepStack 17 | it "should interact well with exceptions" exceptionInteract 18 | it "should run in nested cases" nested 19 | 20 | basic, deepStack, exceptionInteract, nested :: IO () 21 | 22 | basic = do 23 | (end, len) <- runIOE . runState (0::Int) . fmap snd . runState collatzStart $ collatz 24 | end `shouldBe` 1 25 | len `shouldBe` collatzLength 26 | 27 | deepStack = do 28 | n <- runIOE . fmap fst . runState () . fmap snd . runState (0::Int) $ do 29 | fmap fst . runState () . fmap fst . runState () $ do 30 | fmap fst . runState () $ do 31 | fmap fst . runState () . fmap fst . runState () . fmap fst . runState () $ do 32 | modify @Int (+1) 33 | modify @Int (+2) 34 | modify @Int (+4) 35 | modify @Int (+8) 36 | n `shouldBe` 15 37 | 38 | exceptionInteract = do 39 | testTry E.try 40 | testCatch E.catch 41 | testTry LE.try 42 | testCatch LE.catch 43 | testTry UE.try 44 | testCatch UE.catch 45 | where 46 | testTry 47 | :: (∀ a es. IOE :> es => Eff es a -> Eff es (Either Ex a)) 48 | -> IO () 49 | testTry tryImpl = do 50 | e <- runIOE $ tryImpl $ runState (0::Int) action 51 | e `shouldBe` Left Ex 52 | s <- runIOE $ fmap snd $ runState (0::Int) $ tryImpl action 53 | s `shouldBe` 1 54 | testCatch 55 | :: (∀ a es. IOE :> es => Eff es a -> (Ex -> Eff es a) -> Eff es a) 56 | -> IO () 57 | testCatch catchImpl = do 58 | s <- runIOE . fmap snd . runState (0::Int) $ do 59 | _ <- (fmap fst . runState () $ action) `catchImpl` \Ex -> modify @Int (+4) 60 | modify @Int (+8) 61 | s `shouldBe` 13 62 | action :: '[State Int, IOE] :>> es => Eff es () 63 | action = do 64 | modify @Int (+1) 65 | _ <- throwIO Ex 66 | modify @Int (+2) 67 | 68 | nested = do 69 | x <- runIOE do 70 | runHasInt 0 do 71 | putInt 1 72 | fmap snd . runState () $ do 73 | putInt 2 74 | fmap snd . runState () $ do 75 | putInt expected 76 | getInt 77 | x `shouldBe` expected 78 | where 79 | expected :: Int 80 | expected = 4 81 | 82 | data HasInt :: Effect where 83 | GetInt :: HasInt m Int 84 | PutInt :: Int -> HasInt m () 85 | 86 | getInt :: HasInt :> es => Eff es Int 87 | getInt = send GetInt 88 | 89 | putInt :: HasInt :> es => Int -> Eff es () 90 | putInt = send . PutInt 91 | 92 | runHasInt :: Int -> Eff (HasInt : es) a -> Eff es a 93 | runHasInt n = 94 | fmap fst . runState () . fmap fst . runState n . fmap fst . runState True . reinterpret3 \case 95 | GetInt -> get 96 | PutInt i -> put i 97 | 98 | data Ex = Ex 99 | deriving stock (Eq, Show) 100 | deriving anyclass (Exception) 101 | 102 | collatzStart :: Integer 103 | collatzStart = 9780657630 104 | 105 | collatzLength :: Int 106 | collatzLength = 1132 107 | 108 | -- | Tests multiple 'State'S, 'put', 'get' and 'modify'. 109 | collatz :: (State Integer :> es, State Int :> es) => Eff es () 110 | collatz = get @Integer >>= \case 111 | 1 -> pure () 112 | n -> if even n 113 | then do put $ n `div` 2 114 | modify @Int (+1) 115 | collatz 116 | else do put $ 3*n + 1 117 | modify @Int (+1) 118 | collatz 119 | {-# NOINLINE collatz #-} 120 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: cleff 2 | version: 0.3.4.0 3 | github: "re-xyr/cleff" 4 | license: BSD3 5 | author: "Xy Ren" 6 | maintainer: "xy.r@outlook.com" 7 | copyright: "2021 Xy Ren" 8 | 9 | tested-with: 10 | - GHC == 8.6.5 11 | - GHC == 8.8.4 12 | - GHC == 8.10.7 13 | - GHC == 9.0.2 14 | - GHC == 9.2.2 15 | 16 | extra-source-files: 17 | - CHANGELOG.md 18 | - README.md 19 | 20 | synopsis: Fast and concise extensible effects 21 | category: Control, Effect, Language 22 | 23 | description: | 24 | @cleff@ is an effect system for building modular, well-abstracted and performant programs. It provides: 25 | 26 | - Blazing-fast speed in the majority of use cases (<#benchmarks Benchmarks>) 27 | - Well-built integration with the existing Haskell ecosystem (@unliftio@, @monad-control@, @exceptions@...) 28 | - Predictable behavior under expections and concurrency that does not stab you in the back 29 | - Flexible and expressive API for power users, with first-class support of scoped effects 30 | 31 | You can use @cleff@ out of the box, with little to no boilerplate. To get started, use the module "Cleff" as a 32 | starting point. 33 | 34 | dependencies: 35 | - atomic-primops >= 0.8 && < 0.9 36 | - base >= 4.12 && < 4.17 37 | - containers >= 0.5 && < 0.7 38 | - exceptions >= 0.10 && < 0.11 39 | - microlens >= 0.1 && < 0.5 40 | - monad-control >= 1 && < 1.1 41 | - primitive >= 0.6.4 && < 0.8 42 | - stm >= 2.5 && < 2.6 43 | - template-haskell >= 2.14 && < 2.19 44 | - th-abstraction >= 0.2 && < 0.5 45 | - transformers-base >= 0.4 && < 0.5 46 | - unliftio-core >= 0.1.1 && < 0.3 47 | 48 | flags: 49 | dynamic-ioe: 50 | description: | 51 | Make @IOE@ a real effect. This is only for reference purposes and should not be enabled in production code. 52 | manual: true 53 | default: false 54 | 55 | ghc-options: 56 | - -Wall 57 | - -Widentities 58 | - -Wincomplete-record-updates 59 | - -Wincomplete-uni-patterns 60 | - -Wno-unticked-promoted-constructors 61 | - -Wpartial-fields 62 | - -Wunused-type-patterns 63 | # - -ddump-hi 64 | # - -ddump-simpl 65 | # - -ddump-to-file 66 | # - -dsuppress-all 67 | # - -dsuppress-uniques 68 | 69 | when: 70 | - condition: flag(dynamic-ioe) 71 | cpp-options: 72 | - -DDYNAMIC_IOE 73 | - condition: impl(ghc >= 8.8) 74 | ghc-options: 75 | - -Wmissing-deriving-strategies 76 | 77 | default-extensions: 78 | - BangPatterns 79 | - BlockArguments 80 | - ConstraintKinds 81 | - DataKinds 82 | - DeriveAnyClass 83 | - DerivingStrategies 84 | - DerivingVia 85 | - EmptyCase 86 | - FlexibleContexts 87 | - FlexibleInstances 88 | - FunctionalDependencies 89 | - GADTs 90 | - GeneralizedNewtypeDeriving 91 | - LambdaCase 92 | - MagicHash 93 | - NoStarIsType 94 | - PatternSynonyms 95 | - PolyKinds 96 | - RankNTypes 97 | - RoleAnnotations 98 | - ScopedTypeVariables 99 | - StandaloneDeriving 100 | - TemplateHaskell 101 | - TupleSections 102 | - TypeApplications 103 | - TypeFamilies 104 | - TypeOperators 105 | - UndecidableInstances 106 | - UnicodeSyntax 107 | - UnliftedFFITypes 108 | - ViewPatterns 109 | 110 | library: 111 | source-dirs: src 112 | ghc-options: 113 | - -Wmissing-export-lists 114 | other-modules: 115 | - Data.Any 116 | - Data.PrimVec 117 | - Data.RadixVec 118 | - Data.ThreadVar 119 | 120 | tests: 121 | cleff-test: 122 | main: Main.hs 123 | source-dirs: test 124 | ghc-options: 125 | - -threaded 126 | - -rtsopts 127 | - -with-rtsopts=-N 128 | dependencies: 129 | - cleff 130 | - extra 131 | - hspec 132 | - lifted-base 133 | - unliftio 134 | 135 | cleff-example: 136 | main: Main.hs 137 | source-dirs: example 138 | ghc-options: 139 | - -threaded 140 | - -rtsopts 141 | - -with-rtsopts=-N 142 | dependencies: 143 | - cleff 144 | - extra 145 | - unliftio 146 | -------------------------------------------------------------------------------- /test/ThSpec.hs: -------------------------------------------------------------------------------- 1 | -- | This module is adapted from https://github.com/arybczak/effectful/blob/master/effectful/tests/ThEffectSpec.hs, 2 | -- originally BSD3 license, authors Andrzej Rybczak et al. 3 | module ThSpec where 4 | 5 | import Cleff 6 | import Data.Kind (Type) 7 | import GHC.TypeLits (KnownNat, Nat, type (+)) 8 | import Test.Hspec 9 | 10 | spec :: Spec 11 | spec = it "should compile" True 12 | 13 | data SimpleADT m a = SimpleADTC1 Int | SimpleADTC2 String 14 | 15 | makeEffect ''SimpleADT 16 | 17 | data GADTSyntax m a where 18 | GADTSyntaxC1 :: Int -> GADTSyntax m a 19 | GADTSyntaxC2 :: String -> GADTSyntax m a 20 | 21 | makeEffect ''GADTSyntax 22 | 23 | data ADTSyntax1 m a = a ~ Int => ADTSyntax1C String 24 | 25 | makeEffect ''ADTSyntax1 26 | 27 | data ADTSyntax2 m a 28 | = a ~ Int => ADTSyntax2C1 Int 29 | | a ~ String => ADTSyntax2C2 String 30 | 31 | makeEffect ''ADTSyntax2 32 | 33 | data ADTSyntax3 m a = Show a => ADTSyntax3C a 34 | 35 | makeEffect ''ADTSyntax3 36 | 37 | data Fields m a = FieldsC { fieldsCF1 :: Int, fieldsCF2 :: String } 38 | 39 | makeEffect ''Fields 40 | 41 | newtype Newtype1 m a = Newtype1C Int 42 | 43 | makeEffect ''Newtype1 44 | 45 | newtype Newtype2 m a where 46 | Newtype2C :: String -> Newtype2 m a 47 | 48 | makeEffect ''Newtype2 49 | 50 | data Instance = ADTI | GADTI | NTI | MMI 51 | 52 | data family Family (s :: Instance) (m :: Type -> Type) a 53 | 54 | data instance Family 'ADTI _ _ = ADTIC1 Int | ADTIC2 String 55 | 56 | makeEffect 'ADTIC1 57 | 58 | data instance Family 'GADTI _ _ where 59 | GADTIC1 :: Int -> Family 'GADTI m Int 60 | GADTIC2 :: String -> Family 'GADTI m String 61 | 62 | makeEffect 'GADTIC1 63 | 64 | newtype instance Family 'NTI _ _ = NTIC Int 65 | 66 | makeEffect 'NTIC 67 | 68 | data instance Family 'MMI m (_ m) where 69 | MMIC1 :: f m -> Family 'MMI m (f m) 70 | MMIC2 :: (∀ x. m x -> m (f m)) -> Family 'MMI m (f m) 71 | 72 | -- Generates correctly since 0.3.1.0 73 | makeEffect 'MMIC1 74 | 75 | data Complex m a where 76 | Mono :: Int -> Complex m Bool 77 | Poly :: a -> Complex m a 78 | PolyIn :: a -> Complex m Bool 79 | PolyOut :: Int -> Complex m a 80 | Lots :: a -> b -> c -> d -> e -> f -> Complex m () 81 | Nested :: Maybe b -> Complex m (Maybe a) 82 | MultiNested :: (Maybe a, [b]) -> Complex m (Maybe a, [b]) 83 | Existential :: (∀ e. e -> Maybe e) -> Complex m a 84 | LotsNested :: Maybe a -> [b] -> (c, c) -> Complex m (a, b, c) 85 | Dict :: Ord a => a -> Complex m a 86 | MultiDict :: (Eq a, Ord b, Enum a, Num c) 87 | => a -> b -> c -> Complex m () 88 | IndexedMono :: f 0 -> Complex m Int 89 | IndexedPoly :: ∀ f (n :: Nat) m . f n -> Complex m (f (n + 1)) 90 | IndexedPolyDict :: KnownNat n => f n -> Complex m Int 91 | 92 | makeEffect ''Complex 93 | 94 | data HOEff m a where 95 | EffArgMono :: m () -> HOEff m () 96 | EffArgPoly :: m a -> HOEff m a 97 | EffArgComb :: m a -> (m a -> m b) -> HOEff m b 98 | EffRank2 :: (∀ x. m x -> m (Maybe x)) -> HOEff m a 99 | 100 | makeEffect ''HOEff 101 | 102 | data ComplexEffArgs b c m a where 103 | EffMono :: Int -> ComplexEffArgs Int String m Bool 104 | EffPoly1 :: a -> ComplexEffArgs a b m a 105 | EffPoly2 :: a -> ComplexEffArgs a (Maybe a) m Bool 106 | EffPolyFree :: String -> ComplexEffArgs a b m Int 107 | EffSame1 :: ComplexEffArgs a a m a 108 | EffSame2 :: ComplexEffArgs b b m a 109 | EffHO :: m b -> ComplexEffArgs b Int m String 110 | 111 | -- TODO(daylily): This cannot produce desired result. This is almost certainly caused by us not annotating types 112 | -- explicitly, but that's too much effort. 113 | -- makeEffect ''ComplexEffArgs 114 | 115 | data HKEffArgs f g m a where 116 | HKRank2 :: (∀ x . f x -> g x) -> HKEffArgs f g m a 117 | 118 | makeEffect ''HKEffArgs 119 | 120 | data ByCon m a where 121 | ByConC :: Int -> ByCon m String 122 | 123 | makeEffect 'ByConC 124 | 125 | data ByField m a where 126 | ByFieldC :: { byFieldCF :: Int } -> ByField m Int 127 | 128 | makeEffect 'byFieldCF 129 | 130 | data PartialMonad m a where 131 | ImpartialMonad :: Int -> PartialMonad m () 132 | PartialMonad :: IOE :> es => Int -> Eff es () -> PartialMonad (Eff es) () 133 | 134 | makeEffect ''PartialMonad 135 | -------------------------------------------------------------------------------- /src/Cleff/Writer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | -- | 3 | -- Copyright: (c) 2021 Xy Ren 4 | -- License: BSD3 5 | -- Maintainer: xy.r@outlook.com 6 | -- Stability: experimental 7 | -- Portability: non-portable (GHC only) 8 | module Cleff.Writer 9 | ( -- * Effect 10 | Writer (..) 11 | -- * Operations 12 | , tell 13 | , listen 14 | , listens 15 | -- * Interpretations 16 | , runWriter 17 | , runWriterBatch 18 | ) where 19 | 20 | import Cleff 21 | import Cleff.Internal.Base 22 | import Data.Atomics (atomicModifyIORefCAS_) 23 | import Data.Foldable (traverse_) 24 | import Data.IORef (IORef, newIORef, readIORef) 25 | 26 | -- * Effect 27 | 28 | -- | An effect capable of accumulating monoidal outputs. This roughly corresponds to the @MonadWriter@ typeclass and 29 | -- @WriterT@ monad transformer in the @mtl@ library. 30 | -- 31 | -- However, note that this does not have a @pass@ operation as we are not sure what its semantics should be. In fact, 32 | -- the @pass@ semantics in @mtl@ is also unclear and will change when handlers are put in different orders. To avoid 33 | -- any confusion we decided it is best that we don't include it because no one seems to be relying on it anyway. 34 | data Writer w :: Effect where 35 | Tell :: w -> Writer w m () 36 | Listen :: m a -> Writer w m (a, w) 37 | 38 | -- * Operations 39 | 40 | makeEffect_ ''Writer 41 | 42 | -- | Produces an output that is appended to the accumulated value. 43 | tell :: Writer w :> es => w -> Eff es () 44 | 45 | -- | Monitor the output of a computation, and return the output alongside the computation's result. 46 | listen :: Writer w :> es => Eff es a -> Eff es (a, w) 47 | 48 | -- | Apply a function to the accumulated output of 'listen'. 49 | listens :: Writer w :> es => (w -> x) -> Eff es a -> Eff es (a, x) 50 | listens f m = do 51 | (a, w) <- listen m 52 | pure (a, f w) 53 | 54 | -- * Interpretations 55 | 56 | -- | Run a monoidal 'Writer' effect. 57 | -- 58 | -- === Caveats 59 | -- 60 | -- Both 'runWriter' and 'listen's under 'runWriter' will stop taking care of writer operations done on 61 | -- forked threads as soon as the main thread finishes its computation. Any writer operation done 62 | -- /before main thread finishes/ is still taken into account. 63 | runWriter :: ∀ w es a. Monoid w => Eff (Writer w : es) a -> Eff es (a, w) 64 | runWriter m = thisIsPureTrustMe do 65 | rw <- liftIO $ newIORef mempty 66 | x <- reinterpret (handle [rw]) m 67 | w' <- liftIO $ readIORef rw 68 | pure (x, w') 69 | where 70 | handle :: [IORef w] -> Handler (Writer w) (IOE : es) 71 | handle rws = \case 72 | Tell w' -> traverse_ (\rw -> liftIO $ atomicModifyIORefCAS_ rw (<> w')) rws 73 | Listen m' -> do 74 | rw' <- liftIO $ newIORef mempty 75 | x <- toEffWith (handle $ rw' : rws) m' 76 | w' <- liftIO $ readIORef rw' 77 | pure (x, w') 78 | 79 | -- | Run a monoidal 'Writer' effect, but appends the listened output to the parent value only when the listen operation 80 | -- finishes. This means that when you run two 'listen's on two threads, the values 'tell'ed inside will not be appended 81 | -- to the parent value in real time, but only after the thread finishes 'listen'ing. For example, this code 82 | -- 83 | -- @ 84 | -- 'UnliftIO.concurrently_' 85 | -- ('listen' '$' 'tell' "1" '>>' 'tell' "2" '>>' 'tell' "3") 86 | -- ('listen' '$' 'tell' "4" '>>' 'tell' "5" '>>' 'tell' "6") 87 | -- @ 88 | -- 89 | -- will produce either @"123456"@ or @"456123"@ with 'runWriterBatch', but may produce these digits in any order with 90 | -- 'runWriter'. 91 | -- 92 | -- This version of interpreter can be faster than 'runWriter' in 'listen'-intense code. It is subject to all caveats 93 | -- of 'runWriter'. 94 | -- 95 | -- @since 0.2.0.0 96 | runWriterBatch :: ∀ w es a. Monoid w => Eff (Writer w : es) a -> Eff es (a, w) 97 | runWriterBatch m = thisIsPureTrustMe do 98 | rw <- liftIO $ newIORef mempty 99 | x <- reinterpret (handle rw) m 100 | w' <- liftIO $ readIORef rw 101 | pure (x, w') 102 | where 103 | handle :: IORef w -> Handler (Writer w) (IOE : es) 104 | handle rw = \case 105 | Tell w' -> liftIO $ atomicModifyIORefCAS_ rw (<> w') 106 | Listen m' -> do 107 | rw' <- liftIO $ newIORef mempty 108 | x <- toEffWith (handle rw') m' 109 | w' <- liftIO $ readIORef rw' 110 | liftIO $ atomicModifyIORefCAS_ rw (<> w') 111 | pure (x, w') 112 | -------------------------------------------------------------------------------- /src/Data/RadixVec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | -- | 3 | -- Copyright: (c) 2021 Xy Ren 4 | -- License: BSD3 5 | -- Maintainer: xy.r@outlook.com 6 | -- Stability: unstable 7 | -- Portability: non-portable (GHC only) 8 | module Data.RadixVec (RadixVec, size, empty, lookup, update, snoc) where 9 | 10 | import Control.Monad.ST (ST) 11 | import Data.Bits (Bits (unsafeShiftL, unsafeShiftR, (.&.)), FiniteBits (countTrailingZeros)) 12 | import Data.Primitive.MachDeps (sIZEOF_INT) 13 | import Data.Primitive.SmallArray (SmallArray, SmallMutableArray, copySmallArray, indexSmallArray, 14 | newSmallArray, readSmallArray, runSmallArray, sizeofSmallArray, 15 | thawSmallArray, writeSmallArray) 16 | import Prelude hiding (lookup) 17 | 18 | -- | An efficient vector type, implemented as a radix tree. It has the following time complexities: 19 | -- 20 | -- * Lookup: \( O(\log n) \) 21 | -- * Update: \( O(\log n) \) 22 | -- * Append: \( O(\log n) \) 23 | -- 24 | -- The branching factor (base of log) is 32 therefore the time is close to constant in most cases. Note that in 25 | -- practice, lookup is faster than update, and update is faster than append. 26 | data RadixVec a = RadixVec !Int !(Tree a) 27 | 28 | type Shift = Int 29 | 30 | -- | The \( \log_2 \) of the branching factor. The branching factor is set to be 32 for now but may change in the 31 | -- future. 32 | factor :: Int 33 | factor = 5 34 | 35 | -- | A mask covering one chunk of an index. 36 | initialMask :: Int 37 | initialMask = (1 `unsafeShiftL` factor) - 1 38 | 39 | -- | A radix tree. The tree is always left-leaning. 40 | data Tree a 41 | = Tip 42 | {-# UNPACK #-} !(SmallArray a) 43 | | Node 44 | {-# UNPACK #-} !Shift 45 | {-# UNPACK #-} !(SmallArray (Tree a)) 46 | 47 | -- | Mask a portion of an index. 48 | mask :: Shift -> Int -> Int 49 | mask s x = initialMask .&. (x `unsafeShiftR` s) 50 | 51 | -- | Mask the zeroth portion of the index. 52 | mask0 :: Int -> Int 53 | mask0 x = initialMask .&. x 54 | 55 | -- | Alter an element in a 'SmallMutableArray' by a function. 56 | alterSmallArray :: SmallMutableArray s a -> Int -> (a -> a) -> ST s () 57 | alterSmallArray marr ix f = do 58 | x <- readSmallArray marr ix 59 | writeSmallArray marr ix $! f x 60 | 61 | -- | Get the size of the 'RadixVec'. 62 | size :: RadixVec a -> Int 63 | size (RadixVec sz _) = sz 64 | 65 | -- | The empty 'RadixVec'. 66 | empty :: RadixVec a 67 | empty = RadixVec 0 $ Tip $ runSmallArray $ newSmallArray 0 $ error 68 | "Cleff.Internal.RadixVec: Encountered an element in an empty RadixVec. Please report this as a bug." 69 | 70 | -- | Lookup in a 'RadixVec' by an index. This does not perform any bounds check. 71 | lookup :: Int -> RadixVec a -> a 72 | lookup ix (RadixVec _ tree) = go tree 73 | where 74 | go (Tip arr) = indexSmallArray arr (initialMask .&. ix) 75 | go (Node s arr) = go (indexSmallArray arr (mask s ix)) 76 | 77 | -- | Update a value in a 'RadixVec' by an index. The value will be forced before installing. This does not perform any 78 | -- bounds check. 79 | update :: Int -> a -> RadixVec a -> RadixVec a 80 | update ix x (RadixVec len tree) = RadixVec len (go tree) 81 | where 82 | go (Tip arr) = Tip $ runSmallArray do 83 | marr <- thawSmallArray arr 0 (sizeofSmallArray arr) 84 | writeSmallArray marr (mask0 ix) $! x 85 | pure marr 86 | go (Node s arr) = Node s $ runSmallArray do 87 | marr <- thawSmallArray arr 0 (sizeofSmallArray arr) 88 | alterSmallArray marr (mask s ix) go 89 | pure marr 90 | 91 | -- | Append a value to a 'RadixVec'. The value will be forced before installing. This does not perform any bounds check. 92 | snoc :: RadixVec a -> a -> RadixVec a 93 | snoc (RadixVec len tree) x 94 | | ins <= topShift = RadixVec (len + 1) (go tree) 95 | | otherwise = RadixVec (len + 1) $ Node (topShift + factor) $ runSmallArray $ do 96 | marr <- newSmallArray 2 $! tree 97 | writeSmallArray marr 1 $! branch topShift 98 | pure marr 99 | where 100 | topShift = case tree of 101 | Tip _ -> 0 102 | Node s _ -> s 103 | ins = (countTrailingZeros len `mod` sIZEOF_INT `div` factor) * factor 104 | branch 0 = Tip $ runSmallArray $ newSmallArray 1 $! x 105 | branch s = Node s $ runSmallArray $ newSmallArray 1 $! branch (s - factor) 106 | enlarge arr new = runSmallArray do 107 | let sz = sizeofSmallArray arr 108 | marr <- newSmallArray (sz + 1) $! new 109 | copySmallArray marr 0 arr 0 sz 110 | pure marr 111 | go (Tip arr) = Tip $ enlarge arr x 112 | go (Node s arr) 113 | | ins == s = Node s $ enlarge arr $ branch (s - factor) 114 | | otherwise = Node s $ runSmallArray do 115 | marr <- thawSmallArray arr 0 (sizeofSmallArray arr) 116 | alterSmallArray marr (mask s len) go 117 | pure marr 118 | -------------------------------------------------------------------------------- /test/MaskSpec.hs: -------------------------------------------------------------------------------- 1 | -- | This module is adapted from https://github.com/polysemy-research/polysemy/blob/master/test/ResourceSpec.hs, 2 | -- originally BSD3 license, authors Sandy Maguire et al. 3 | {-# OPTIONS_GHC -Wno-orphans #-} 4 | module MaskSpec where 5 | 6 | import Cleff 7 | import Cleff.Error 8 | import Cleff.Mask 9 | import Cleff.Output 10 | import Cleff.State 11 | import Cleff.Trace 12 | import Cleff.Writer 13 | import Control.Exception (Exception) 14 | import Control.Monad (void) 15 | import Data.Tuple.Extra (second) 16 | import Test.Hspec 17 | 18 | spec :: Spec 19 | spec = parallel $ do 20 | testBoth "persist state and call the finalizer" 21 | (\((e, s), ts) -> do 22 | s `shouldBe` "finalized" 23 | e `shouldBe` Left () 24 | ts `shouldBe` ["allocated", "starting block"] 25 | ) $ do 26 | bracket 27 | (put "allocated" >> pure ()) 28 | (\() -> do 29 | get >>= trace 30 | put "finalized" 31 | ) 32 | (\() -> do 33 | get >>= trace 34 | put "starting block" 35 | _ <- throwError () 36 | put "don't get here" 37 | ) 38 | 39 | testBoth "persist state and call the finalizer with bracketOnError" 40 | (\((e, s), ts) -> do 41 | ts `shouldContain` ["allocated"] 42 | ts `shouldContain` ["starting block"] 43 | s `shouldBe` "finalized" 44 | e `shouldBe` Left () 45 | ) $ do 46 | bracketOnError 47 | (put "allocated" >> pure ()) 48 | (\() -> do 49 | get >>= trace 50 | put "finalized" 51 | ) 52 | (\() -> do 53 | get >>= trace 54 | put "starting block" 55 | _ <- throwError () 56 | put "don't get here" 57 | ) 58 | 59 | testBoth "should not call the finalizer if there no error" 60 | (\((e, s), ts) -> do 61 | ts `shouldContain` ["allocated"] 62 | ts `shouldNotContain` ["starting block"] 63 | s `shouldBe` "don't get here" 64 | e `shouldBe` Right () 65 | ) $ do 66 | bracketOnError 67 | (put "allocated" >> pure ()) 68 | (\() -> do 69 | get >>= trace 70 | put "finalized" 71 | ) 72 | (\() -> do 73 | get >>= trace 74 | put "starting block" 75 | put "don't get here" 76 | ) 77 | 78 | testBoth "should call the finalizer on Error" 79 | (\((e, s), ts) -> do 80 | ts `shouldContain` ["beginning transaction"] 81 | ts `shouldContain` ["rolling back transaction"] 82 | s `shouldBe` "" 83 | e `shouldBe` Left () 84 | ) $ do 85 | withTransaction $ do 86 | void $ throwError () 87 | pure "hello" 88 | 89 | testBoth "io dispatched bracket" 90 | (\((e, s), ts) -> do 91 | ts `shouldContain` ["allocated"] 92 | ts `shouldContain` ["starting block"] 93 | s `shouldBe` "finalized" 94 | e `shouldBe` Left () 95 | ) $ do 96 | bracket 97 | (put "allocated" >> pure ()) 98 | (\() -> do 99 | get >>= trace 100 | put "finalized" 101 | ) 102 | (\() -> do 103 | get >>= trace 104 | put "starting block" 105 | _ <- throwError () 106 | put "don't get here" 107 | ) 108 | 109 | testBoth "should not lock when done recursively" 110 | (\((e, s), ts) -> do 111 | ts `shouldContain` [ "hello 1" 112 | , "hello 2" 113 | , "RUNNING" 114 | , "goodbye 2" 115 | ] 116 | s `shouldBe` "finished" 117 | e `shouldBe` Left () 118 | ) $ do 119 | bracket 120 | (put "hello 1") 121 | (\() -> do 122 | get >>= trace 123 | put "finished" 124 | ) 125 | (\() -> do 126 | get >>= trace 127 | void $ 128 | bracket (put "hello 2") 129 | (const $ do 130 | get >>= trace 131 | put "goodbye 2" 132 | ) 133 | (const $ do 134 | get >>= trace 135 | put "RUNNING" 136 | throwError () 137 | ) 138 | -- This doesn't run due to the thrown error above 139 | get >>= trace 140 | put "goodbye 1" 141 | ) 142 | 143 | instance Exception () 144 | 145 | runTest 146 | :: Eff '[Error (), Mask, State [Char], Trace, Output String] a 147 | -> IO ((Either () a, [Char]), [String]) 148 | runTest = pure 149 | . runPure 150 | . fmap (second reverse) . runState [] 151 | . outputToListState 152 | . subsume @(Output String) 153 | . traceToOutput 154 | . runState "" 155 | . runMask 156 | . runError @() 157 | 158 | runTest2 159 | :: Eff '[Error (), Mask, State [Char], Trace, Output String] a 160 | -> IO ((Either () a, [Char]), [String]) 161 | runTest2 = pure 162 | . runPure 163 | . runWriter 164 | . outputToWriter (:[]) 165 | . subsume @(Output String) 166 | . traceToOutput 167 | . runState "" 168 | . runMask 169 | . runError @() 170 | 171 | testBoth 172 | :: String 173 | -> (((Either () a, [Char]), [String]) -> Expectation) 174 | -> Eff '[Error (), Mask, State [Char], Trace, Output String] a 175 | -> Spec 176 | testBoth name k m = do 177 | describe name $ do 178 | it "via outputToListState" $ do 179 | z <- runTest m 180 | k z 181 | it "via outputToWriter" $ do 182 | z <- runTest2 m 183 | k z 184 | 185 | withTransaction :: '[Mask, Trace] :>> r => Eff r a -> Eff r a 186 | withTransaction m = 187 | bracketOnError 188 | (trace "beginning transaction") 189 | (const $ trace "rolling back transaction") 190 | (const $ m <* trace "committing transaction") 191 | -------------------------------------------------------------------------------- /src/Cleff/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | -- | 3 | -- Copyright: (c) 2021 Xy Ren 4 | -- License: BSD3 5 | -- Maintainer: xy.r@outlook.com 6 | -- Stability: experimental 7 | -- Portability: non-portable (GHC only) 8 | module Cleff.State 9 | ( -- * Effect 10 | State (..) 11 | -- * Operations 12 | , get 13 | , put 14 | , state 15 | , gets 16 | , modify 17 | -- * Interpretations 18 | , runState 19 | , runStateLocal 20 | , runStateIORef 21 | , runStateMVar 22 | , runStateTVar 23 | , zoom 24 | ) where 25 | 26 | import Cleff 27 | import Cleff.Internal.Base 28 | import Control.Concurrent.MVar (MVar, modifyMVar, readMVar, swapMVar) 29 | import Control.Concurrent.STM (TVar, atomically, readTVar, readTVarIO, writeTVar) 30 | import Control.Monad (void) 31 | import Data.Atomics (atomicModifyIORefCAS) 32 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 33 | import Data.ThreadVar (getThreadVar, newThreadVar) 34 | import Data.Tuple (swap) 35 | import Lens.Micro (Lens', (&), (.~), (^.)) 36 | 37 | -- * Effect 38 | 39 | -- | An effect capable of providing a mutable state @s@ that can be read and written. This roughly corresponds to the 40 | -- @MonadState@ typeclass and @StateT@ monad transformer in the @mtl@ library. 41 | data State s :: Effect where 42 | Get :: State s m s 43 | Put :: s -> State s m () 44 | State :: (s -> (a, s)) -> State s m a 45 | 46 | -- * Operations 47 | 48 | makeEffect_ ''State 49 | 50 | -- | Read the current state. 51 | get :: State s :> es => Eff es s 52 | 53 | -- | Update the state with a new value. 54 | put :: State s :> es => s -> Eff es () 55 | 56 | -- | Modify the state /and/ produce a value from the state via a function. 57 | state :: State s :> es 58 | => (s -> (a, s)) -- ^ The function that takes the state and returns a result value together with a modified state 59 | -> Eff es a 60 | 61 | -- | Apply a function to the result of 'get'. 62 | gets :: State s :> es => (s -> t) -> Eff es t 63 | gets = (<$> get) 64 | 65 | -- | Modify the value of the state via a function. 66 | modify :: State s :> es => (s -> s) -> Eff es () 67 | modify f = state (((), ) . f) 68 | 69 | -- * Interpretations 70 | 71 | handleIORef :: IOE :> es => IORef s -> Handler (State s) es 72 | handleIORef rs = \case 73 | Get -> liftIO $ readIORef rs 74 | Put s' -> liftIO $ writeIORef rs s' 75 | State f -> liftIO $ atomicModifyIORefCAS rs (swap . f) 76 | 77 | -- | Run the 'State' effect. 78 | -- 79 | -- === Caveats 80 | -- 81 | -- The 'runState' interpreter is implemented with 'Data.IORef.IORef's and there is no way to do arbitrary 82 | -- atomic transactions. The 'state' operation is atomic though and it is implemented with 'atomicModifyIORefCAS', which 83 | -- can be faster than @atomicModifyIORef@ in contention. For any more complicated cases of atomicity, please build your 84 | -- own effect that uses either @MVar@s or @TVar@s based on your need. 85 | -- 86 | -- Unlike @mtl@, in @cleff@ the state /will not revert/ when an error is thrown. 87 | -- 88 | -- 'runState' will stop taking care of state operations done on forked threads as soon as the main thread finishes its 89 | -- computation. Any state operation done /before main thread finishes/ is still taken into account. 90 | runState :: s -> Eff (State s : es) a -> Eff es (a, s) 91 | runState s m = thisIsPureTrustMe do 92 | rs <- liftIO $ newIORef s 93 | x <- reinterpret (handleIORef rs) m 94 | s' <- liftIO $ readIORef rs 95 | pure (x, s') 96 | 97 | -- | Run a 'State' effect where each thread has its thread-local state. 98 | -- 99 | -- This means that each thread will have an individual state that has the same initial value. Threfore, state 100 | -- operations on one thread will not change the state for any other thread. 101 | -- 102 | -- The returned final state is that of the current thread. 103 | -- 104 | -- === Caveats 105 | -- 106 | -- Like 'runState', the 'state' operation in this handler is atomic. Like 'runState', and unlike @mtl@, any errors will 107 | -- not revert the state changes. 108 | -- 109 | -- Be warned that if you use a thread pool, then when a thread is reused, it may read the state left from the last 110 | -- usage, therefore losing locality. If you use a thread pool, you will want to manually reset the state after each 111 | -- task. 112 | -- 113 | -- @since 0.3.3.0 114 | runStateLocal :: s -> Eff (State s : es) a -> Eff es (a, s) 115 | runStateLocal s m = thisIsPureTrustMe do 116 | rs <- liftIO $ newThreadVar s 117 | x <- reinterpret (\e -> liftIO (getThreadVar rs) >>= \r -> handleIORef r e) m 118 | s' <- liftIO $ readIORef =<< getThreadVar rs 119 | pure (x, s') 120 | 121 | -- | Run the 'State' effect in terms of operations on a supplied 'IORef'. The 'state' operation is atomic. 122 | -- 123 | -- @since 0.2.1.0 124 | runStateIORef :: IOE :> es => IORef s -> Eff (State s : es) a -> Eff es a 125 | runStateIORef rs = interpret $ handleIORef rs 126 | 127 | -- | Run the 'State' effect in terms of operations on a supplied 'MVar'. 128 | -- 129 | -- @since 0.2.1.0 130 | runStateMVar :: IOE :> es => MVar s -> Eff (State s : es) a -> Eff es a 131 | runStateMVar rs = interpret \case 132 | Get -> liftIO $ readMVar rs 133 | Put s' -> liftIO $ void $ swapMVar rs s' 134 | State f -> liftIO $ modifyMVar rs \s -> let (x, !s') = f s in pure (s', x) 135 | 136 | -- | Run the 'State' effect in terms of operations on a supplied 'TVar'. 137 | -- 138 | -- @since 0.2.1.0 139 | runStateTVar :: IOE :> es => TVar s -> Eff (State s : es) a -> Eff es a 140 | runStateTVar rs = interpret \case 141 | Get -> liftIO $ readTVarIO rs 142 | Put s' -> liftIO $ atomically $ writeTVar rs s' 143 | State f -> liftIO $ atomically do 144 | s <- readTVar rs 145 | let (x, !s') = f s 146 | writeTVar rs s' 147 | pure x 148 | 149 | -- | Run a 'State' effect in terms of a larger 'State' via a 'Lens''. 150 | zoom :: State t :> es => Lens' t s -> Eff (State s : es) ~> Eff es 151 | zoom field = interpret \case 152 | Get -> gets (^. field) 153 | Put s -> modify (& field .~ s) 154 | State f -> state \t -> let (a, !s) = f (t ^. field) in (a, t & field .~ s) 155 | -------------------------------------------------------------------------------- /src/Cleff/Internal/Env.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# OPTIONS_HADDOCK not-home #-} 3 | -- | 4 | -- Copyright: (c) 2021 Xy Ren 5 | -- License: BSD3 6 | -- Maintainer: xy.r@outlook.com 7 | -- Stability: unstable 8 | -- Portability: non-portable (GHC only) 9 | -- 10 | -- Operations on the effect environment type 'Env'. These operations are more flexible than the public API; you may 11 | -- want to use these in conjunction with the effect stack manipulation operations in "Cleff.Internal.Stack". 12 | -- 13 | -- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be 14 | -- extra careful if you're to depend on this module. 15 | module Cleff.Internal.Env 16 | ( Env 17 | , Handling 18 | , Handler 19 | , esSend 20 | , empty 21 | , read 22 | , adjust 23 | , overwriteLocal 24 | , overwriteGlobal 25 | , overwriteSelfGlobal 26 | , extend 27 | , update 28 | ) where 29 | 30 | import Cleff.Internal.Monad 31 | import Cleff.Internal.Stack (Stack) 32 | import qualified Cleff.Internal.Stack as Stack 33 | import Data.Any (fromAny, pattern Any) 34 | import qualified Data.RadixVec as Vec 35 | import Prelude hiding (read) 36 | import Unsafe.Coerce (unsafeCoerce) 37 | 38 | -- | The internal representation of effect handlers. This is just a natural transformation from the effect type 39 | -- @e ('Eff' es)@ to the effect monad @'Eff' es@ for any effect stack @es@. 40 | -- 41 | -- In interpreting functions (see "Cleff.Internal.Interpret"), the user-facing 'Cleff.Handler' type is transformed into 42 | -- this type. 43 | newtype InternalHandler e = InternalHandler (∀ es. e (Eff es) ~> Eff es) 44 | 45 | -- | The send-site environment. 46 | data SendSite esSend e = SendSite 47 | {-# UNPACK #-} !(Env esSend) -- ^ The send-site 'Env'. 48 | {-# UNPACK #-} !(HandlerPtr e) -- ^ The pointer to the current effect handler. 49 | 50 | -- | The typeclass that denotes a handler scope, handling effect @e@ sent from the effect stack @esSend@ in the 51 | -- effect stack @es@. 52 | -- 53 | -- You should not define instances for this typeclass whatsoever. 54 | class Handling esSend e es | esSend -> e es where 55 | -- @esSend@ is existential so it uniquely determines the other two variables. As handling scopes can nest, the other 56 | -- two variables cannot determine anything. 57 | 58 | -- | Obtain the send-site environment. 59 | sendSite :: SendSite esSend e 60 | sendSite = error 61 | "Cleff.Internal.Env.sendSite: Attempting to access the send site without a reflected value. This is perhaps \ 62 | \because you are trying to define an instance for the 'Handling' typeclass, which you should not be doing \ 63 | \whatsoever. If that or other shenanigans seem unlikely, please report this as a bug." 64 | 65 | -- | Get the pointer to the current effect handler itself. 66 | hdlPtr :: ∀ esSend e es. Handling esSend e es => HandlerPtr e 67 | hdlPtr = let SendSite _ ptr = sendSite @esSend in ptr 68 | 69 | -- | Get the send-site 'Env'. 70 | esSend :: Handling esSend e es => Env esSend 71 | esSend = let SendSite env _ = sendSite in env 72 | 73 | -- | Newtype wrapper for instantiating the 'Handling' typeclass locally, a la the reflection trick. We do not use 74 | -- the @reflection@ library directly so as not to expose this piece of implementation detail to the user. 75 | newtype InstHandling esSend e es a = InstHandling (Handling esSend e es => a) 76 | 77 | -- | Instantiate an 'Handling' typeclass, /i.e./ pass an implicit send-site environment in. This function shouldn't 78 | -- be directly used anyhow. 79 | instHandling :: ∀ esSend e es a. (Handling esSend e es => a) -> SendSite esSend e -> a 80 | instHandling x = unsafeCoerce (InstHandling x :: InstHandling esSend e es a) 81 | 82 | -- | The type of an /effect handler/, which is a function that transforms an effect @e@ from an arbitrary effect stack 83 | -- into computations in the effect stack @es@. 84 | type Handler e es = ∀ esSend. Handling esSend e es => e (Eff esSend) ~> Eff es 85 | 86 | -- | Transform a 'Handler' into an 'InternalHandler' given a pointer that is going to point to the 'InternalHandler' 87 | -- and the current 'Env'. 88 | mkInternalHandler :: HandlerPtr e -> Env es -> Handler e es -> InternalHandler e 89 | mkInternalHandler ptr es handle = InternalHandler \e -> Eff \ess -> 90 | unEff (instHandling handle (SendSite ess ptr) e) (update ess es) 91 | 92 | -- | Create an empty 'Env' with no address allocated. 93 | empty :: Env '[] 94 | empty = Env Stack.empty Vec.empty 95 | 96 | -- | Read the handler a pointer points to. \( O(1) \). 97 | read :: ∀ e es. e :> es => Env es -> ∀ es'. e (Eff es') ~> Eff es' 98 | read (Env stack heap) = fromAny $ Vec.lookup (unHandlerPtr (Stack.index @e stack)) heap 99 | 100 | -- | Adjust the effect stack via an function over 'Stack'. 101 | adjust :: ∀ es' es. (Stack es -> Stack es') -> Env es -> Env es' 102 | adjust f = \(Env stack heap) -> Env (f stack) heap 103 | 104 | -- | Replace the handler a pointer points to. \( O(1) \). 105 | overwriteGlobal :: ∀ e es es'. e :> es => Env es' -> Handler e es' -> Env es -> Env es 106 | overwriteGlobal es hdl (Env stack heap) = Env stack $ 107 | Vec.update m (Any $ mkInternalHandler ptr es hdl) heap 108 | where ptr@(HandlerPtr m) = Stack.index @e stack 109 | 110 | -- | Replace the handler a pointer points to. \( O(1) \). 111 | overwriteSelfGlobal :: ∀ e es es' esSend. Handling esSend e es => Env es' -> Handler e es' -> Env esSend -> Env esSend 112 | overwriteSelfGlobal es hdl (Env stack heap) = Env stack $ 113 | Vec.update ix (Any $ mkInternalHandler ptr es hdl) heap 114 | where ptr@(HandlerPtr ix) = hdlPtr @esSend 115 | 116 | -- | Replace the handler pointer of an effect in the stack. \( O(n) \). 117 | overwriteLocal :: ∀ e es es'. e :> es => Env es' -> Handler e es' -> Env es -> Env es 118 | overwriteLocal es hdl (Env stack heap) = Env 119 | (Stack.update @e ptr stack) 120 | (Vec.snoc heap $ Any $ mkInternalHandler ptr es hdl) 121 | where ptr = HandlerPtr (Vec.size heap) 122 | 123 | -- | Add a new effect to the stack with its corresponding handler pointer. \( O(n) \). 124 | extend :: ∀ e es es'. Env es' -> Handler e es' -> Env es -> Env (e : es) 125 | extend es hdl (Env stack heap) = Env 126 | (Stack.cons ptr stack) 127 | (Vec.snoc heap $ Any $ mkInternalHandler ptr es hdl) 128 | where ptr = HandlerPtr (Vec.size heap) 129 | 130 | -- | Use the state of LHS as a newer version for RHS. \( O(1) \). 131 | update :: ∀ es es'. Env es' -> Env es -> Env es 132 | update (Env _ heap) (Env stack _) = Env stack heap 133 | -------------------------------------------------------------------------------- /src/Cleff/Internal/Stack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE UnboxedTuples #-} 3 | {-# OPTIONS_HADDOCK not-home #-} 4 | -- | 5 | -- Copyright: (c) 2021 Xy Ren 6 | -- License: BSD3 7 | -- Maintainer: xy.r@outlook.com 8 | -- Stability: unstable 9 | -- Portability: non-portable (GHC only) 10 | -- 11 | -- This module defines the effect stack as an immutable extensible stack type, and provides functions for manipulating 12 | -- it. The effect stack type has the following time complexities: 13 | -- 14 | -- * Lookup: Amortized \( O(1) \). 15 | -- * Update: \( O(n) \). 16 | -- * Shrink: \( O(1) \). 17 | -- * Append: \( O(n) \). 18 | -- 19 | -- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be 20 | -- extra careful if you're to depend on this module. 21 | module Cleff.Internal.Stack 22 | ( Effect 23 | , Stack 24 | , HandlerPtr (HandlerPtr, unHandlerPtr) 25 | -- * Construction 26 | , type (++) 27 | , empty 28 | , cons 29 | , concat 30 | -- * Deconstruction 31 | , KnownList 32 | , head 33 | , take 34 | , tail 35 | , drop 36 | -- * Retrieval and updating 37 | , (:>) 38 | , (:>>) 39 | , Subset 40 | , index 41 | , pick 42 | , update 43 | ) where 44 | 45 | import Data.Coerce (coerce) 46 | import Data.Kind (Constraint, Type) 47 | import Data.PrimVec (PrimVec) 48 | import qualified Data.PrimVec as Vec 49 | import GHC.TypeLits (ErrorMessage (ShowType, Text, (:<>:)), TypeError) 50 | import Prelude hiding (concat, drop, head, tail, take) 51 | 52 | -- | The type of effects. An effect @e m a@ takes an effect monad type @m :: 'Type' -> 'Type'@ and a result type 53 | -- @a :: 'Type'@. 54 | type Effect = (Type -> Type) -> Type -> Type 55 | 56 | -- | The effect stack, storing pointers to handlers. It is essentially an extensible stack type supporting 57 | -- efficient \( O(1) \) reads. 58 | type role Stack nominal 59 | newtype Stack (es :: [Effect]) = Stack (PrimVec Int) 60 | 61 | -- | A pointer to an effect handler. 62 | type role HandlerPtr nominal 63 | newtype HandlerPtr (e :: Effect) = HandlerPtr { unHandlerPtr :: Int } 64 | 65 | unreifiable :: String -> String -> String -> a 66 | unreifiable clsName funName comp = error $ 67 | funName <> ": Attempting to access " <> comp <> " without a reflected value. This is perhaps because you are trying \ 68 | \to define an instance for the '" <> clsName <> "' typeclass, which you should not be doing whatsoever. If that or \ 69 | \other shenanigans seem unlikely, please report this as a bug." 70 | 71 | -- | Create an empty stack. \( O(1) \). 72 | empty :: Stack '[] 73 | empty = coerce (Vec.empty @Int) 74 | 75 | -- | Prepend one entry to the stack. \( O(n) \). 76 | cons :: HandlerPtr e -> Stack es -> Stack (e : es) 77 | cons = coerce (Vec.cons @Int) 78 | 79 | -- | Type level list concatenation. 80 | type family xs ++ ys where 81 | '[] ++ ys = ys 82 | (x : xs) ++ ys = x : (xs ++ ys) 83 | infixr 5 ++ 84 | 85 | -- | Concatenate two stacks. \( O(m+n) \). 86 | concat :: Stack es -> Stack es' -> Stack (es ++ es') 87 | concat = coerce (Vec.concat @Int) 88 | 89 | -- | Slice off one entry from the top of the stack. \( O(1) \). 90 | tail :: Stack (e : es) -> Stack es 91 | tail = coerce (Vec.tail @Int) 92 | 93 | -- | @'KnownList' es@ means the list @es@ is concrete, /i.e./ is of the form @'[a1, a2, ..., an]@ instead of a type 94 | -- variable. 95 | class KnownList (es :: [Effect]) where 96 | -- | Get the length of the list. 97 | reifyLen :: Int 98 | reifyLen = unreifiable "KnownList" "Cleff.Internal.Stack.reifyLen" "the length of a type-level list" 99 | 100 | instance KnownList '[] where 101 | reifyLen = 0 102 | 103 | instance KnownList es => KnownList (e : es) where 104 | reifyLen = 1 + reifyLen @es 105 | 106 | -- | Slice off several entries from the top of the stack. \( O(1) \). 107 | drop :: ∀ es es'. KnownList es => Stack (es ++ es') -> Stack es' 108 | drop = coerce (Vec.drop @Int) (reifyLen @es) 109 | 110 | -- | Get the head of the stack. \( O(1) \). 111 | head :: Stack (e : es) -> HandlerPtr e 112 | head = coerce (Vec.head @Int) 113 | 114 | -- | Take elements from the top of the stack. \( O(m) \). 115 | take :: ∀ es es'. KnownList es => Stack (es ++ es') -> Stack es 116 | take = coerce (Vec.take @Int) (reifyLen @es) 117 | 118 | -- | @e ':>' es@ means the effect @e@ is present in the effect stack @es@, and therefore can be 'Cleff.send'ed in an 119 | -- @'Cleff.Eff' es@ computation. 120 | class (e :: Effect) :> (es :: [Effect]) where 121 | -- | Get the index of the element. 122 | reifyIndex :: Int 123 | reifyIndex = unreifiable "Elem" "Cleff.Internal.Stack.reifyIndex" "the index of an effect in the effect stack" 124 | infix 0 :> 125 | 126 | -- | The element closer to the head takes priority. 127 | instance {-# OVERLAPPING #-} e :> e : es where 128 | reifyIndex = 0 129 | 130 | instance e :> es => e :> e' : es where 131 | reifyIndex = 1 + reifyIndex @e @es 132 | 133 | type ElemNotFound e = Text "The element '" :<>: ShowType e :<>: Text "' is not present in the constraint" 134 | 135 | instance TypeError (ElemNotFound e) => e :> '[] where 136 | reifyIndex = error 137 | "Cleff.Internal.Stack.reifyIndex: Attempting to refer to a nonexistent member. Please report this as a bug." 138 | 139 | -- | @xs ':>>' es@ means the list of effects @xs@ are all present in the effect stack @es@. This is a convenient type 140 | -- alias for @(e1 ':>' es, ..., en ':>' es)@. 141 | type family xs :>> es :: Constraint where 142 | '[] :>> _ = () 143 | (x : xs) :>> es = (x :> es, xs :>> es) 144 | infix 0 :>> 145 | 146 | -- | Get an element in the stack. Amortized \( O(1) \). 147 | index :: ∀ e es. e :> es => Stack es -> HandlerPtr e 148 | index = coerce (Vec.index @Int) (reifyIndex @e @es) 149 | 150 | -- | @es@ is a subset of @es'@, /i.e./ all elements of @es@ are in @es'@. 151 | class KnownList es => Subset (es :: [Effect]) (es' :: [Effect]) where 152 | -- | Get a list of indices of the elements. 153 | reifyIndices :: [Int] 154 | reifyIndices = unreifiable 155 | "Subset" "Cleff.Internal.Stack.reifyIndices" "the indices of a subset of the effect stack" 156 | 157 | instance Subset '[] es where 158 | reifyIndices = [] 159 | 160 | instance (Subset es es', e :> es') => Subset (e : es) es' where 161 | reifyIndices = reifyIndex @e @es' : reifyIndices @es @es' 162 | 163 | -- | Get a subset of the stack. Amortized \( O(m) \). 164 | pick :: ∀ es es'. Subset es es' => Stack es' -> Stack es 165 | pick = coerce (Vec.pick @Int) (reifyLen @es) (reifyIndices @es @es') 166 | 167 | -- | Update an entry in the stack. \( O(n) \). 168 | update :: ∀ e es. e :> es => HandlerPtr e -> Stack es -> Stack es 169 | update = coerce (Vec.update @Int) (reifyIndex @e @es) 170 | -------------------------------------------------------------------------------- /src/Cleff/Internal/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | -- | 3 | -- Copyright: (c) 2021 Xy Ren 4 | -- License: BSD3 5 | -- Maintainer: xy.r@outlook.com 6 | -- Stability: unstable 7 | -- Portability: non-portable (GHC only) 8 | -- 9 | -- This module contains the definition of the 'Eff' monad, as well as reexports of some shared utilities in the 10 | -- internal modules. Most of the times, you won't need to use this module directly; user-facing functionalities are all 11 | -- exported via the "Cleff" module. 12 | -- 13 | -- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be 14 | -- extra careful if you're to depend on this module. 15 | module Cleff.Internal.Monad 16 | ( -- * The 'Eff' monad 17 | Eff (Eff, unEff) 18 | , Effect 19 | , Env (Env) 20 | , HandlerPtr (HandlerPtr, unHandlerPtr) 21 | -- * Constraints 22 | , (:>) 23 | , (:>>) 24 | , KnownList 25 | , Subset 26 | -- * Misc types 27 | , type (++) 28 | , type (~>) 29 | ) where 30 | 31 | import Cleff.Internal.Stack (Effect, HandlerPtr (HandlerPtr, unHandlerPtr), KnownList, Stack, Subset, 32 | type (++), type (:>), type (:>>)) 33 | import Control.Applicative (Applicative (liftA2)) 34 | import Control.Monad.Fix (MonadFix (mfix)) 35 | import Control.Monad.Zip (MonadZip (munzip, mzipWith)) 36 | import Data.Any (Any) 37 | import Data.Monoid (Ap (Ap)) 38 | import Data.RadixVec (RadixVec) 39 | import Data.String (IsString (fromString)) 40 | 41 | -- * The 'Eff' monad 42 | 43 | -- | The extensible effects monad. The monad @'Eff' es@ is capable of performing any effect in the /effect stack/ @es@, 44 | -- which is a type-level list that holds all effects available. 45 | -- 46 | -- The best practice is to always use a polymorphic type variable for the effect stack @es@, and then use the type 47 | -- operator '(:>)' in constraints to indicate what effects are available in the stack. For example, 48 | -- 49 | -- @ 50 | -- ('Cleff.Reader.Reader' 'String' ':>' es, 'Cleff.State.State' 'Bool' ':>' es) => 'Eff' es 'Integer' 51 | -- @ 52 | -- 53 | -- means you can perform operations of the @'Cleff.Reader.Reader' 'String'@ effect and the @'Cleff.State.State' 'Bool'@ 54 | -- effect in a computation returning an 'Integer'. A convenient shorthand, '(:>>)', can also be used to indicate 55 | -- multiple effects being in a stack: 56 | -- 57 | -- @ 58 | -- '['Cleff.Reader.Reader' 'String', 'Cleff.State.State' 'Bool'] ':>>' es => 'Eff' es 'Integer' 59 | -- @ 60 | -- 61 | -- The reason why you should always use a polymorphic effect stack as opposed to a concrete list of effects are that: 62 | -- 63 | -- * it can contain other effects that are used by computations other than the current one, and 64 | -- * it does not require you to run the effects in any particular order. 65 | type role Eff nominal representational 66 | newtype Eff es a = Eff { unEff :: Env es -> IO a } 67 | -- ^ The effect monad receives an effect environment 'Env' that contains all effect handlers and produces an 'IO' 68 | -- action. 69 | 70 | -- | The /effect environment/ that corresponds effects in the stack to their respective handlers. This 71 | -- structure simulates memory: handlers are retrieved via pointers ('HandlerPtr's), and for each effect in the stack 72 | -- we can either change what pointer it uses or change the handler the pointer points to. The former is used for global 73 | -- effect interpretation ('Cleff.reinterpretN') and the latter for local interpretation ('Cleff.toEffWith') in order to 74 | -- retain correct HO semantics. For more details on this see https://github.com/re-xyr/cleff/issues/5. 75 | type role Env nominal 76 | data Env (es :: [Effect]) = Env 77 | {-# UNPACK #-} !(Stack es) -- ^ The effect stack storing pointers to handlers. 78 | {-# UNPACK #-} !(RadixVec Any) -- ^ The storage that corresponds pointers to handlers. 79 | 80 | instance Functor (Eff es) where 81 | fmap f (Eff x) = Eff (fmap f . x) 82 | x <$ Eff y = Eff \es -> x <$ y es 83 | 84 | instance Applicative (Eff es) where 85 | pure = Eff . const . pure 86 | Eff f <*> Eff x = Eff \es -> f es <*> x es 87 | Eff x <* Eff y = Eff \es -> x es <* y es 88 | Eff x *> Eff y = Eff \es -> x es *> y es 89 | liftA2 f (Eff x) (Eff y) = Eff \es -> liftA2 f (x es) (y es) 90 | 91 | instance Monad (Eff es) where 92 | -- no 'return', because the default impl is correct and it is going to be deprecated anyway 93 | Eff x >>= f = Eff \es -> x es >>= \x' -> unEff (f x') es 94 | (>>) = (*>) -- More efficient, since the default is @x >> y = x >>= const y@ 95 | 96 | instance MonadFix (Eff es) where 97 | mfix f = Eff \es -> mfix \x -> unEff (f x) es 98 | 99 | -- | @since 0.2.1.0 100 | deriving via (Ap (Eff es) a) instance Bounded a => Bounded (Eff es a) 101 | 102 | -- | @since 0.2.1.0 103 | instance Num a => Num (Eff es a) where 104 | (+) = liftA2 (+) 105 | (-) = liftA2 (-) 106 | (*) = liftA2 (*) 107 | negate = fmap negate 108 | abs = fmap abs 109 | signum = fmap signum 110 | fromInteger = pure . fromInteger 111 | 112 | -- | @since 0.2.1.0 113 | instance Fractional a => Fractional (Eff es a) where 114 | (/) = liftA2 (/) 115 | recip = fmap recip 116 | fromRational = pure . fromRational 117 | 118 | -- | @since 0.2.1.0 119 | instance Floating a => Floating (Eff es a) where 120 | pi = pure pi 121 | exp = fmap exp 122 | log = fmap log 123 | sqrt = fmap sqrt 124 | (**) = liftA2 (**) 125 | logBase = liftA2 logBase 126 | sin = fmap sin 127 | cos = fmap cos 128 | tan = fmap tan 129 | asin = fmap asin 130 | acos = fmap acos 131 | atan = fmap atan 132 | sinh = fmap sinh 133 | cosh = fmap cosh 134 | tanh = fmap tanh 135 | asinh = fmap asinh 136 | acosh = fmap acosh 137 | atanh = fmap atanh 138 | 139 | -- | @since 0.2.1.0 140 | deriving newtype instance Semigroup a => Semigroup (Eff es a) 141 | 142 | -- | @since 0.2.1.0 143 | deriving newtype instance Monoid a => Monoid (Eff es a) 144 | 145 | -- | @since 0.2.1.0 146 | instance IsString a => IsString (Eff es a) where 147 | fromString = pure . fromString 148 | 149 | -- | Compatibility instance for @MonadComprehensions@. 150 | -- 151 | -- @since 0.2.1.0 152 | instance MonadZip (Eff es) where 153 | mzipWith = liftA2 154 | munzip x = (fst <$> x, snd <$> x) 155 | 156 | -- * Misc types 157 | 158 | -- | A natural transformation from @f@ to @g@. With this, instead of writing 159 | -- 160 | -- @ 161 | -- runSomeEffect :: 'Cleff.Eff' (SomeEffect : es) a -> 'Cleff.Eff' es a 162 | -- @ 163 | -- 164 | -- you can write: 165 | -- 166 | -- @ 167 | -- runSomeEffect :: 'Cleff.Eff' (SomeEffect : es) ~> 'Cleff.Eff' es 168 | -- @ 169 | type f ~> g = ∀ a. f a -> g a 170 | -------------------------------------------------------------------------------- /src/Cleff/Mask.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | -- | 3 | -- Copyright: (c) 2021 Xy Ren 4 | -- License: BSD3 5 | -- Maintainer: xy.r@outlook.com 6 | -- Stability: experimental 7 | -- Portability: non-portable (GHC only) 8 | module Cleff.Mask 9 | ( -- * Effect 10 | Mask (..) 11 | -- * High-level operations 12 | , bracket 13 | , bracketOnError 14 | , bracket_ 15 | , bracketOnError_ 16 | , onError 17 | , finally 18 | -- * Primitive operations 19 | , mask 20 | , uninterruptibleMask 21 | , onException 22 | , mask_ 23 | , uninterruptibleMask_ 24 | -- * Interpretations 25 | , runMask 26 | ) where 27 | 28 | import Cleff 29 | import Cleff.Internal.Base 30 | import qualified Control.Exception as Exc 31 | 32 | -- * Effect 33 | 34 | -- | An effect capable of 'Exc.mask'ing and performing cleanup operations when an computation is interrupted. In 35 | -- particular, this effects allows the use of 'bracket'. 36 | -- 37 | -- === Technical details 38 | -- 39 | -- Regarding the nuances of 'bracket' semantics, this effect uses the semantics of "UnliftIO.Exception" rather than 40 | -- "Control.Exception". They are more sensible defaults and users can implement other semantics out of the primitive 41 | -- operations if they want to. 42 | data Mask :: Effect where 43 | Mask :: ((m ~> m) -> m a) -> Mask m a 44 | UninterruptibleMask :: ((m ~> m) -> m a) -> Mask m a 45 | OnException :: m a -> m b -> Mask m a 46 | 47 | -- * Operations 48 | 49 | makeEffect_ ''Mask 50 | 51 | -- | Prevents a computation from receiving asynchronous exceptions, /i.e./ being interrupted by another thread. Also 52 | -- provides a function to restore receiving async exceptions for a computation. 53 | -- 54 | -- However, some potentially blocking actions like @takeMVar@ can still be interrupted, and for them also not to be 55 | -- interrupted in any case you'll need 'uninterruptibleMask'. See 'Control.Exception.mask' for details. 56 | mask :: Mask :> es => ((Eff es ~> Eff es) -> Eff es a) -> Eff es a 57 | 58 | -- | Prevents a computation from receiving asynchronous exceptions, even if there is an interruptible operation 59 | -- (operations that potentially deadlocks or otherwise blocks indefinitely). Therefore this function is potentially 60 | -- dangerous in the sense that it can make a thread both unresponsive and unkillable. See 61 | -- 'Control.Exception.uninterruptibleMask' for details. 62 | uninterruptibleMask :: Mask :> es => ((Eff es ~> Eff es) -> Eff es a) -> Eff es a 63 | 64 | -- | Like 'onError', but without 'uninterruptibleMask'ing the cleanup action, making it possible that a cleanup action 65 | -- is interrupted. Use 'onError' is usually the safer option. 66 | onException :: Mask :> es 67 | => Eff es a -- ^ The main computation that may throw an exception 68 | -> Eff es b -- ^ The computation that runs when an exception is thrown 69 | -> Eff es a 70 | 71 | -- | Run a computation that acquires a resource (@alloc@), then a main computation using that resource, then a cleanup 72 | -- computation (@dealloc@). 'bracket' guarantees that @alloc@ and @dealloc@ will always run, regardless of whether an 73 | -- exception is thrown in the main computation. Note that if an exception is thrown in the main computation, it will 74 | -- be rethrown after 'bracket' finishes. 75 | -- 76 | -- === Technical details 77 | -- 78 | -- Note that this function uses @unliftio@ semantics: resource acquiring action is interruptibly 'mask'ed while 79 | -- resource cleanup is 'uninterruptibleMask'ed. Most of the times, this will be what you want. Other functions in this 80 | -- module use @unliftio@ semantics too. 81 | bracket :: Mask :> es 82 | => Eff es a -- ^ The computation to run first, usually acquires a resource 83 | -> (a -> Eff es c) -- ^ The computation to run after the main computation, usually cleans up 84 | -> (a -> Eff es b) -- ^ The main computation that uses the resource 85 | -> Eff es b 86 | bracket alloc dealloc action = mask \restore -> do 87 | res <- alloc 88 | restore (action res) `finally` dealloc res 89 | 90 | -- | Like 'bracket', but only runs cleanup if an exception is thrown in the main computation. 91 | bracketOnError :: Mask :> es 92 | => Eff es a -- ^ The computation to run first, usually acquires a resource 93 | -> (a -> Eff es c) -- ^ The computation to run when the main computation throws an exception, usually cleans up 94 | -> (a -> Eff es b) -- ^ The main computation that uses the resource 95 | -> Eff es b 96 | bracketOnError alloc dealloc action = mask \restore -> do 97 | res <- alloc 98 | restore (action res) `onError` dealloc res 99 | 100 | -- | Variant of 'mask' that does not provide a restoring function. 101 | mask_ :: Mask :> es => Eff es a -> Eff es a 102 | mask_ m = mask \_ -> m 103 | 104 | -- | Variant of 'uninterruptibleMask' that does not provide a restoring function. 105 | uninterruptibleMask_ :: Mask :> es => Eff es a -> Eff es a 106 | uninterruptibleMask_ m = uninterruptibleMask \_ -> m 107 | 108 | -- | Variant of 'bracket' that does not pass the allocated resource to the cleanup action. 109 | bracket_ :: Mask :> es => Eff es a -> Eff es c -> (a -> Eff es b) -> Eff es b 110 | bracket_ ma = bracket ma . const 111 | 112 | -- | Variant of 'bracketOnError' that does not pass the allocated resource to the cleanup action. 113 | bracketOnError_ :: Mask :> es => Eff es a -> Eff es c -> (a -> Eff es b) -> Eff es b 114 | bracketOnError_ ma = bracketOnError ma . const 115 | 116 | -- | Attach an action that runs if the main computation throws an exception. Note that this will rethrow the exception 117 | -- instead of returning to normal control flow. 118 | -- 119 | -- The cleanup action is guaranteed not to be interrupted halfways. 120 | onError :: Mask :> es 121 | => Eff es a -- ^ The main computation that may throw an exception 122 | -> Eff es b -- ^ The computation that runs when an exception is thrown 123 | -> Eff es a 124 | onError m n = m `onException` uninterruptibleMask_ n 125 | 126 | -- | Attach a cleanup action that will always run after a potentially throwing computation. 127 | finally :: Mask :> es 128 | => Eff es a -- ^ The main computation that may throw an exception 129 | -> Eff es b -- ^ The computation that runs after the main computation, regardless of whether an exception is thrown 130 | -> Eff es a 131 | finally m mz = (m `onError` mz) <* uninterruptibleMask_ mz 132 | 133 | -- * Interpretations 134 | 135 | -- | Interpret the 'Mask' effect in terms of primitive 'IO' actions. 136 | runMask :: Eff (Mask : es) ~> Eff es 137 | runMask = thisIsPureTrustMe . reinterpret \case 138 | Mask f -> withToIO \toIO -> Exc.mask \restore -> toIO $ f (fromIO . restore . toIO) 139 | UninterruptibleMask f -> withToIO \toIO -> Exc.uninterruptibleMask \restore -> toIO $ f (fromIO . restore . toIO) 140 | OnException m n -> withToIO \toIO -> toIO m `Exc.catch` \(e :: Exc.SomeException) -> 141 | Exc.try @Exc.SomeException (toIO n) *> Exc.throwIO e 142 | -------------------------------------------------------------------------------- /src/Cleff/Internal/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_HADDOCK not-home #-} 3 | -- | 4 | -- Copyright: (c) 2021 Xy Ren 5 | -- License: BSD3 6 | -- Maintainer: xy.r@outlook.com 7 | -- Stability: unstable 8 | -- Portability: non-portable (GHC only) 9 | -- 10 | -- This module contains Template Haskell functions for generating definitions of functions that send effect 11 | -- operations. You mostly won't want to import this module directly; The "Cleff" module reexports the main 12 | -- functionalities of this module. 13 | -- 14 | -- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be 15 | -- extra careful if you're to depend on this module. 16 | module Cleff.Internal.TH (makeEffect, makeEffect_) where 17 | 18 | import Cleff.Internal.Interpret 19 | import Cleff.Internal.Monad 20 | import Control.Monad (join) 21 | import Data.Char (toLower) 22 | import Data.Foldable (foldl') 23 | import qualified Data.Map.Strict as Map 24 | import Data.Maybe (maybeToList) 25 | import Language.Haskell.TH 26 | import Language.Haskell.TH.Datatype (ConstructorInfo (constructorName), DatatypeInfo (datatypeCons), 27 | TypeSubstitution (applySubstitution), reifyDatatype) 28 | import Language.Haskell.TH.PprLib (text, (<>)) 29 | import Prelude hiding ((<>)) 30 | 31 | -- | For a datatype @T@ representing an effect, @'makeEffect' T@ generates function defintions for performing the 32 | -- operations of @T@ via 'send'. For example, 33 | -- 34 | -- @ 35 | -- 'makeEffect' ''Filesystem 36 | -- @ 37 | -- 38 | -- generates the following definitions: 39 | -- 40 | -- @ 41 | -- readFile :: Filesystem ':>' es => 'FilePath' -> 'Eff' es 'String' 42 | -- readFile x = 'send' (ReadFile x) 43 | -- writeFile :: Filesystem ':>' es => 'FilePath' -> 'String' -> 'Eff' es () 44 | -- writeFile x y = 'send' (WriteFile x y) 45 | -- @ 46 | -- 47 | -- The naming rule is changing the first uppercase letter in the constructor name to lowercase or removing the @:@ 48 | -- symbol in the case of operator constructors. Also, this function will preserve any fixity declarations defined on 49 | -- the constructors. 50 | -- 51 | -- === Technical details 52 | -- 53 | -- This function is also "weaker" than @polysemy@'s @makeSem@, because this function cannot properly handle some 54 | -- cases involving ambiguous types. Those cases are rare, though. See the @ThSpec@ test spec for more details. 55 | makeEffect :: Name -> Q [Dec] 56 | makeEffect = makeSmartCons True 57 | 58 | -- | Like 'makeEffect', but doesn't generate type signatures. This is useful when you want to attach Haddock 59 | -- documentation to the function signature, /e.g./: 60 | -- 61 | -- @ 62 | -- data Identity :: 'Cleff.Effect' where 63 | -- Noop :: Identity m () 64 | -- 'makeEffect_' ''Identity 65 | -- 66 | -- -- | Perform nothing at all. 67 | -- noop :: Identity ':>' es => 'Eff' es () 68 | -- @ 69 | -- 70 | -- Be careful that the function signatures must be added /after/ the 'makeEffect_' call. 71 | makeEffect_ :: Name -> Q [Dec] 72 | makeEffect_ = makeSmartCons False 73 | 74 | -- | This is the function underlying 'makeEffect' and 'makeEffect_'. You can switch between the behavior of two by 75 | -- changing the 'Bool' parameter to 'True' (generating signatures) or 'False' (not generating signatures). 76 | makeSmartCons :: Bool -> Name -> Q [Dec] 77 | makeSmartCons shouldMakeSig effName = do 78 | info <- reifyDatatype effName 79 | join <$> traverse (makeCon shouldMakeSig) (constructorName <$> reverse (datatypeCons info)) 80 | 81 | -- | Make a single function definition of a certain effect operation. 82 | makeCon :: Bool -> Name -> Q [Dec] 83 | makeCon shouldMakeSig name = do 84 | fixity <- reifyFixity name 85 | ctorTy <- reify name >>= \case 86 | DataConI _ ty _ -> pure ty 87 | _ -> fail $ show $ text "'" <> ppr name <> text "' is not a constructor" 88 | 89 | operationCtx' <- extractCtx ctorTy 90 | (operationParams', (effTy, effMonad, resTy')) <- extractParams ctorTy 91 | 92 | (esVar, maybeMndVar) <- case effMonad of 93 | Right m -> do 94 | fresh <- VarT <$> newName "es" 95 | pure (fresh, Just m) 96 | Left v -> pure (VarT v, Nothing) 97 | 98 | let operationCtx = substMnd maybeMndVar esVar <$> operationCtx' 99 | let operationParams = substMnd maybeMndVar esVar <$> operationParams' 100 | let resTy = substMnd maybeMndVar esVar resTy' 101 | 102 | let fnName = mkName $ toSmartConName $ nameBase name 103 | fnArgs <- traverse (const $ newName "x") operationParams 104 | 105 | let 106 | fnBody = VarE 'send `AppE` foldl' (\f -> AppE f . VarE) (ConE name) fnArgs 107 | fnSig = ForallT [] (UInfixT effTy ''(:>) esVar : operationCtx) 108 | (makeTyp operationParams esVar effTy resTy) 109 | 110 | pure $ 111 | maybeToList ((`InfixD` name) <$> fixity) ++ 112 | [ SigD fnName fnSig | shouldMakeSig ] ++ 113 | [ FunD fnName [Clause [] (NormalB $ LamE (VarP <$> fnArgs) fnBody) []] ] 114 | 115 | where 116 | -- Uncapitalize the first letter / remove the ':' in operator constructors 117 | toSmartConName :: String -> String 118 | toSmartConName (':' : xs) = xs 119 | toSmartConName (x : xs) = toLower x : xs 120 | toSmartConName _ = error "Cleff.makeEffect: Empty constructor name. Please report this as a bug." 121 | 122 | -- Extract constraints for the constructor (the type is normalized so we don't need to extract recursively) 123 | extractCtx :: Type -> Q Cxt 124 | extractCtx (ForallT _ ctx _) = pure ctx 125 | extractCtx ty = fail $ show $ text "The constructor with type'" <> ppr ty <> text "' does not construct an effect" 126 | 127 | -- Extract (parameter types, (effect type, Eff es / m variable, return type)) 128 | extractParams :: Type -> Q ([Type], (Type, Either Name Name, Type)) 129 | extractParams (ForallT _ _ t) = extractParams t 130 | extractParams (SigT t _) = extractParams t 131 | extractParams (ParensT t) = extractParams t 132 | extractParams (ArrowT `AppT` a `AppT` t) = do 133 | (args, ret) <- extractParams t 134 | pure (a : args, ret) 135 | #if MIN_VERSION_template_haskell(2,17,0) 136 | extractParams (MulArrowT `AppT` _ `AppT` a `AppT` t) = do 137 | (args, ret) <- extractParams t 138 | pure (a : args, ret) 139 | #endif 140 | extractParams (effTy `AppT` VarT mndVar `AppT` resTy) = pure ([], (effTy, Right mndVar, resTy)) 141 | extractParams (effTy `AppT` (ConT eff `AppT` VarT esVar) `AppT` resTy) 142 | | eff == ''Eff = pure ([], (effTy, Left esVar, resTy)) 143 | extractParams ty@(_ `AppT` m `AppT` _) = fail $ show 144 | $ text "The effect monad argument '" <> ppr m 145 | <> text "' in the effect '" <> ppr ty <> text "' is not a type variable nor in shape 'Eff es'" 146 | extractParams t = fail $ show 147 | $ text "The type '" <> ppr t 148 | <> text "' does not have the shape of an effect (i.e. has a polymorphic monad type and a result type)" 149 | 150 | -- Make the type of the smart constructor from params, effect row variable, effect type and result type 151 | -- Example: a -> m b -> c -> MyEffect m d ==> a -> Eff es b -> c -> Eff es d 152 | makeTyp :: [Type] -> Type -> Type -> Type -> Type 153 | makeTyp [] esVar _ resTy = ConT ''Eff `AppT` esVar `AppT` resTy 154 | makeTyp (parTy : pars) esVar effTy resTy = 155 | ArrowT `AppT` parTy `AppT` makeTyp pars esVar effTy resTy 156 | 157 | -- Substitute in 'Eff es' for the 'm' variable 158 | substMnd :: Maybe Name -> Type -> Type -> Type 159 | substMnd Nothing _ = id 160 | substMnd (Just mndVar) esVar = applySubstitution (Map.singleton mndVar $ ConT ''Eff `AppT` esVar) 161 | -------------------------------------------------------------------------------- /cleff.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.34.4. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: cleff 8 | version: 0.3.4.0 9 | synopsis: Fast and concise extensible effects 10 | description: @cleff@ is an effect system for building modular, well-abstracted and performant programs. It provides: 11 | . 12 | - Blazing-fast speed in the majority of use cases (<#benchmarks Benchmarks>) 13 | - Well-built integration with the existing Haskell ecosystem (@unliftio@, @monad-control@, @exceptions@...) 14 | - Predictable behavior under expections and concurrency that does not stab you in the back 15 | - Flexible and expressive API for power users, with first-class support of scoped effects 16 | . 17 | You can use @cleff@ out of the box, with little to no boilerplate. To get started, use the module "Cleff" as a 18 | starting point. 19 | category: Control, Effect, Language 20 | homepage: https://github.com/re-xyr/cleff#readme 21 | bug-reports: https://github.com/re-xyr/cleff/issues 22 | author: Xy Ren 23 | maintainer: xy.r@outlook.com 24 | copyright: 2021 Xy Ren 25 | license: BSD3 26 | license-file: LICENSE 27 | build-type: Simple 28 | tested-with: 29 | GHC == 8.6.5 30 | , GHC == 8.8.4 31 | , GHC == 8.10.7 32 | , GHC == 9.0.2 33 | , GHC == 9.2.2 34 | extra-source-files: 35 | CHANGELOG.md 36 | README.md 37 | 38 | source-repository head 39 | type: git 40 | location: https://github.com/re-xyr/cleff 41 | 42 | flag dynamic-ioe 43 | description: Make @IOE@ a real effect. This is only for reference purposes and should not be enabled in production code. 44 | 45 | manual: True 46 | default: False 47 | 48 | library 49 | exposed-modules: 50 | Cleff 51 | Cleff.Error 52 | Cleff.Fail 53 | Cleff.Fresh 54 | Cleff.Input 55 | Cleff.Internal.Base 56 | Cleff.Internal.Env 57 | Cleff.Internal.Interpret 58 | Cleff.Internal.Monad 59 | Cleff.Internal.Stack 60 | Cleff.Internal.TH 61 | Cleff.Mask 62 | Cleff.Output 63 | Cleff.Reader 64 | Cleff.State 65 | Cleff.Trace 66 | Cleff.Writer 67 | other-modules: 68 | Data.Any 69 | Data.PrimVec 70 | Data.RadixVec 71 | Data.ThreadVar 72 | hs-source-dirs: 73 | src 74 | default-extensions: 75 | BangPatterns 76 | BlockArguments 77 | ConstraintKinds 78 | DataKinds 79 | DeriveAnyClass 80 | DerivingStrategies 81 | DerivingVia 82 | EmptyCase 83 | FlexibleContexts 84 | FlexibleInstances 85 | FunctionalDependencies 86 | GADTs 87 | GeneralizedNewtypeDeriving 88 | LambdaCase 89 | MagicHash 90 | NoStarIsType 91 | PatternSynonyms 92 | PolyKinds 93 | RankNTypes 94 | RoleAnnotations 95 | ScopedTypeVariables 96 | StandaloneDeriving 97 | TemplateHaskell 98 | TupleSections 99 | TypeApplications 100 | TypeFamilies 101 | TypeOperators 102 | UndecidableInstances 103 | UnicodeSyntax 104 | UnliftedFFITypes 105 | ViewPatterns 106 | ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors -Wpartial-fields -Wunused-type-patterns -Wmissing-export-lists 107 | build-depends: 108 | atomic-primops ==0.8.* 109 | , base >=4.12 && <4.17 110 | , containers >=0.5 && <0.7 111 | , exceptions ==0.10.* 112 | , microlens >=0.1 && <0.5 113 | , monad-control >=1 && <1.1 114 | , primitive >=0.6.4 && <0.8 115 | , stm ==2.5.* 116 | , template-haskell >=2.14 && <2.19 117 | , th-abstraction >=0.2 && <0.5 118 | , transformers-base ==0.4.* 119 | , unliftio-core >=0.1.1 && <0.3 120 | if flag(dynamic-ioe) 121 | cpp-options: -DDYNAMIC_IOE 122 | if impl(ghc >= 8.8) 123 | ghc-options: -Wmissing-deriving-strategies 124 | default-language: Haskell2010 125 | 126 | test-suite cleff-example 127 | type: exitcode-stdio-1.0 128 | main-is: Main.hs 129 | other-modules: 130 | Broker 131 | Filesystem 132 | Teletype 133 | Paths_cleff 134 | hs-source-dirs: 135 | example 136 | default-extensions: 137 | BangPatterns 138 | BlockArguments 139 | ConstraintKinds 140 | DataKinds 141 | DeriveAnyClass 142 | DerivingStrategies 143 | DerivingVia 144 | EmptyCase 145 | FlexibleContexts 146 | FlexibleInstances 147 | FunctionalDependencies 148 | GADTs 149 | GeneralizedNewtypeDeriving 150 | LambdaCase 151 | MagicHash 152 | NoStarIsType 153 | PatternSynonyms 154 | PolyKinds 155 | RankNTypes 156 | RoleAnnotations 157 | ScopedTypeVariables 158 | StandaloneDeriving 159 | TemplateHaskell 160 | TupleSections 161 | TypeApplications 162 | TypeFamilies 163 | TypeOperators 164 | UndecidableInstances 165 | UnicodeSyntax 166 | UnliftedFFITypes 167 | ViewPatterns 168 | ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors -Wpartial-fields -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-N 169 | build-depends: 170 | atomic-primops ==0.8.* 171 | , base >=4.12 && <4.17 172 | , cleff 173 | , containers >=0.5 && <0.7 174 | , exceptions ==0.10.* 175 | , extra 176 | , microlens >=0.1 && <0.5 177 | , monad-control >=1 && <1.1 178 | , primitive >=0.6.4 && <0.8 179 | , stm ==2.5.* 180 | , template-haskell >=2.14 && <2.19 181 | , th-abstraction >=0.2 && <0.5 182 | , transformers-base ==0.4.* 183 | , unliftio 184 | , unliftio-core >=0.1.1 && <0.3 185 | if flag(dynamic-ioe) 186 | cpp-options: -DDYNAMIC_IOE 187 | if impl(ghc >= 8.8) 188 | ghc-options: -Wmissing-deriving-strategies 189 | default-language: Haskell2010 190 | 191 | test-suite cleff-test 192 | type: exitcode-stdio-1.0 193 | main-is: Main.hs 194 | other-modules: 195 | ConcurrencySpec 196 | ErrorSpec 197 | HigherOrderSpec 198 | InterposeSpec 199 | MaskSpec 200 | StateSpec 201 | ThSpec 202 | Paths_cleff 203 | hs-source-dirs: 204 | test 205 | default-extensions: 206 | BangPatterns 207 | BlockArguments 208 | ConstraintKinds 209 | DataKinds 210 | DeriveAnyClass 211 | DerivingStrategies 212 | DerivingVia 213 | EmptyCase 214 | FlexibleContexts 215 | FlexibleInstances 216 | FunctionalDependencies 217 | GADTs 218 | GeneralizedNewtypeDeriving 219 | LambdaCase 220 | MagicHash 221 | NoStarIsType 222 | PatternSynonyms 223 | PolyKinds 224 | RankNTypes 225 | RoleAnnotations 226 | ScopedTypeVariables 227 | StandaloneDeriving 228 | TemplateHaskell 229 | TupleSections 230 | TypeApplications 231 | TypeFamilies 232 | TypeOperators 233 | UndecidableInstances 234 | UnicodeSyntax 235 | UnliftedFFITypes 236 | ViewPatterns 237 | ghc-options: -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors -Wpartial-fields -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-N 238 | build-depends: 239 | atomic-primops ==0.8.* 240 | , base >=4.12 && <4.17 241 | , cleff 242 | , containers >=0.5 && <0.7 243 | , exceptions ==0.10.* 244 | , extra 245 | , hspec 246 | , lifted-base 247 | , microlens >=0.1 && <0.5 248 | , monad-control >=1 && <1.1 249 | , primitive >=0.6.4 && <0.8 250 | , stm ==2.5.* 251 | , template-haskell >=2.14 && <2.19 252 | , th-abstraction >=0.2 && <0.5 253 | , transformers-base ==0.4.* 254 | , unliftio 255 | , unliftio-core >=0.1.1 && <0.3 256 | if flag(dynamic-ioe) 257 | cpp-options: -DDYNAMIC_IOE 258 | if impl(ghc >= 8.8) 259 | ghc-options: -Wmissing-deriving-strategies 260 | default-language: Haskell2010 261 | -------------------------------------------------------------------------------- /src/Cleff/Error.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE Trustworthy #-} 3 | -- | 4 | -- Copyright: (c) 2021 Xy Ren 5 | -- License: BSD3 6 | -- Maintainer: xy.r@outlook.com 7 | -- Stability: experimental 8 | -- Portability: non-portable (GHC only) 9 | module Cleff.Error 10 | ( -- * Effect 11 | Error (..) 12 | -- * Operations 13 | , throwError 14 | , catchError 15 | -- ** Other ways of throwing errors 16 | , fromEither 17 | , fromException 18 | , fromExceptionVia 19 | , fromExceptionEff 20 | , fromExceptionEffVia 21 | , note 22 | -- ** Other ways of handling errors 23 | , catchErrorJust 24 | , catchErrorIf 25 | , handleError 26 | , handleErrorJust 27 | , handleErrorIf 28 | , tryError 29 | , tryErrorJust 30 | -- * Interpretations 31 | , runError 32 | , mapError 33 | ) where 34 | 35 | import Cleff 36 | import Cleff.Internal.Base 37 | import Control.Exception (Exception) 38 | import qualified Control.Exception as Exc 39 | import Control.Monad ((<=<)) 40 | import Data.Any (Any, pattern Any) 41 | import Data.Atomics.Counter (AtomicCounter, incrCounter, newCounter) 42 | import Data.Bool (bool) 43 | import System.IO.Unsafe (unsafePerformIO) 44 | 45 | -- * Effect 46 | 47 | -- | An effect capable of breaking out of current control flow by throwing an error of type @e@, and handling the 48 | -- errors thrown from computations. This effect roughly corresponds to the @MonadError@ typeclass and @ExceptT@ monad 49 | -- transformer in @mtl@. 50 | data Error e :: Effect where 51 | ThrowError :: e -> Error e m a 52 | CatchError :: m a -> (e -> m a) -> Error e m a 53 | 54 | -- * Operations 55 | 56 | makeEffect_ ''Error 57 | 58 | -- | Throw an error in the current computation. 59 | throwError :: Error e :> es => e -> Eff es a 60 | 61 | -- | Handle an error if one is thrown from a computation, and then return to normal control flow. 62 | catchError :: Error e :> es 63 | => Eff es a -- ^ The computation that may throw errors 64 | -> (e -> Eff es a) -- ^ The handler that is called when an error is thrown 65 | -> Eff es a 66 | 67 | -- | Lift an 'Either' value into the 'Error' effect. 68 | fromEither :: Error e :> es => Either e a -> Eff es a 69 | fromEither = either throwError pure 70 | 71 | -- | Lift exceptions generated by an 'IO' computation into the 'Error' effect. 72 | fromException :: ∀ e es a. (Exception e, '[Error e, IOE] :>> es) => IO a -> Eff es a 73 | fromException m = withRunInIO \run -> Exc.catch m (run . throwError @e) 74 | 75 | -- | Like 'fromException', but allows to transform the exception into another error type. 76 | fromExceptionVia :: (Exception ex, '[Error er, IOE] :>> es) => (ex -> er) -> IO a -> Eff es a 77 | fromExceptionVia f m = withRunInIO \run -> Exc.catch m (run . throwError . f) 78 | 79 | -- | Lift exceptions generated by an 'Eff' computation into the 'Error' effect. 80 | fromExceptionEff :: ∀ e es a. (Exception e, '[Error e, IOE] :>> es) => Eff es a -> Eff es a 81 | fromExceptionEff m = withRunInIO \run -> Exc.catch (run m) (run . throwError @e) 82 | 83 | -- | Like 'fromExceptionEff', but allows to transform the exception into another error type. 84 | fromExceptionEffVia :: (Exception ex, '[Error er, IOE] :>> es) => (ex -> er) -> Eff es a -> Eff es a 85 | fromExceptionEffVia f m = withRunInIO \run -> Exc.catch (run m) (run . throwError . f) 86 | 87 | -- | Try to extract a value from 'Maybe', throw an error otherwise. 88 | note :: Error e :> es => e -> Maybe a -> Eff es a 89 | note e = maybe (throwError e) pure 90 | 91 | -- | A variant of 'catchError' that allows a predicate to choose whether to catch ('Just') or rethrow ('Nothing') the 92 | -- error. 93 | catchErrorJust :: Error e :> es => (e -> Maybe b) -> Eff es a -> (b -> Eff es a) -> Eff es a 94 | catchErrorJust f m h = m `catchError` \e -> maybe (throwError e) h $ f e 95 | 96 | -- | A variant of 'catchError' that allows a predicate to choose whether to catch ('True') or rethrow ('False') the 97 | -- error. 98 | catchErrorIf :: Error e :> es => (e -> Bool) -> Eff es a -> (e -> Eff es a) -> Eff es a 99 | catchErrorIf f m h = m `catchError` \e -> bool (throwError e) (h e) $ f e 100 | 101 | -- | Flipped version of 'catchError'. 102 | handleError :: Error e :> es => (e -> Eff es a) -> Eff es a -> Eff es a 103 | handleError = flip catchError 104 | 105 | -- | Flipped version of 'catchErrorJust'. 106 | handleErrorJust :: Error e :> es => (e -> Maybe b) -> (b -> Eff es a) -> Eff es a -> Eff es a 107 | handleErrorJust = flip . catchErrorJust 108 | 109 | -- | Flipped version of 'catchErrorIf'. 110 | handleErrorIf :: Error e :> es => (e -> Bool) -> (e -> Eff es a) -> Eff es a -> Eff es a 111 | handleErrorIf = flip . catchErrorIf 112 | 113 | -- | Runs a computation, returning a 'Left' value if an error was thrown. 114 | tryError :: Error e :> es => Eff es a -> Eff es (Either e a) 115 | tryError m = (Right <$> m) `catchError` (pure . Left) 116 | 117 | -- | A variant of 'tryError' that allows a predicate to choose whether to catch ('True') or rethrow ('False') the 118 | -- error. 119 | tryErrorJust :: Error e :> es => (e -> Maybe b) -> Eff es a -> Eff es (Either b a) 120 | tryErrorJust f m = (Right <$> m) `catchError` \e -> maybe (throwError e) (pure . Left) $ f e 121 | 122 | -- * Interpretations 123 | 124 | type ExcUid = Int 125 | 126 | -- | Exception wrapper used in 'runError' in order not to conflate error types with exception types. 127 | data ErrorExc = ErrorExc !ExcUid Any 128 | deriving anyclass (Exception) 129 | 130 | instance Show ErrorExc where 131 | showsPrec _ (ErrorExc uid _) = 132 | ("Cleff.Error.runError: Escaped error (error UID: " <>) . shows uid . ("). This is possibly due \ 133 | \to trying to 'throwError' in a forked thread, or trying to 'wait' on an error-throwing 'Async' computation out \ 134 | \of the effect scope where it is created. Refer to the haddock of 'runError' for details on the caveats. If all \ 135 | \those shenanigans mentioned or other similar ones seem unlikely, please report this as a bug." <>) 136 | 137 | catch' :: ∀ e es a. IOE :> es => ExcUid -> Eff es a -> (e -> Eff es a) -> Eff es a 138 | catch' eid m h = withRunInIO \run -> run m `Exc.catch` \ex@(ErrorExc eid' (Any e)) -> 139 | if eid == eid' then run $ h e else Exc.throwIO ex 140 | 141 | try' :: ∀ e es a. IOE :> es => ExcUid -> Eff es a -> Eff es (Either e a) 142 | try' eid m = catch' eid (Right <$> m) (pure . Left) 143 | 144 | excUidSource :: AtomicCounter 145 | excUidSource = unsafePerformIO (newCounter 0) 146 | {-# NOINLINE excUidSource #-} 147 | 148 | newExcUid :: IO ExcUid 149 | newExcUid = incrCounter 1 excUidSource 150 | 151 | errorHandler :: ExcUid -> Handler (Error e) (IOE : es) 152 | errorHandler eid = \case 153 | ThrowError e -> liftIO $ Exc.throwIO $ ErrorExc eid (Any e) 154 | CatchError m' h' -> catch' eid (toEff m') (toEff . h') 155 | 156 | -- | Run an 'Error' effect. 157 | -- 158 | -- === Caveats 159 | -- 160 | -- 'runError' is implemented with 'Exc.Exception's therefore inherits some of its unexpected behaviors. 161 | -- Errors thrown in forked threads will /not/ be directly caught by 'catchError's in the parent thread. Instead it will 162 | -- incur an exception, and we won't be quite able to display the details of that exception properly at that point. 163 | -- Therefore please properly handle the errors in the forked threads separately. 164 | -- 165 | -- However if you use @async@ and @wait@ for the action in the same effect scope (/i.e./ they get to be interpreted by 166 | -- the same 'runError' handler), the error /will/ be caught in the parent thread even if you don't deal with it in the 167 | -- forked thread. But if you passed the @Async@ value out of the effect scope and @wait@ed for it elsewhere, the error 168 | -- will again not be caught. The best choice is /not to pass @Async@ values around randomly/. 169 | runError :: ∀ e es a. Eff (Error e : es) a -> Eff es (Either e a) 170 | runError m = thisIsPureTrustMe do 171 | eid <- liftIO newExcUid 172 | try' eid (reinterpret (errorHandler eid) m) 173 | 174 | -- | Transform an 'Error' into another. This is useful for aggregating multiple errors into one type. 175 | mapError :: ∀ e e' es. Error e' :> es => (e -> e') -> Eff (Error e : es) ~> Eff es 176 | mapError f = either (throwError . f) pure <=< runError 177 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # `cleff` - fast and concise extensible effects 2 | 3 | [![GitHub Workflow Status](https://img.shields.io/github/workflow/status/re-xyr/cleff/build)](https://github.com/re-xyr/cleff/actions/workflows/build.yaml) 4 | [![Hackage](https://img.shields.io/hackage/v/cleff)](https://hackage.haskell.org/package/cleff) 5 | 6 | `cleff` is an extensible effects library for Haskell, with a focus on the balance of performance, expressiveness and ease of use. It provides a set of predefined effects that you can conveniently reuse in your program, as well as low-boilerplate mechanisms for defining and interpreting new domain-specific effects on your own. 7 | 8 | In essence, `cleff` offers: 9 | 10 | - **Performance**: 11 | 12 | `cleff` does not use techniques like Freer monads or monad transformers. Instead, `cleff`'s `Eff` monad is essentially implemented as a `ReaderT IO`. This concrete formulation [allows more GHC optimizations to fire][alexis-talk], and has lower performance overhead. [In microbenchmarks](#benchmarks), `cleff` outperforms [`polysemy`] and even `mtl`. 13 | 14 | The only caveat is that `cleff` does not support nondeterminism and continuations in the `Eff` monad - but after all, [most effects libraries has broken nondeterminism support](https://github.com/polysemy-research/polysemy/issues/246), and we encourage users to wrap another monad transformer with support of nondeterminism (*e.g.* `ListT`) over the main `Eff` monad in such cases. 15 | 16 | - **Low boilerplate**: 17 | 18 | `cleff` supports user-defined effects and provides simple yet flexible API for implementing them. Implementations of effects are simply case-splitting functions, and users familiar with [`polysemy`] or [`freer-simple`] will find it very easy to get along with `cleff`. [Take a look at the examples](#example). 19 | 20 | - **Interoperability**: 21 | 22 | `cleff`'s simple underlying structure allows us to implement near-seamless interop with the current ecosystem, mainly classes like `MonadUnliftIO`, `MonadCatch` and `MonadBaseControl`. In other words, you can directly use libraries like `unliftio`, `exceptions` and `lifted-async` in `cleff` without writing any "adapter" code. 23 | 24 | - **Predictable semantics**: 25 | 26 | Traditional effect libraries have many surprising behaviors. For example, `mtl` reverts the state when an error is thrown, and has [a lot more subtleties when interacting with `IO`][readert]. `cleff` implements `State` and `Writer` as `IORef` operations, and `Error` as `Exceptions`, so it is able to interact well with `IO` and provide semantics that are predictable in the presence of concurrency and exceptions. Moreover, any potentially surprising behavior is carefully documented for each effect. 27 | 28 | - **Higher-order effects**: 29 | 30 | *Higher-order* effects are effects that "wraps" monadic computations, like `local`, `catchError` and `mask`. Implementing higher-order effects is often tedious, or outright not supported in most effect libraries. `polysemy` is the first library that aims to provide easy higher-order effects mechanism with its `Tactics` API. Following its path, `cleff` provides a set of combinators that can be used to implement higher-order effects. These combinators are as expressive as `polysemy`'s, and are also easier to use correctly. 31 | 32 | - **Ergonomics without sacrificing flexibility**: 33 | 34 | Unlike `mtl`, `cleff` doesn't have functional dependencies on effects, so you can have *e.g.* multiple `State` effects. As a side effect, GHC will sometimes ask you to provide which effect you're operating on via `TypeApplications`, or otherwise the effect usage will be ambiguous. This can be verbose at times, and we have a solution for that: [`cleff-plugin`](https://github.com/re-xyr/cleff/tree/master/cleff-plugin) is a GHC plugin that works like `mtl`'s functional dependencies, and can resolve most type ambiguities involving effects for you. 35 | 36 | ## Example 37 | 38 | This is the code that defines the classic `Teletype` effect. It only takes 20 lines to define the effect and two interpretations, one using stdio and another reading from and writing to a list: 39 | 40 | ```haskell 41 | import Cleff 42 | import Cleff.Input 43 | import Cleff.Output 44 | import Cleff.State 45 | import Data.Maybe (fromMaybe) 46 | 47 | -- Effect definition 48 | data Teletype :: Effect where 49 | ReadTTY :: Teletype m String 50 | WriteTTY :: String -> Teletype m () 51 | makeEffect ''Teletype 52 | 53 | -- Effect Interpretation via IO 54 | runTeletypeIO :: IOE :> es => Eff (Teletype : es) a -> Eff es a 55 | runTeletypeIO = interpretIO \case 56 | ReadTTY -> getLine 57 | WriteTTY s -> putStrLn s 58 | 59 | -- Effect interpretation via other pure effects 60 | runTeletypePure :: [String] -> Eff (Teletype : es) w -> Eff es [String] 61 | runTeletypePure tty = fmap (reverse . snd) 62 | . runState [] . outputToListState 63 | . runState tty . inputToListState 64 | . reinterpret2 \case 65 | ReadTTY -> fromMaybe "" <$> input 66 | WriteTTY msg -> output msg 67 | 68 | -- Using the effect 69 | 70 | echo :: Teletype :> es => Eff es () 71 | echo = do 72 | x <- readTTY 73 | if null x then pure () 74 | else writeTTY x >> echo 75 | 76 | echoPure :: [String] -> [String] 77 | echoPure input = runPure $ runTeletypePure input echo 78 | 79 | main :: IO () 80 | main = runIOE $ runTeletypeIO echo 81 | ``` 82 | 83 | See [`example/`](https://github.com/re-xyr/cleff/tree/master/example/) for more examples. 84 | 85 | ## Benchmarks 86 | 87 | These are the results of [`effectful`'s microbenchmarks](https://github.com/haskell-effectful/effectful/tree/master/benchmarks), compiled by GHC 8.10.7. Each diagram shows the average run time of each effect library's implementation of an identical program; lower is better. Each benchmark suite has two flavors - *shallow* and *deep* - where the shallow variant only uses necessary effects, and the deep variant adds 10 redundant `Reader` effects, to simulate more realistic scenarios. Keep in mind that these are *very short and synthetic programs*, and may or may not tell the accurate performance characteristics of different effect libraries in real use. 88 | 89 | - `countdown`: ![countdown benchmark result](https://raw.githubusercontent.com/re-xyr/cleff/master/docs/img/benchmark-countdown.png) 90 | - `filesize`: ![filesize benchmark result](https://raw.githubusercontent.com/re-xyr/cleff/master/docs/img/benchmark-filesize.png) 91 | 92 | ### Differences from `effectful` 93 | 94 | If you know about [`effectful`], you may notice that `cleff` and `effectful` seem to make many similar claims and have a similar underlying implementation. In microbenchmarks, `cleff` is slightly behind `effectful`. This may make you confused about the differences between the two libraries. To put it simply, `cleff` has a more versatile and expressive effect interpretation mechanism, and a lighter weight API. In contrast, `effectful` gains its performance advantage by providing static dispatch for some internal effects, which means they cannot have multiple interpretations. 95 | 96 | ## References 97 | 98 | These are the useful resources that inspired this library's design and implementation. 99 | 100 | Papers: 101 | 102 | - [Extensible Effect: An Alternative to Monad Transformers](https://okmij.org/ftp/Haskell/extensible/exteff.pdf) by Oleg Kiselyov, Amr Sabry, and Cameron Swords. 103 | - [Freer Monads, More Extensible Effects](https://okmij.org/ftp/Haskell/extensible/more.pdf) by Oleg Kiselyov, and Hiromi Ishii. 104 | 105 | Libraries: 106 | 107 | - [`eff`] by Alexis King and contributors. 108 | - [`effectful`] by Andrzej Rybczak and contributors. 109 | - [`freer-simple`] by Alexis King and contributors. 110 | - [`polysemy`] by Sandy Maguire and contributors. 111 | 112 | Talks: 113 | 114 | - [Effects for Less][alexis-talk] by Alexis King. 115 | - [Unresolved challenges of scoped effects, and what that means for `eff`][alexis-talk-2] by Alexis King. 116 | 117 | Blog posts: 118 | 119 | - [Asynchronous Exception Handling in Haskell](https://www.fpcomplete.com/blog/2018/04/async-exception-handling-haskell/) by Michael Snoyman. 120 | - [Polysemy: Mea Culpa](https://reasonablypolymorphic.com/blog/mea-culpa/) by Sandy Maguire. 121 | - [Polysemy Internals: The Effect-Interpreter Effect](https://reasonablypolymorphic.com/blog/tactics/) by Sandy Maguire. 122 | - [ReaderT design pattern][readert] by Michael Snoyman. 123 | - [Safe exception handling](https://www.fpcomplete.com/haskell/tutorial/exceptions/) by Michael Snoyman. 124 | 125 | [`polysemy`]: https://hackage.haskell.org/package/polysemy 126 | [`fused-effects`]: https://hackage.haskell.org/package/fused-effects 127 | [`effectful`]: https://github.com/arybczak/effectful 128 | [`eff`]: https://github.com/hasura/eff 129 | [`freer-simple`]: https://hackage.haskell.org/package/freer-simple 130 | [alexis-talk]: https://www.youtube.com/watch?v=0jI-AlWEwYI 131 | [alexis-talk-2]: https://www.twitch.tv/videos/1163853841 132 | [readert]: https://www.fpcomplete.com/blog/2017/06/readert-design-pattern/ 133 | -------------------------------------------------------------------------------- /src/Cleff/Internal/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_HADDOCK not-home #-} 3 | {-# OPTIONS_GHC -Wno-orphans #-} 4 | -- | 5 | -- Copyright: (c) 2021 Xy Ren 6 | -- License: BSD3 7 | -- Maintainer: xy.r@outlook.com 8 | -- Stability: unstable 9 | -- Portability: non-portable (GHC only) 10 | -- 11 | -- This module contains the 'IOE' effect together with a few primitives for using it, as well as interpretation 12 | -- combinators for 'IO'-related effects. It is not usually needed because safe functionalities are re-exported in the 13 | -- "Cleff" module. 14 | -- 15 | -- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be 16 | -- extra careful if you're to depend on this module. 17 | module Cleff.Internal.Base 18 | ( -- * The 'IOE' Effect 19 | IOE 20 | -- * Primitive 'IO' functions 21 | , primLiftIO 22 | , primUnliftIO 23 | -- * Related classes 24 | , MonadIO (liftIO) 25 | , MonadUnliftIO (withRunInIO) 26 | -- * Unwrapping 'Eff' 27 | , thisIsPureTrustMe 28 | , runIOE 29 | , runPure 30 | , runPureIO 31 | -- * Effect interpretation 32 | , HandlerIO 33 | , interpretIO 34 | -- * Combinators for interpreting higher-order effects 35 | , withToIO 36 | , fromIO 37 | ) where 38 | 39 | import qualified Cleff.Internal.Env as Env 40 | import Cleff.Internal.Interpret 41 | import Cleff.Internal.Monad 42 | import qualified Cleff.Internal.Stack as Stack 43 | import Control.Monad.Base (MonadBase (liftBase)) 44 | import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) 45 | import qualified Control.Monad.Catch as Catch 46 | import Control.Monad.IO.Unlift (MonadIO (liftIO), MonadUnliftIO (withRunInIO)) 47 | import Control.Monad.Primitive (PrimMonad (PrimState, primitive), RealWorld) 48 | import Control.Monad.Trans.Control (MonadBaseControl (StM, liftBaseWith, restoreM)) 49 | import GHC.IO (IO (IO)) 50 | import System.IO.Unsafe (unsafeDupablePerformIO) 51 | 52 | -- * The 'IOE' effect 53 | 54 | -- | The effect capable of lifting and unlifting the 'IO' monad, allowing you to use 'MonadIO', 'MonadUnliftIO', 55 | -- 'PrimMonad', 'MonadCatch', 'MonadThrow' and 'MonadMask' functionalities. This is the "final" effect that most 56 | -- effects eventually are interpreted into. For example, you can do: 57 | -- 58 | -- @ 59 | -- log :: 'IOE' :> es => 'Eff' es () 60 | -- log = 'liftIO' ('putStrLn' "Test logging") 61 | -- @ 62 | -- 63 | -- It is not recommended to use this effect directly in application code, as it is too liberal and allows arbitrary IO, 64 | -- therefore making it harder to do proper effect management. Ideally, this is only used in interpreting more 65 | -- fine-grained effects. 66 | -- 67 | -- === Technical details 68 | -- 69 | -- Note that this is /not/ a real effect and cannot be interpreted in any way besides 'thisIsPureTrustMe' and 70 | -- 'runIOE'. This is mainly for performance concern, but also that there doesn't really exist reasonable 71 | -- interpretations other than the current one, given the underlying implementation of the 'Eff' monad. 72 | -- 73 | -- 'IOE' can be a real effect though, and you can enable the @dynamic-ioe@ build flag to have that. However it is only 74 | -- for reference purposes and should not be used in production code. 75 | data IOE :: Effect where 76 | #ifdef DYNAMIC_IOE 77 | Lift :: IO a -> IOE m a 78 | Unlift :: ((m ~> IO) -> IO a) -> IOE m a 79 | #endif 80 | 81 | -- * Primitive 'IO' functions 82 | 83 | -- | Lift an 'IO' computation into 'Eff'. This function is /highly unsafe/ and should not be used directly; use 'liftIO' 84 | -- instead, or if you're interpreting higher-order effects, use 'fromIO'. 85 | primLiftIO :: IO a -> Eff es a 86 | primLiftIO = Eff . const 87 | 88 | -- | Give a runner function a way to run 'Eff' actions as an 'IO' computation. This function is /highly unsafe/ and 89 | -- should not be used directly; use 'withRunInIO' instead, or if you're interpreting higher-order effects, use 90 | -- 'withToIO'. 91 | primUnliftIO :: ((Eff es ~> IO) -> IO a) -> Eff es a 92 | primUnliftIO f = Eff \es -> f \(Eff m) -> m es 93 | 94 | instance IOE :> es => MonadIO (Eff es) where 95 | #ifdef DYNAMIC_IOE 96 | liftIO = send . Lift 97 | #else 98 | liftIO = primLiftIO 99 | #endif 100 | 101 | instance IOE :> es => MonadUnliftIO (Eff es) where 102 | #ifdef DYNAMIC_IOE 103 | withRunInIO f = send $ Unlift f 104 | #else 105 | withRunInIO = primUnliftIO 106 | #endif 107 | 108 | instance IOE :> es => MonadThrow (Eff es) where 109 | throwM = liftIO . Catch.throwM 110 | 111 | instance IOE :> es => MonadCatch (Eff es) where 112 | catch m h = withRunInIO \run -> Catch.catch (run m) (run . h) 113 | 114 | instance IOE :> es => MonadMask (Eff es) where 115 | mask f = withRunInIO \run -> Catch.mask \restore -> run $ f (liftIO . restore . run) 116 | uninterruptibleMask f = withRunInIO \run -> Catch.uninterruptibleMask \restore -> run $ f (liftIO . restore . run) 117 | generalBracket ma mz m = withRunInIO \run -> Catch.generalBracket (run ma) (\x e -> run $ mz x e) (run . m) 118 | 119 | -- | Compatibility instance; use 'MonadIO' if possible. 120 | instance IOE :> es => MonadBase IO (Eff es) where 121 | liftBase = liftIO 122 | 123 | -- | Compatibility instance; use 'MonadUnliftIO' if possible. 124 | instance IOE :> es => MonadBaseControl IO (Eff es) where 125 | type StM (Eff es) a = a 126 | liftBaseWith = withRunInIO 127 | restoreM = pure 128 | 129 | instance IOE :> es => PrimMonad (Eff es) where 130 | type PrimState (Eff es) = RealWorld 131 | primitive = liftIO . IO 132 | 133 | -- * Unwrapping 'Eff' 134 | 135 | -- | Unsafely eliminate an 'IOE' effect from the top of the effect stack. This is mainly for implementing effects that 136 | -- uses 'IO' but does not do anything really /impure/ (/i.e./ can be safely used 'unsafeDupablePerformIO' on), such as a 137 | -- State effect. 138 | thisIsPureTrustMe :: Eff (IOE : es) ~> Eff es 139 | thisIsPureTrustMe = 140 | #ifndef DYNAMIC_IOE 141 | adjust (Stack.cons $ HandlerPtr (-1)) 142 | #else 143 | interpret \case 144 | Lift m -> primLiftIO m 145 | Unlift f -> primUnliftIO \runInIO -> f (runInIO . toEff) 146 | #endif 147 | {-# INLINE thisIsPureTrustMe #-} 148 | 149 | -- | Unwrap an 'Eff' computation with side effects into an 'IO' computation, given that all effects other than 'IOE' are 150 | -- interpreted. 151 | runIOE :: Eff '[IOE] ~> IO 152 | runIOE = runPureIO . thisIsPureTrustMe 153 | {-# INLINE runIOE #-} 154 | 155 | -- | Unwrap a pure 'Eff' computation into a pure value, given that all effects are interpreted. 156 | runPure :: Eff '[] a -> a 157 | runPure = unsafeDupablePerformIO . runPureIO 158 | {-# INLINE runPure #-} 159 | 160 | -- | Unwrap a pure 'Eff' computation into an 'IO' computation. You may occasionally need this. 161 | runPureIO :: Eff '[] ~> IO 162 | runPureIO = \(Eff m) -> m Env.empty 163 | {-# INLINE runPureIO #-} 164 | 165 | -- * Effect interpretation 166 | 167 | -- | The type of an /'IO' effect handler/, which is a function that transforms an effect @e@ into 'IO' computations. 168 | -- This is used for 'interpretIO'. 169 | type HandlerIO e es = ∀ esSend. Handling esSend e es => e (Eff esSend) ~> IO 170 | 171 | -- | Interpret an effect in terms of 'IO', by transforming an effect into 'IO' computations. 172 | -- 173 | -- @ 174 | -- 'interpretIO' f = 'interpret' ('liftIO' '.' f) 175 | -- @ 176 | interpretIO :: IOE :> es => HandlerIO e es -> Eff (e : es) ~> Eff es 177 | interpretIO f = interpret (liftIO . f) 178 | {-# INLINE interpretIO #-} 179 | 180 | -- * Combinators for interpreting higher-order effects 181 | 182 | -- | Temporarily gain the ability to unlift an @'Eff' esSend@ computation into 'IO'. This is analogous to 183 | -- 'withRunInIO', and is useful in dealing with higher-order effects that involves 'IO'. For example, the @Resource@ 184 | -- effect that supports bracketing: 185 | -- 186 | -- @ 187 | -- data Resource m a where 188 | -- Bracket :: m a -> (a -> m ()) -> (a -> m b) -> Resource m b 189 | -- @ 190 | -- 191 | -- can be interpreted into 'Control.Exception.bracket' actions in 'IO', by converting all effect computations into 192 | -- 'IO' computations via 'withToIO': 193 | -- 194 | -- @ 195 | -- runResource :: 'IOE' ':>' es => 'Eff' (Resource : es) a -> 'Eff' es a 196 | -- runResource = 'interpret' \\case 197 | -- Bracket alloc dealloc use -> 'withToIO' $ \\toIO -> 198 | -- 'Control.Exception.bracket' (toIO alloc) (toIO . dealloc) (toIO . use) 199 | -- @ 200 | withToIO :: (Handling esSend e es, IOE :> es) => ((Eff esSend ~> IO) -> IO a) -> Eff es a 201 | withToIO f = Eff \es -> f \(Eff m) -> m (Env.update es esSend) 202 | {-# INLINE withToIO #-} 203 | 204 | -- | Lift an 'IO' computation into @'Eff' esSend@. This is analogous to 'liftIO', and is only useful in dealing with 205 | -- effect operations with the monad type in the negative position, for example 'Control.Exception.mask'ing: 206 | -- 207 | -- @ 208 | -- data Mask :: 'Effect' where 209 | -- Mask :: ((m '~>' m) -> m a) -> Mask m a 210 | -- ^ this "m" is in negative position 211 | -- @ 212 | -- 213 | -- See how the @restore :: IO a -> IO a@ from 'Control.Exception.mask' is "wrapped" into 214 | -- @'Eff' esSend a -> 'Eff' esSend a@: 215 | -- 216 | -- @ 217 | -- runMask :: 'IOE' ':>' es => 'Eff' (Mask : es) a -> 'Eff' es a 218 | -- runMask = 'interpret' \\case 219 | -- Mask f -> 'withToIO' $ \\toIO -> 'Control.Exception.mask' $ 220 | -- \\restore -> f ('fromIO' . restore . toIO) 221 | -- @ 222 | -- 223 | -- Here, @toIO@ from 'withToIO' takes an @'Eff' esSend@ to 'IO', where it can be passed into the @restore@ function, 224 | -- and the returned 'IO' computation is recovered into 'Eff' with 'fromIO'. 225 | fromIO :: (Handling esSend e es, IOE :> es) => IO ~> Eff esSend 226 | fromIO = Eff . const 227 | {-# INLINE fromIO #-} 228 | -------------------------------------------------------------------------------- /src/Cleff.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | -- | 3 | -- Copyright: (c) 2021 Xy Ren 4 | -- License: BSD3 5 | -- Maintainer: xy.r@outlook.com 6 | -- Stability: experimental 7 | -- Portability: non-portable (GHC only) 8 | -- 9 | -- This library implements an /extensible effects system/, where sets of monadic actions ("effects") are encoded as 10 | -- datatypes, tracked at the type level and can have multiple different implementations. This means you can swap out 11 | -- implementations of certain monadic actions in mock tests or in different environments. The notion of "effect" is 12 | -- general here: it can be an 'IO'-performing side effect, or just reading the value of a static global environment. 13 | -- 14 | -- In particular, this library consists of 15 | -- 16 | -- * The 'Eff' monad, which is the core of an extensible effects system. All effects are performed within it and it 17 | -- will be the "main" monad of your application. This monad tracks effects at the type level. 18 | -- * A set of predefined general effects, like 'Cleff.Reader.Reader' and 'Cleff.State.State' that can be used out of 19 | -- the box. 20 | -- * Combinators for defining new effects and interpreting them /on your own/. These effects can be translated in terms 21 | -- of other already existing effects, or into operations in the 'IO' monad. 22 | -- 23 | -- In terms of structuring your application, this library helps you to do two things: 24 | -- 25 | -- * __Effect management:__ The 'Eff' monad tracks what effects are used explicitly at the type level, therefore you 26 | -- are able to enforce what effects are involved in each function, and avoid accidentally introduced behaviors. 27 | -- * __Effect decoupling:__ You can swap between the implementations of the effects in your application easily, 28 | -- so you can refactor and test your applications with less clutter. 29 | module Cleff 30 | ( -- * Using effects 31 | Eff 32 | , (:>) 33 | , (:>>) 34 | , Effect 35 | , IOE 36 | -- ** Running effects 37 | -- $runningEffects 38 | , runPure 39 | , runIOE 40 | -- * Defining effects 41 | -- $definingEffects 42 | , send 43 | , sendVia 44 | , makeEffect 45 | , makeEffect_ 46 | -- * Trivial effects handling 47 | , raise 48 | , raiseN 49 | , inject 50 | , subsume 51 | , subsumeN 52 | , KnownList 53 | , Subset 54 | -- * Interpreting effects 55 | -- $interpretingEffects 56 | , Handler 57 | , interpret 58 | , reinterpret 59 | , reinterpret2 60 | , reinterpret3 61 | , reinterpretN 62 | , interpose 63 | , impose 64 | , imposeN 65 | -- ** Interpreting in terms of 'IO' 66 | , HandlerIO 67 | , interpretIO 68 | -- ** Translating effects 69 | , Translator 70 | , transform 71 | , translate 72 | -- ** Transforming interpreters 73 | , raiseUnder 74 | , raiseNUnder 75 | , raiseUnderN 76 | , raiseNUnderN 77 | -- * Combinators for interpreting higher order effects 78 | -- $higherOrderEffects 79 | , Handling 80 | , toEff 81 | , toEffWith 82 | , withFromEff 83 | -- ** Interpreting 'IO'-related higher order effects 84 | , withToIO 85 | , fromIO 86 | -- * Miscellaneous 87 | , type (~>) 88 | , type (++) 89 | , MonadIO (..) 90 | , MonadUnliftIO (..) 91 | ) where 92 | 93 | import Cleff.Internal.Base 94 | import Cleff.Internal.Interpret 95 | import Cleff.Internal.Monad 96 | import Cleff.Internal.TH 97 | 98 | -- $runningEffects 99 | -- To run an effect @T@, we should use an /interpreter/ of @T@, which is a function that has a type like this: 100 | -- 101 | -- @ 102 | -- runT :: 'Eff' (T : es) a -> 'Eff' es a 103 | -- @ 104 | -- 105 | -- Such an interpreter provides an implementation of @T@ and eliminates @T@ from the effect stack. All builtin effects 106 | -- in @cleff@ have interpreters out of the box in their respective modules. 107 | -- 108 | -- By applying interpreters to an 'Eff' computation, you can eventually obtain an /end computation/, where there are no 109 | -- more effects to be interpreted on the effect stack. There are two kinds of end computations: 110 | -- 111 | -- * A /pure computation/ with the type @'Eff' '[] a@, which you can obtain the value via 'runPure'; or, 112 | -- * An /impure computation/ with type @'Eff' '['IOE'] a@ that can be unwrapped into an IO computation via 113 | -- 'runIOE'. 114 | 115 | -- $definingEffects 116 | -- An effect should be defined as a GADT and have the kind 'Effect'. Each operation in the effect is a constructor of 117 | -- the effect type. For example, an effect supporting reading and writing files can be like this: 118 | -- 119 | -- @ 120 | -- data Filesystem :: 'Effect' where 121 | -- ReadFile :: 'FilePath' -> Filesystem m 'String' 122 | -- WriteFile :: 'FilePath' -> 'String' -> Filesystem m () 123 | -- @ 124 | -- 125 | -- Here, @ReadFile@ is an operation that takes a 'FilePath' and returns a 'String', presumably the content of the file; 126 | -- @WriteFile@ is an operation that takes a 'FilePath' and a 'String' and returns @()@, meaning it only performs 127 | -- side effects - presumably writing the 'String' to the file specified. 128 | -- 129 | -- Operations constructed with these constructors can be performed via the 'send' function. You can also use the 130 | -- Template Haskell function 'makeEffect' to automatically generate definitions of functions that perform the effects. 131 | 132 | -- $interpretingEffects 133 | -- An effect can be understood as the /syntax/ of a tiny language; however we also need to define the /meaning/ (or 134 | -- /semantics/) of the language. In other words, we need to specify the implementations of effects. 135 | -- 136 | -- In an extensible effects system, this is achieved by writing /effect handlers/, which are functions that transforms 137 | -- operations of one effect into other "more primitive" effects. These handlers can then be used to make interpreters 138 | -- with library functions that we'll now see. 139 | -- 140 | -- For example, for the @Filesystem@ effect: 141 | -- 142 | -- @ 143 | -- data Filesystem :: 'Effect' where 144 | -- ReadFile :: 'FilePath' -> Filesystem m 'String' 145 | -- WriteFile :: 'FilePath' -> 'String' -> Filesystem m () 146 | -- @ 147 | -- 148 | -- We can easily handle it in terms of 'IO' operations via 'interpretIO', by pattern matching on the effect 149 | -- constructors: 150 | -- 151 | -- @ 152 | -- runFilesystemIO :: 'IOE' ':>' es => 'Eff' (Filesystem : es) a -> 'Eff' es a 153 | -- runFilesystemIO = 'interpretIO' \\case 154 | -- ReadFile path -> 'readFile' path 155 | -- WriteFile path contents -> 'writeFile' path contents 156 | -- @ 157 | -- 158 | -- Specifically, a @ReadFile@ operation is mapped to a real 'readFile' IO computation, and similarly a @WriteFile@ 159 | -- operation is mapped to a 'writeFile' computation. 160 | -- 161 | -- An effect is a set of abstract operations, and naturally, they can have more than one interpretations. Therefore, 162 | -- here we can also construct an in-memory filesystem that reads from and writes into a 'Cleff.State.State' effect, via 163 | -- the 'reinterpret' function that adds another effect to the stack for the effect handler to use: 164 | -- 165 | -- @ 166 | -- filesystemToState 167 | -- :: 'Cleff.Fail.Fail' ':>' es 168 | -- => 'Eff' (Filesystem : es) a 169 | -- -> 'Eff' ('Cleff.State.State' ('Data.Map.Map' 'FilePath' 'String') : es) a 170 | -- filesystemToState = 'reinterpret' \\case 171 | -- ReadFile path -> 'Cleff.State.gets' ('Data.Map.lookup' path) >>= \\case 172 | -- 'Nothing' -> 'fail' ("File not found: " ++ 'show' path) 173 | -- 'Just' contents -> 'pure' contents 174 | -- WriteFile path contents -> 'Cleff.State.modify' ('Data.Map.insert' path contents) 175 | -- @ 176 | -- 177 | -- Here, we used the 'reinterpret' function to introduce a @'Cleff.State.State' ('Data.Map.Map' 'FilePath' 'String')@ as 178 | -- the in-memory filesystem, making @filesystemToState@ a /reinterpreter/ that "maps" an effect into another effect. 179 | -- We also added a @'Cleff.Fail.Fail' ':>' es@ constraint to our reinterpreter so that we're able to report errors. 180 | -- To make an /interpreter/ out of this is simple, as we just need to interpret the remaining 'Cleff.State.State' 181 | -- effect: 182 | -- 183 | -- @ 184 | -- runFilesystemPure 185 | -- :: 'Cleff.Fail.Fail' ':>' es 186 | -- => 'Data.Map.Map' 'FilePath' 'String' 187 | -- -> 'Eff' (Filesystem : es) a 188 | -- -> 'Eff' es a 189 | -- runFilesystemPure fs 190 | -- = 'fmap' 'fst' -- runState returns (Eff es (a, s)), so we need to extract the first component to get (Eff es a) 191 | -- . 'Cleff.State.runState' fs -- (State (Map FilePath String) : es) ==> es 192 | -- . filesystemToState -- (Filesystem : es) ==> (State (Map FilePath String) : es) 193 | -- @ 194 | -- 195 | -- Both of these interpreters can then be applied to computations with the @Filesystem@ effect to give different 196 | -- implementations to the effect. 197 | 198 | -- $higherOrderEffects 199 | -- /Higher order effects/ are effects whose operations take other effect computations as arguments. For example, the 200 | -- 'Cleff.Error.Error' effect is a higher order effect, because its 'Cleff.Error.CatchError' operation takes an effect 201 | -- computation that may throw errors and also an error handler that returns an effect computation: 202 | -- 203 | -- @ 204 | -- data Error e :: 'Effect' where 205 | -- ThrowError :: e -> Error e m a 206 | -- CatchError :: m a -> (e -> m a) -> Error e m a 207 | -- @ 208 | -- 209 | -- More literally, an high order effect makes use of the monad type paramenter @m@, while a first order effect, like 210 | -- 'Cleff.State.State', does not. 211 | -- 212 | -- It is harder to write interpreters for higher order effects, because the operations of these effects carry 213 | -- computations from arbitrary effect stacks, and we'll need to convert the to the current effect stack that the effect 214 | -- is being interpreted into. Fortunately, Cleff provides convenient combinators for doing so. 215 | -- 216 | -- In a 'Handler', you can temporarily "unlift" a computation from an arbitrary effect stack into the current stack via 217 | -- 'toEff', explicitly change the current effect interpretation in the computation via 'toEffWith', or directly express 218 | -- the effect in terms of 'IO' via 'withToIO'. 219 | -------------------------------------------------------------------------------- /src/Cleff/Internal/Interpret.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# OPTIONS_HADDOCK not-home #-} 3 | -- | 4 | -- Copyright: (c) 2021 Xy Ren 5 | -- License: BSD3 6 | -- Maintainer: xy.r@outlook.com 7 | -- Stability: unstable 8 | -- Portability: non-portable (GHC only) 9 | -- 10 | -- This module contains most functions for interacting with the effect system. Most of the times you won't need to 11 | -- import this directly; the module "Cleff" reexports the majority of the functionalities. If you want operations 12 | -- more flexible than these, see "Cleff.Internal.Env". 13 | -- 14 | -- __This is an /internal/ module and its API may change even between minor versions.__ Therefore you should be 15 | -- extra careful if you're to depend on this module. 16 | module Cleff.Internal.Interpret 17 | ( -- * General transformation 18 | alter 19 | , adjust 20 | -- * Performing operations 21 | , send 22 | , sendVia 23 | -- * Trivial handling 24 | , raise 25 | , raiseN 26 | , inject 27 | , subsume 28 | , subsumeN 29 | , raiseUnder 30 | , raiseNUnder 31 | , raiseUnderN 32 | , raiseNUnderN 33 | -- * Interpreting effects 34 | , Handler 35 | , interpret 36 | , reinterpret 37 | , reinterpret2 38 | , reinterpret3 39 | , reinterpretN 40 | , interpose 41 | , impose 42 | , imposeN 43 | -- * Translating effects 44 | , Translator 45 | , transform 46 | , translate 47 | -- * Combinators for interpreting higher effects 48 | , Handling 49 | , esSend 50 | , toEff 51 | , toEffWith 52 | , withFromEff 53 | ) where 54 | 55 | import Cleff.Internal.Env (Handler, Handling, esSend) 56 | import qualified Cleff.Internal.Env as Env 57 | import Cleff.Internal.Monad 58 | import Cleff.Internal.Stack (Stack) 59 | import qualified Cleff.Internal.Stack as Stack 60 | 61 | -- | Alter the effect environment by a contravariant transformation function over it. This function reveals the 62 | -- profunctorial nature of 'Eff'; in particular, 'Eff' is a profunctor @['Effect'] -> 'Data.Kind.Type'@, @lmap@ is 63 | -- 'alter', and @rmap@ is 'fmap'. 64 | alter :: ∀ es es'. (Env es' -> Env es) -> Eff es ~> Eff es' 65 | alter f = \(Eff m) -> Eff \es -> m (f es) 66 | 67 | -- | A specialized version of 'alter' that only adjusts the effect stack. 68 | adjust :: ∀ es es'. (Stack es' -> Stack es) -> Eff es ~> Eff es' 69 | adjust f = alter (Env.adjust f) 70 | 71 | -- * Performing operations 72 | 73 | -- | Perform an effect operation, /i.e./ a value of an effect type @e :: 'Effect'@. This requires @e@ to be in the 74 | -- effect stack. 75 | send :: e :> es => e (Eff es) ~> Eff es 76 | send = sendVia id 77 | {-# INLINE send #-} 78 | 79 | -- | Perform an action in another effect stack via a transformation to that stack; in other words, this function "maps" 80 | -- the effect operation from effect stack @es@ to @es'@. This is a largely generalized version of 'send'; only use this 81 | -- if you are sure about what you're doing. 82 | -- 83 | -- @ 84 | -- 'send' = 'sendVia' 'id' 85 | -- @ 86 | -- 87 | -- @since 0.2.0.0 88 | sendVia :: e :> es' => (Eff es ~> Eff es') -> e (Eff es) ~> Eff es' 89 | sendVia f e = Eff \es -> unEff (f $ Env.read es e) es 90 | {-# INLINE sendVia #-} 91 | 92 | -- * Trivial handling 93 | 94 | -- | Lift a computation into a bigger effect stack with one more effect. For a more general version see 'raiseN'. 95 | raise :: ∀ e es. Eff es ~> Eff (e : es) 96 | raise = raiseN @'[e] 97 | 98 | -- | Lift a computation into a bigger effect stack with arbitrarily more effects. This function requires 99 | -- @TypeApplications@. 100 | raiseN :: ∀ es' es. KnownList es' => Eff es ~> Eff (es' ++ es) 101 | raiseN = adjust (Stack.drop @es') 102 | 103 | -- | Like 'raise', but adds the new effect under the top effect. This is useful for transforming an interpreter 104 | -- @e' ':>' es => 'Eff' (e : es) '~>` 'Eff' es@ into a reinterpreter @'Eff' (e : es) '~>' 'Eff' (e' : es)@: 105 | -- 106 | -- @ 107 | -- myInterpreter :: Bar ':>' es => 'Eff' (Foo : es) '~>' 'Eff' es 108 | -- myInterpreter = ... 109 | -- 110 | -- myReinterpreter :: 'Eff' (Foo : es) '~>' 'Eff' (Bar : es) 111 | -- myReinterpreter = myInterpreter '.' 'raiseUnder' 112 | -- @ 113 | -- 114 | -- In other words, 115 | -- 116 | -- @ 117 | -- 'reinterpret' h == 'interpret' h . 'raiseUnder' 118 | -- @ 119 | -- 120 | -- However, note that this function is suited for transforming an existing interpreter into a reinterpreter; if you 121 | -- want to define a reinterpreter from scratch, you should still prefer 'reinterpret', which is both easier to use and 122 | -- more efficient. 123 | -- 124 | -- @since 0.2.0.0 125 | raiseUnder :: ∀ e' e es. Eff (e : es) ~> Eff (e : e' : es) 126 | raiseUnder = raiseNUnder @'[e'] 127 | 128 | -- | Like 'raiseUnder', but allows introducing multiple effects. This function requires @TypeApplications@. 129 | -- 130 | -- @since 0.2.0.0 131 | raiseNUnder :: ∀ es' e es. KnownList es' => Eff (e : es) ~> Eff (e : es' ++ es) 132 | raiseNUnder = raiseNUnderN @es' @'[e] 133 | 134 | -- | Like 'raiseUnder', but allows introducing the effect under multiple effects. This function requires 135 | -- @TypeApplications@. 136 | -- 137 | -- @since 0.2.0.0 138 | raiseUnderN :: ∀ e es' es. KnownList es' => Eff (es' ++ es) ~> Eff (es' ++ e : es) 139 | raiseUnderN = raiseNUnderN @'[e] @es' @es 140 | 141 | -- | A generalization of both 'raiseUnderN' and 'raiseNUnder', allowing introducing multiple effects under multiple 142 | -- effects. This function requires @TypeApplications@ and is subject to serious type ambiguity; you most likely will 143 | -- need to supply all three type variables explicitly. 144 | -- 145 | -- @since 0.2.0.0 146 | raiseNUnderN :: ∀ es'' es' es. (KnownList es', KnownList es'') => Eff (es' ++ es) ~> Eff (es' ++ es'' ++ es) 147 | raiseNUnderN = adjust \re -> Stack.concat 148 | (Stack.take @es' @(es'' ++ es) re) (Stack.drop @es'' @es (Stack.drop @es' @(es'' ++ es) re)) 149 | 150 | -- | Lift a computation with a fixed, known effect stack into some superset of the stack. 151 | inject :: ∀ es' es. Subset es' es => Eff es' ~> Eff es 152 | inject = adjust (Stack.pick @es') 153 | 154 | -- | Eliminate a duplicate effect from the top of the effect stack. For a more general version see 'subsumeN'. 155 | subsume :: ∀ e es. e :> es => Eff (e : es) ~> Eff es 156 | subsume = subsumeN @'[e] 157 | 158 | -- | Eliminate several duplicate effects from the top of the effect stack. This function requires @TypeApplications@. 159 | subsumeN :: ∀ es' es. Subset es' es => Eff (es' ++ es) ~> Eff es 160 | subsumeN = adjust \re -> Stack.concat (Stack.pick @es' re) re 161 | 162 | -- * Interpreting effects 163 | 164 | -- | Interpret an effect @e@ in terms of effects in the effect stack @es@ with an effect handler. 165 | interpret :: ∀ e es. Handler e es -> Eff (e : es) ~> Eff es 166 | interpret = reinterpretN @'[] 167 | {-# INLINE interpret #-} 168 | 169 | -- | Like 'interpret', but adds a new effect @e'@ to the stack that can be used in the handler. 170 | reinterpret :: ∀ e' e es. Handler e (e' : es) -> Eff (e : es) ~> Eff (e' : es) 171 | reinterpret = reinterpretN @'[e'] 172 | {-# INLINE reinterpret #-} 173 | 174 | -- | Like 'reinterpret', but adds two new effects. 175 | reinterpret2 :: ∀ e' e'' e es. Handler e (e' : e'' : es) -> Eff (e : es) ~> Eff (e' : e'' : es) 176 | reinterpret2 = reinterpretN @'[e', e''] 177 | {-# INLINE reinterpret2 #-} 178 | 179 | -- | Like 'reinterpret', but adds three new effects. 180 | reinterpret3 :: ∀ e' e'' e''' e es. Handler e (e' : e'' : e''' : es) -> Eff (e : es) ~> Eff (e' : e'' : e''' : es) 181 | reinterpret3 = reinterpretN @'[e', e'', e'''] 182 | {-# INLINE reinterpret3 #-} 183 | 184 | -- | Like 'reinterpret', but adds arbitrarily many new effects. This function requires @TypeApplications@. 185 | reinterpretN :: ∀ es' e es. KnownList es' => Handler e (es' ++ es) -> Eff (e : es) ~> Eff (es' ++ es) 186 | reinterpretN handle = alter \es -> Env.extend es handle $ Env.adjust (Stack.drop @es') es 187 | {-# INLINE reinterpretN #-} 188 | 189 | -- | Respond to an effect, but does not eliminate it from the stack. This means you can re-send the operations in the 190 | -- effect handler; it is often useful when you need to "intercept" operations so you can add extra behaviors like 191 | -- logging. 192 | interpose :: ∀ e es. e :> es => Handler e es -> Eff es ~> Eff es 193 | interpose = imposeN @'[] 194 | {-# INLINE interpose #-} 195 | 196 | -- | Like 'interpose', but allows to introduce one new effect to use in the handler. 197 | impose :: ∀ e' e es. e :> es => Handler e (e' : es) -> Eff es ~> Eff (e' : es) 198 | impose = imposeN @'[e'] 199 | {-# INLINE impose #-} 200 | 201 | -- | Like 'impose', but allows introducing arbitrarily many effects. This requires @TypeApplications@. 202 | imposeN :: ∀ es' e es. (KnownList es', e :> es) => Handler e (es' ++ es) -> Eff es ~> Eff (es' ++ es) 203 | imposeN handle = alter \es -> Env.overwriteLocal es handle $ Env.adjust (Stack.drop @es') es 204 | {-# INLINE imposeN #-} 205 | 206 | -- * Translating effects 207 | 208 | -- | The type of a simple transformation function from effect @e@ to @e'@. 209 | type Translator e e' = ∀ esSend. e (Eff esSend) ~> e' (Eff esSend) 210 | 211 | -- | Interpret an effect in terms of another effect in the stack via a simple 'Translator'. 212 | -- 213 | -- @ 214 | -- 'transform' trans = 'interpret' ('sendVia' 'toEff' '.' trans) 215 | -- @ 216 | transform :: ∀ e e' es. e' :> es => Translator e e' -> Eff (e : es) ~> Eff es 217 | transform trans = interpret (sendVia toEff . trans) 218 | {-# INLINE transform #-} 219 | 220 | -- | Like 'transform', but instead of using an effect in stack, add a new one to the top of it. 221 | -- 222 | -- @ 223 | -- 'translate' trans = 'reinterpret' ('sendVia' 'toEff' '.' trans) 224 | -- @ 225 | translate :: ∀ e e' es. Translator e e' -> Eff (e : es) ~> Eff (e' : es) 226 | translate trans = reinterpret (sendVia toEff . trans) 227 | {-# INLINE translate #-} 228 | 229 | -- * Combinators for interpreting higher effects 230 | 231 | -- | Run a computation in the current effect stack; this is useful for interpreting higher-order effects. For example, 232 | -- if you want to interpret a bracketing effects in terms of 'IO': 233 | -- 234 | -- @ 235 | -- data Resource m a where 236 | -- Bracket :: m a -> (a -> m ()) -> (a -> m b) -> Resource m b 237 | -- @ 238 | -- 239 | -- You will not be able to simply write this for the effect: 240 | -- 241 | -- @ 242 | -- runBracket :: IOE ':>' es => 'Eff' (Resource : es) a -> 'Eff' es a 243 | -- runBracket = 'interpret' \\case 244 | -- Bracket alloc dealloc use -> UnliftIO.'UnliftIO.bracket' alloc dealloc use 245 | -- @ 246 | -- 247 | -- This is because effects are sended from all kinds of stacks that has @Resource@ in it, so effect handlers received 248 | -- the effect as @Resource esSend a@, where @esSend@ is an arbitrary stack with @Resource@, instead of 249 | -- @Resource es a@. This means @alloc@, @dealloc@ and @use@ are of type @'Eff' esSend a@, while 'UnliftIO.bracket' can 250 | -- only take and return @'Eff' es a@. So we need to use 'toEff', which converts an @'Eff' esSend a@ into 251 | -- an @'Eff' es a@: 252 | -- 253 | -- @ 254 | -- runBracket :: IOE ':>' es => 'Eff' (Resource : es) a -> 'Eff' es a 255 | -- runBracket = 'interpret' \\case 256 | -- Bracket alloc dealloc use -> UnliftIO.'UnliftIO.bracket' 257 | -- ('toEff' alloc) 258 | -- ('toEff' . dealloc) 259 | -- ('toEff' . use) 260 | -- @ 261 | toEff :: Handling esSend e es => Eff esSend ~> Eff es 262 | toEff = alter \es -> Env.update es esSend 263 | {-# INLINE toEff #-} 264 | 265 | -- [Note] toEffWith 266 | -- 267 | -- The 'Handling' constraint of 'handle' will NOT be prematurely initialized here because that will make 'handle' 268 | -- monomorphic. Therefore this usage is safe. 269 | 270 | -- | Run a computation in the current effect stack, just like 'toEff', but takes a 'Handler' of the current effect 271 | -- being interpreted, so that inside the computation being ran, the effect is interpreted differently. This is useful 272 | -- for interpreting effects with local contexts, like 'Cleff.Reader.Local': 273 | -- 274 | -- @ 275 | -- runReader :: r -> 'Eff' ('Cleff.Reader.Reader' r : es) '~>' 'Eff' es 276 | -- runReader x = 'interpret' (handle x) 277 | -- where 278 | -- handle :: r -> 'Handler' ('Cleff.Reader.Reader' r) es 279 | -- handle r = \\case 280 | -- 'Cleff.Reader.Ask' -> 'pure' r 281 | -- 'Cleff.Reader.Local' f m -> 'toEffWith' (handle $ f r) m 282 | -- @ 283 | toEffWith :: ∀ esSend e es. Handling esSend e es => Handler e es -> Eff esSend ~> Eff es 284 | toEffWith handle = alter \es -> Env.overwriteSelfGlobal es handle $ Env.update es esSend 285 | {-# INLINE toEffWith #-} 286 | 287 | -- | Temporarily gain the ability to lift some @'Eff' es@ actions into @'Eff' esSend@. This is only useful for dealing 288 | -- with effect operations with the monad type in the negative position, which means it's unlikely that you need to use 289 | -- this function in implementing your effects. 290 | withFromEff :: Handling esSend e es => ((Eff es ~> Eff esSend) -> Eff esSend a) -> Eff es a 291 | withFromEff f = Eff \es -> unEff (f $ alter \ess -> Env.update ess es) (Env.update es esSend) 292 | {-# INLINE withFromEff #-} 293 | -------------------------------------------------------------------------------- /cleff-plugin/src/Cleff/Plugin/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 3 | {-# HLINT ignore "Redundant if" #-} 4 | -- | Copyright: (c) 2022 Xy Ren 5 | -- License: BSD3 6 | -- Maintainer: xy.r@outlook.com 7 | -- Stability: unstable 8 | -- Portability: non-portable (GHC only) 9 | module Cleff.Plugin.Internal (Plugin, Names, makePlugin) where 10 | 11 | import Data.Function (on) 12 | import Data.IORef (IORef, modifyIORef, newIORef, readIORef) 13 | import Data.Maybe (isNothing, mapMaybe) 14 | import Data.Set (Set) 15 | import qualified Data.Set as Set 16 | import Data.Traversable (for) 17 | import GHC.TcPluginM.Extra (lookupModule, lookupName) 18 | 19 | #if __GLASGOW_HASKELL__ >= 900 20 | import GHC.Core.Class (Class) 21 | import GHC.Core.InstEnv (InstEnvs, lookupInstEnv) 22 | import GHC.Core.Unify (tcUnifyTy) 23 | import GHC.Plugins (Outputable (ppr), Plugin (pluginRecompile, tcPlugin), PredType, 24 | Role (Nominal), TCvSubst, Type, defaultPlugin, eqType, fsLit, mkModuleName, 25 | mkTcOcc, nonDetCmpType, purePlugin, showSDocUnsafe, splitAppTys, substTys, 26 | tyConClass_maybe) 27 | import GHC.Tc.Plugin (tcLookupClass, tcPluginIO) 28 | import GHC.Tc.Solver.Monad (newWantedEq, runTcSDeriveds) 29 | import GHC.Tc.Types (TcM, TcPlugin (TcPlugin, tcPluginInit, tcPluginSolve, tcPluginStop), 30 | TcPluginM, TcPluginResult (TcPluginOk), unsafeTcPluginTcM) 31 | import GHC.Tc.Types.Constraint (Ct (CDictCan, CNonCanonical), CtEvidence (CtWanted), CtLoc, ctPred) 32 | import GHC.Tc.Utils.Env (tcGetInstEnvs) 33 | import GHC.Tc.Utils.TcType (tcSplitTyConApp) 34 | 35 | #else 36 | import Class (Class) 37 | #if __GLASGOW_HASKELL__ >= 810 38 | import Constraint (Ct (CDictCan, CNonCanonical), CtEvidence (CtWanted), CtLoc, ctPred) 39 | #endif 40 | import GhcPlugins (Outputable (ppr), Plugin (pluginRecompile, tcPlugin), PredType, 41 | Role (Nominal), TCvSubst, Type, defaultPlugin, eqType, fsLit, mkModuleName, 42 | mkTcOcc, nonDetCmpType, purePlugin, showSDocUnsafe, splitAppTys, substTys, 43 | tyConClass_maybe) 44 | import InstEnv (InstEnvs, lookupInstEnv) 45 | import TcEnv (tcGetInstEnvs) 46 | import TcPluginM (tcLookupClass, tcPluginIO) 47 | import TcRnTypes 48 | import TcSMonad (newWantedEq, runTcSDeriveds) 49 | import TcType (tcSplitTyConApp) 50 | import Unify (tcUnifyTy) 51 | #endif 52 | 53 | -- | A list of unique, unambiguous Haskell names in the format of @(packageName, moduleName, identifier)@. 54 | type Names = [(String, String, String)] 55 | 56 | -- | Make a @polysemy-plugin@-style effect disambiguation plugin that applies to all the "element-of" typeclasses 57 | -- passed in. Each of the names passed in should have type @k -> [k] -> 'Data.Kind.Type'@ where @k@ can be either 58 | -- polymorphic or monomorphic. 59 | -- 60 | -- Some examples include: 61 | -- 62 | -- @ 63 | -- (\"cleff\", \"Cleff.Internal.Rec\", \":>\") 64 | -- (\"polysemy\", \"Polysemy.Internal.Union\", \"Member\") 65 | -- (\"effectful\", \"Effectful.Internal.Effect\", \":>\") 66 | -- @ 67 | -- 68 | -- You can see the source code for notes on the implementation of the plugin. 69 | makePlugin :: Names -> Plugin 70 | makePlugin names = defaultPlugin 71 | { tcPlugin = const (Just $ fakedep names) 72 | , pluginRecompile = purePlugin 73 | } 74 | 75 | fakedep :: Names -> TcPlugin 76 | fakedep names = TcPlugin 77 | { tcPluginInit = initFakedep names 78 | , tcPluginSolve = solveFakedepForAllElemClasses 79 | , tcPluginStop = const $ pure () 80 | } 81 | 82 | liftTc :: TcM a -> TcPluginM a 83 | liftTc = unsafeTcPluginTcM 84 | 85 | liftIo :: IO a -> TcPluginM a 86 | liftIo = tcPluginIO 87 | type VisitedSet = Set (OrdType, OrdType) 88 | 89 | initFakedep :: Names -> TcPluginM ([Class], IORef VisitedSet) 90 | initFakedep names = do 91 | classes <- for names \(packageName, elemModuleName, elemClassName) -> do 92 | recMod <- lookupModule (mkModuleName elemModuleName) $ fsLit packageName 93 | nm <- lookupName recMod $ mkTcOcc elemClassName 94 | tcLookupClass nm 95 | visited <- liftIo $ newIORef Set.empty 96 | pure (classes, visited) 97 | 98 | data FakedepGiven = FakedepGiven 99 | { givenEffHead :: Type 100 | , givenEff :: Type 101 | , givenEs :: Type 102 | } 103 | 104 | instance Show FakedepGiven where 105 | show (FakedepGiven _ e es) = "(Elem " <> showSDocUnsafe (ppr e) <> " " <> showSDocUnsafe (ppr es) <> ")" 106 | 107 | data FakedepWanted = FakedepWanted FakedepGiven CtLoc 108 | 109 | instance Show FakedepWanted where 110 | show (FakedepWanted given _) = show given 111 | 112 | newtype OrdType = OrdType { unOrdType :: Type } 113 | 114 | instance Eq OrdType where 115 | (==) = eqType `on` unOrdType 116 | 117 | instance Ord OrdType where 118 | compare = nonDetCmpType `on` unOrdType 119 | 120 | solveFakedepForAllElemClasses :: ([Class], IORef VisitedSet) -> [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginResult 121 | solveFakedepForAllElemClasses (elemClasses, visitedRef) givens _ wanteds = do 122 | solns <- concat <$> for elemClasses \elemCls -> solveFakedep (elemCls, visitedRef) givens wanteds 123 | pure $ TcPluginOk [] solns 124 | 125 | solveFakedep :: (Class, IORef VisitedSet) -> [Ct] -> [Ct] -> TcPluginM [Ct] 126 | solveFakedep _ _ [] = pure [] 127 | solveFakedep (elemCls, visitedRef) allGivens allWanteds = do 128 | -- We're given two lists of constraints here: 129 | -- - 'allGivens' are constraints already in our context, 130 | -- - 'allWanteds' are constraints that need to be solved. 131 | -- In the following notes, the words "give/given" and "want/wanted" all refer to this specific technical concept: 132 | -- given constraints are those that we can use, and wanted constraints are those that we need to solve. 133 | let 134 | -- The only type of constraint we're interested in solving are 'Elem e es' constraints. Therefore, we extract these 135 | -- constraints out of the 'allGivens' and 'allWanted's. 136 | givens = mapMaybe relevantGiven allGivens 137 | wanteds = mapMaybe relevantWanted allWanteds 138 | -- We store a list of the types of all given constraints, which will be useful later. 139 | allGivenTypes = ctPred <$> allGivens 140 | -- We also store a list of wanted constraints that are /not/ 'Elem e es' for later use. 141 | extraWanteds = ctPred <$> filter irrelevant allWanteds 142 | 143 | -- traceM $ "Givens: " <> show (showSDocUnsafe . ppr <$> allGivens) 144 | -- traceM $ "Wanteds: " <> show (showSDocUnsafe . ppr <$> allWanteds) 145 | 146 | -- For each 'Elem e es' we /want/ to solve (the "goal"), we need to eventually correspond it to another unique 147 | -- /given/ 'Elem e es' that will make the program typecheck (the "solution"). 148 | globals <- liftTc tcGetInstEnvs -- Get the global instances environment for later use 149 | let solns = mapMaybe (solve globals allGivenTypes extraWanteds givens) wanteds 150 | 151 | -- Now we need to tell GHC the solutions. The way we do this is to generate a new equality constraint, like 152 | -- 'Elem (State e) es ~ Elem (State Int) es', so that GHC's constraint solver will know that 'e' must be 'Int'. 153 | eqns <- for solns \(FakedepWanted (FakedepGiven _ goalEff _) loc, FakedepGiven _ solnEff _) -> do 154 | (eqn, _) <- liftTc $ runTcSDeriveds $ newWantedEq loc Nominal goalEff solnEff 155 | pure (CNonCanonical eqn, (OrdType goalEff, OrdType solnEff)) 156 | 157 | -- For any solution we've generated, we need to be careful not to generate it again, or we might end up generating 158 | -- infinitely many solutions. So, we record any already generated solution in a set. 159 | visitedSolnPairs <- liftIo $ readIORef visitedRef 160 | let solnEqns = fst <$> flip filter eqns \(_, pair) -> Set.notMember pair visitedSolnPairs 161 | liftIo $ modifyIORef visitedRef (Set.union $ Set.fromList $ snd <$> eqns) 162 | 163 | -- traceM $ "Emitting: " <> showSDocUnsafe (ppr solnEqns) 164 | pure solnEqns -- Finally we tell GHC the solutions. 165 | 166 | where 167 | 168 | -- Determine if there is a unique solution to a goal from a set of candidates. 169 | solve :: InstEnvs -> [PredType] -> [PredType] -> [FakedepGiven] -> FakedepWanted -> Maybe (FakedepWanted, FakedepGiven) 170 | solve globals allGivenTypes extraWanteds givens goal@(FakedepWanted (FakedepGiven _ _ goalEs) _) = 171 | let 172 | -- Apart from 'Elem' constraints in the context, the effects already hardwired into the effect stack type, 173 | -- like those in 'A : B : C : es', also need to be considered. So here we extract that for them to be considered 174 | -- simultaneously with regular 'Elem' constraints. 175 | cands = extractExtraGivens goalEs goalEs <> givens 176 | -- The first criteria is that the candidate constraint must /unify/ with the goal. This means that the type 177 | -- variables in the goal can be instantiated in a way so that the goal becomes equal to the candidate. 178 | -- For example, the candidates 'Elem (State Int) es' and 'Elem (State String) es' both unify with the goal 179 | -- 'Elem (State s) es'. 180 | unifiableCands = mapMaybe (unifiableWith goal) cands 181 | in case unifiableCands of 182 | -- If there's already only one unique solution, commit to it; in the worst case where it doesn't actually match, 183 | -- we get a cleaner error message like "Unable to match (State String) to (State Int)" instead of a type 184 | -- ambiguity error. 185 | [(soln, _)] -> Just (goal, soln) 186 | _ -> 187 | -- Otherwise, the second criteria comes in: the candidate must satisfy all other constraints we /want/ to solve. 188 | -- For example, when we want to solve '(Elem (State a) es, Num a)`, the candidate 'Elem (State Int) es' will do 189 | -- the job, because it satisfied 'Num a'; however 'Elem (State String) es' will be excluded. 190 | let satisfiableCands = filter (satisfiable globals allGivenTypes extraWanteds) unifiableCands 191 | -- Finally, if there is a unique candidate remaining, we use it as the solution; otherwise we don't solve anything. 192 | in case satisfiableCands of 193 | [(soln, _)] -> Just (goal, soln) 194 | _ -> Nothing 195 | 196 | -- Extract the heads of a type like 'A : B : C : es' into 'FakedepGiven's. 197 | extractExtraGivens :: Type -> Type -> [FakedepGiven] 198 | extractExtraGivens fullEs es = case splitAppTys es of 199 | (_colon, [_kind, e, es']) -> 200 | let (dtHead, _tyArgs) = splitAppTys e 201 | in FakedepGiven dtHead e fullEs : extractExtraGivens fullEs es' 202 | _ -> [] 203 | 204 | -- Determine whether a given constraint is of form 'Elem e es'. 205 | relevantGiven :: Ct -> Maybe FakedepGiven 206 | relevantGiven (CDictCan _ cls [_kind, eff, es] _) -- Polymorphic case 207 | | cls == elemCls = Just $ FakedepGiven (fst $ splitAppTys eff) eff es 208 | relevantGiven (CDictCan _ cls [eff, es] _) -- Monomorphic case 209 | | cls == elemCls = Just $ FakedepGiven (fst $ splitAppTys eff) eff es 210 | relevantGiven _ = Nothing 211 | 212 | -- Determine whether a wanted constraint is of form 'Elem e es'. 213 | relevantWanted :: Ct -> Maybe FakedepWanted 214 | relevantWanted (CDictCan (CtWanted _ _ _ loc) cls [_kind, eff, es] _) -- Polymorphic case 215 | | cls == elemCls = Just $ FakedepWanted (FakedepGiven (fst $ splitAppTys eff) eff es) loc 216 | relevantWanted (CDictCan (CtWanted _ _ _ loc) cls [eff, es] _) -- Monomorphic case 217 | | cls == elemCls = Just $ FakedepWanted (FakedepGiven (fst $ splitAppTys eff) eff es) loc 218 | relevantWanted _ = Nothing 219 | 220 | -- Determine whether a constraint is /not/ of form 'Elem e es'. 221 | irrelevant :: Ct -> Bool 222 | irrelevant = isNothing . relevantGiven 223 | 224 | -- Given a wanted constraint and a given constraint, unify them and give back a substitution that can be applied 225 | -- to the wanted to make it equal to the given. 226 | unifiableWith :: FakedepWanted -> FakedepGiven -> Maybe (FakedepGiven, TCvSubst) 227 | unifiableWith (FakedepWanted goal _) cand = 228 | -- First, the 'es' type must be equal, and the datatype head of the effect must be equal too. 229 | if givenEs goal `eqType` givenEs cand && givenEffHead goal `eqType` givenEffHead cand 230 | then (cand, ) <$> tcUnifyTy (givenEff goal) (givenEff cand) -- Then the effect type must unify. 231 | else Nothing 232 | 233 | -- Check whether a candidate can satisfy all tthe wanted constraints. 234 | satisfiable :: InstEnvs -> [PredType] -> [PredType] -> (FakedepGiven, TCvSubst) -> Bool 235 | satisfiable globals givens wanteds (_, subst) = 236 | let 237 | wantedsInst = substTys subst wanteds -- The wanteds after unification. 238 | givensInst = Set.fromList $ OrdType <$> substTys subst givens -- The local given context after unification. 239 | in flip all wantedsInst \want -> 240 | if Set.member (OrdType want) givensInst then True -- Can we find this constraint in our local context? 241 | else let (con, args) = tcSplitTyConApp want 242 | in case tyConClass_maybe con of -- If not, lookup the global environment. 243 | Nothing -> False 244 | Just cls -> let (res, _, _) = lookupInstEnv False globals cls args in not $ null res 245 | --------------------------------------------------------------------------------