├── .gitignore ├── .hlint.yaml ├── .stylish-haskell.yaml ├── LICENSE ├── README.md ├── bench ├── BenchCatch.hs ├── BenchCountdown.hs ├── BenchLocal.hs ├── BenchPyth.hs └── Main.hs ├── cabal.project ├── docs ├── InScope.pdf └── img │ └── bench │ ├── catch.svg │ ├── countdown.svg │ ├── local.svg │ └── pyth.svg ├── hie.yaml ├── speff.cabal └── src └── Sp ├── Eff.hs ├── Eff └── Exception.hs ├── Error.hs ├── Internal ├── Ctl │ ├── Monadic.hs │ └── Native.hs ├── Env.hs ├── Handle.hs ├── Monad.hs └── Vec.hs ├── NonDet.hs ├── Reader.hs ├── State.hs └── Writer.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | dist/ 3 | dist-newstyle/ 4 | *~ 5 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - ignore: "Eta reduce" 2 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | steps: 2 | - module_header: 3 | indent: 2 4 | sort: false 5 | break_where: inline 6 | 7 | - simple_align: {} 8 | 9 | - imports: 10 | list_padding: 2 11 | 12 | - language_pragmas: {} 13 | 14 | - trailing_whitespace: {} 15 | 16 | columns: 120 17 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (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 Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this 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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Sp.Eff 2 | 3 | Sp is the effects library that accompanies the [HOPE '22](https://icfp22.sigplan.org/home/hope-2022) talk *Effect Handlers in Scope, Evidently*. 4 | 5 | Sp is implemented with the technique known in the Haskell community as the "[ReaderT pattern]", and in literature as "evidence passing" ([Xie et al 2020]). Basically, effect handlers are stored in a vector that is passed around in the program, so any call to effect operations is local. This makes the effect system more efficient than other traditionally used approaches, like `mtl`-style and free(r) monads. 6 | 7 | Compared to [Xie et al 2020], Sp uses *arrays*, instead of lists, to implement the vector of handlers ("evidence vector"). In practice this is more efficient in most cases, because calling effect operations (reading from the vector), which is much more frequent, is O(1) rather than O(n). 8 | 9 | The main feature of Sp is that it supports *scoped effects*, i.e. effect operations that can accept not only *values*, but also *computations*. The effect handler can call the computations multiple times (just like multi-shot resumptions), or change the behavior of the current effect inside the computation. 10 | 11 | Sp uses a modified version of the multi-shot delimited control monad `Ctl` implemented in [Ev.Eff](https://hackage.haskell.org/package/eveff). The modified version supports embedding any first-order IO operations; the performance overhead is not detrimental. In our benchmarks, Sp performs better than many other popular effects libraries like `polysemy` and `fused-effects`, as well as Ev. Other parts of Sp is based on `cleff`, which uses a similar evidence-passing approach without delimited control, but with other useful features in production. 12 | 13 | On the theory side, Sp demonstrates how to combine evidence-passing semantics with scoped effects. On the application side, Sp shows how to optimize evidence-passing in Haskell and how to integrate IO in an evidence-passing system. An implementation similar to Sp but instead based on [GHC native delcont] could be better suited for production in the future. 14 | 15 | [ReaderT pattern]: https://www.fpcomplete.com/blog/2017/06/readert-design-pattern/ 16 | [Xie et al 2020]: https://dl.acm.org/doi/10.1145/3408981 17 | [GHC native delcont]: https://gitlab.haskell.org/ghc/ghc/-/merge_requests/7942 -------------------------------------------------------------------------------- /bench/BenchCatch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- Benchmarking scoped effects #1: Catching errors 3 | module BenchCatch where 4 | 5 | import qualified Control.Carrier.Error.Either as F 6 | import qualified Control.Carrier.Reader as F 7 | #if SPEFF_BENCH_EFFECTFUL 8 | import qualified Effectful as EL 9 | import qualified Effectful.Error.Dynamic as EL 10 | import qualified Effectful.Reader.Dynamic as EL 11 | #endif 12 | import qualified Polysemy as P 13 | import qualified Polysemy.Error as P 14 | import qualified Polysemy.Reader as P 15 | import qualified Sp.Eff as S 16 | import qualified Sp.Error as S 17 | import qualified Sp.Reader as S 18 | 19 | programSp :: S.Error () S.:> es => Int -> S.Eff es a 20 | programSp = \case 21 | 0 -> S.throwError () 22 | n -> S.catchError (programSp (n - 1)) \() -> S.throwError () 23 | {-# NOINLINE programSp #-} 24 | 25 | catchSp :: Int -> Either () () 26 | catchSp n = S.runEff $ S.runError $ programSp n 27 | 28 | catchSpDeep :: Int -> Either () () 29 | catchSpDeep n = S.runEff $ run $ run $ run $ run $ run $ S.runError $ run $ run $ run $ run $ run $ programSp n 30 | where run = S.runReader () 31 | 32 | #if SPEFF_BENCH_EFFECTFUL 33 | programEffectful :: EL.Error () EL.:> es => Int -> EL.Eff es a 34 | programEffectful = \case 35 | 0 -> EL.throwError () 36 | n -> EL.catchError (programEffectful (n - 1)) \_ () -> EL.throwError () 37 | {-# NOINLINE programEffectful #-} 38 | 39 | catchEffectful :: Int -> Either (EL.CallStack, ()) () 40 | catchEffectful n = EL.runPureEff $ EL.runError $ programEffectful n 41 | 42 | catchEffectfulDeep :: Int -> Either (EL.CallStack, ()) () 43 | catchEffectfulDeep n = 44 | EL.runPureEff $ run $ run $ run $ run $ run $ EL.runError $ run $ run $ run $ run $ run $ programEffectful n 45 | where run = EL.runReader () 46 | #endif 47 | 48 | programFused :: F.Has (F.Error ()) sig m => Int -> m a 49 | programFused = \case 50 | 0 -> F.throwError () 51 | n -> F.catchError (programFused (n - 1)) \() -> F.throwError () 52 | {-# NOINLINE programFused #-} 53 | 54 | catchFused :: Int -> Either () () 55 | catchFused n = F.run $ F.runError $ programFused n 56 | 57 | catchFusedDeep :: Int -> Either () () 58 | catchFusedDeep n = F.run $ run $ run $ run $ run $ run $ F.runError $ run $ run $ run $ run $ run $ programFused n 59 | where run = F.runReader () 60 | 61 | programSem :: P.Error () `P.Member` es => Int -> P.Sem es a 62 | programSem = \case 63 | 0 -> P.throw () 64 | n -> P.catch (programSem (n - 1)) \() -> P.throw () 65 | {-# NOINLINE programSem #-} 66 | 67 | catchSem :: Int -> Either () () 68 | catchSem n = P.run $ P.runError $ programSem n 69 | 70 | catchSemDeep :: Int -> Either () () 71 | catchSemDeep n = P.run $ run $ run $ run $ run $ run $ P.runError $ run $ run $ run $ run $ run $ programSem n 72 | where run = P.runReader () 73 | -------------------------------------------------------------------------------- /bench/BenchCountdown.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- Benchmarking effect invocation and monadic bind 3 | module BenchCountdown where 4 | 5 | import qualified Control.Carrier.Reader as F 6 | import qualified Control.Carrier.State.Strict as F 7 | import qualified Control.Ev.Eff as E 8 | import qualified Control.Ev.Util as E 9 | #ifdef SPEFF_BENCH_FREER_SIMPLE 10 | import qualified Control.Monad.Freer as FS 11 | import qualified Control.Monad.Freer.Reader as FS 12 | import qualified Control.Monad.Freer.State as FS 13 | #endif 14 | import qualified Control.Monad.Identity as M 15 | import qualified Control.Monad.Reader as M 16 | import qualified Control.Monad.State.Strict as M 17 | #if SPEFF_BENCH_EFFECTFUL 18 | import qualified Effectful as EL 19 | import qualified Effectful.Reader.Dynamic as EL 20 | import qualified Effectful.State.Dynamic as EL 21 | #endif 22 | import qualified Polysemy as P 23 | import qualified Polysemy.Reader as P 24 | import qualified Polysemy.State as P 25 | import qualified Sp.Eff as S 26 | import qualified Sp.Reader as S 27 | import qualified Sp.State as S 28 | 29 | programSp :: S.State Int S.:> es => S.Eff es Int 30 | programSp = do 31 | x <- S.get @Int 32 | if x == 0 33 | then pure x 34 | else do 35 | S.put (x - 1) 36 | programSp 37 | {-# NOINLINE programSp #-} 38 | 39 | countdownSp :: Int -> (Int, Int) 40 | countdownSp n = S.runEff $ S.runState n programSp 41 | 42 | countdownSpDeep :: Int -> (Int, Int) 43 | countdownSpDeep n = S.runEff $ runR $ runR $ runR $ runR $ runR $ S.runState n $ runR $ runR $ runR $ runR $ runR $ programSp 44 | where runR = S.runReader () 45 | 46 | #if SPEFF_BENCH_EFFECTFUL 47 | programEffectful :: EL.State Int EL.:> es => EL.Eff es Int 48 | programEffectful = do 49 | x <- EL.get @Int 50 | if x == 0 51 | then pure x 52 | else do 53 | EL.put (x - 1) 54 | programEffectful 55 | {-# NOINLINE programEffectful #-} 56 | 57 | countdownEffectful :: Int -> (Int, Int) 58 | countdownEffectful n = EL.runPureEff $ EL.runStateLocal n programEffectful 59 | 60 | countdownEffectfulDeep :: Int -> (Int, Int) 61 | countdownEffectfulDeep n = 62 | EL.runPureEff $ runR $ runR $ runR $ runR $ runR $ EL.runStateLocal n $ runR $ runR $ runR $ runR $ runR $ programEffectful 63 | where runR = EL.runReader () 64 | #endif 65 | 66 | programEv :: E.State Int E.:? es => E.Eff es Int 67 | programEv = do 68 | x <- E.perform (E.get @Int) () 69 | if x == 0 70 | then pure x 71 | else do 72 | E.perform E.put (x - 1) 73 | programEv 74 | {-# NOINLINE programEv #-} 75 | 76 | countdownEv :: Int -> Int 77 | countdownEv n = E.runEff $ E.state n programEv 78 | 79 | countdownEvDeep :: Int -> Int 80 | countdownEvDeep n = E.runEff $ runR $ runR $ runR $ runR $ runR $ E.state n $ runR $ runR $ runR $ runR $ runR $ programEv 81 | where runR = E.reader () 82 | 83 | #ifdef SPEFF_BENCH_FREER_SIMPLE 84 | programFreer :: FS.Member (FS.State Int) es => FS.Eff es Int 85 | programFreer = do 86 | x <- FS.get @Int 87 | if x == 0 88 | then pure x 89 | else do 90 | FS.put (x - 1) 91 | programFreer 92 | {-# NOINLINE programFreer #-} 93 | 94 | countdownFreer :: Int -> (Int, Int) 95 | countdownFreer n = FS.run $ FS.runState n programFreer 96 | 97 | countdownFreerDeep :: Int -> (Int, Int) 98 | countdownFreerDeep n = FS.run $ runR $ runR $ runR $ runR $ runR $ FS.runState n $ runR $ runR $ runR $ runR $ runR $ programFreer 99 | where runR = FS.runReader () 100 | #endif 101 | 102 | programMtl :: M.MonadState Int m => m Int 103 | programMtl = do 104 | x <- M.get @Int 105 | if x == 0 106 | then pure x 107 | else do 108 | M.put (x - 1) 109 | programMtl 110 | {-# NOINLINE programMtl #-} 111 | 112 | countdownMtl :: Int -> (Int, Int) 113 | countdownMtl n = M.runState programMtl n 114 | 115 | countdownMtlDeep :: Int -> (Int, Int) 116 | countdownMtlDeep n = M.runIdentity $ runR $ runR $ runR $ runR $ runR $ M.runStateT (runR $ runR $ runR $ runR $ runR $ programMtl) n 117 | where runR = (`M.runReaderT` ()) 118 | 119 | programFused :: F.Has (F.State Int) sig m => m Int 120 | programFused = do 121 | x <- F.get @Int 122 | if x == 0 123 | then pure x 124 | else do 125 | F.put (x - 1) 126 | programFused 127 | {-# NOINLINE programFused #-} 128 | 129 | countdownFused :: Int -> (Int, Int) 130 | countdownFused n = F.run $ F.runState n programFused 131 | 132 | countdownFusedDeep :: Int -> (Int, Int) 133 | countdownFusedDeep n = F.run $ runR $ runR $ runR $ runR $ runR $ F.runState n $ runR $ runR $ runR $ runR $ runR $ programFused 134 | where runR = F.runReader () 135 | 136 | programSem :: P.Member (P.State Int) es => P.Sem es Int 137 | programSem = do 138 | x <- P.get @Int 139 | if x == 0 140 | then pure x 141 | else do 142 | P.put (x - 1) 143 | programSem 144 | {-# NOINLINE programSem #-} 145 | 146 | countdownSem :: Int -> (Int, Int) 147 | countdownSem n = P.run $ P.runState n programSem 148 | 149 | countdownSemDeep :: Int -> (Int, Int) 150 | countdownSemDeep n = P.run $ runR $ runR $ runR $ runR $ runR $ P.runState n $ runR $ runR $ runR $ runR $ runR $ programSem 151 | where runR = P.runReader () 152 | -------------------------------------------------------------------------------- /bench/BenchLocal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- Benchmarking scoped effects #2: Local environments 3 | module BenchLocal where 4 | 5 | import qualified Control.Carrier.Error.Either as F 6 | import qualified Control.Carrier.Reader as F 7 | #if SPEFF_BENCH_EFFECTFUL 8 | import qualified Effectful as EL 9 | import qualified Effectful.Reader.Dynamic as EL 10 | #endif 11 | import qualified Polysemy as P 12 | import qualified Polysemy.Reader as P 13 | import qualified Sp.Eff as S 14 | import qualified Sp.Reader as S 15 | 16 | programSp :: S.Reader Int S.:> es => Int -> S.Eff es Int 17 | programSp = \case 18 | 0 -> S.ask 19 | n -> S.local @Int (+1) (programSp (n - 1)) 20 | {-# NOINLINE programSp #-} 21 | 22 | localSp :: Int -> Int 23 | localSp n = S.runEff $ S.runReader @Int 0 $ programSp n 24 | 25 | localSpDeep :: Int -> Int 26 | localSpDeep n = S.runEff $ run $ run $ run $ run $ run $ S.runReader @Int 0 $ run $ run $ run $ run $ run $ programSp n 27 | where run = S.runReader () 28 | 29 | #if SPEFF_BENCH_EFFECTFUL 30 | programEffectful :: EL.Reader Int EL.:> es => Int -> EL.Eff es Int 31 | programEffectful = \case 32 | 0 -> EL.ask 33 | n -> EL.local @Int (+1) (programEffectful (n - 1)) 34 | {-# NOINLINE programEffectful #-} 35 | 36 | localEffectful :: Int -> Int 37 | localEffectful n = EL.runPureEff $ EL.runReader @Int 0 $ programEffectful n 38 | 39 | localEffectfulDeep :: Int -> Int 40 | localEffectfulDeep n = 41 | EL.runPureEff $ run $ run $ run $ run $ run $ EL.runReader @Int 0 $ run $ run $ run $ run $ run $ programEffectful n 42 | where run = EL.runReader () 43 | #endif 44 | 45 | programFused :: F.Has (F.Reader Int) sig m => Int -> m Int 46 | programFused = \case 47 | 0 -> F.ask 48 | n -> F.local @Int (+1) (programFused (n - 1)) 49 | {-# NOINLINE programFused #-} 50 | 51 | localFused :: Int -> Int 52 | localFused n = F.run $ F.runReader @Int 0 $ programFused n 53 | 54 | localFusedDeep :: Int -> Int 55 | localFusedDeep n = F.run $ run $ run $ run $ run $ run $ F.runReader @Int 0 $ run $ run $ run $ run $ run $ programFused n 56 | where run = F.runReader () 57 | 58 | programSem :: P.Reader Int `P.Member` es => Int -> P.Sem es Int 59 | programSem = \case 60 | 0 -> P.ask 61 | n -> P.local @Int (+1) (programSem (n - 1)) 62 | {-# NOINLINE programSem #-} 63 | 64 | localSem :: Int -> Int 65 | localSem n = P.run $ P.runReader @Int 0 $ programSem n 66 | 67 | localSemDeep :: Int -> Int 68 | localSemDeep n = P.run $ run $ run $ run $ run $ run $ P.runReader @Int 0 $ run $ run $ run $ run $ run $ programSem n 69 | where run = P.runReader () 70 | -------------------------------------------------------------------------------- /bench/BenchPyth.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- Benchmarking yield-intensive code 3 | module BenchPyth where 4 | 5 | import qualified Control.Algebra as F 6 | import Control.Applicative (Alternative (empty, (<|>))) 7 | import qualified Control.Carrier.NonDet.Church as F 8 | import qualified Control.Carrier.Reader as F 9 | import qualified Control.Ev.Eff as E 10 | import qualified Control.Ev.Util as E 11 | #ifdef SPEFF_BENCH_FREER_SIMPLE 12 | import qualified Control.Monad.Freer as FS 13 | import qualified Control.Monad.Freer.NonDet as FS 14 | import qualified Control.Monad.Freer.Reader as FS 15 | #endif 16 | import qualified Polysemy as P 17 | import qualified Polysemy.NonDet as P 18 | import qualified Polysemy.Reader as P 19 | import qualified Sp.Eff as S 20 | import qualified Sp.NonDet as S 21 | import qualified Sp.Reader as S 22 | 23 | programSp :: (S.NonDet S.:> e) => Int -> S.Eff e (Int, Int, Int) 24 | programSp upbound = do 25 | x <- S.choice [1..upbound] 26 | y <- S.choice [1..upbound] 27 | z <- S.choice [1..upbound] 28 | if x*x + y*y == z*z then return (x,y,z) else S.send S.Empty 29 | {-# NOINLINE programSp #-} 30 | 31 | pythSp :: Int -> [(Int, Int, Int)] 32 | pythSp n = S.runEff $ S.runNonDet $ programSp n 33 | 34 | pythSpDeep :: Int -> [(Int, Int, Int)] 35 | pythSpDeep n = S.runEff $ run $ run $ run $ run $ run $ S.runNonDet $ run $ run $ run $ run $ run $ programSp n 36 | where run = S.runReader () 37 | 38 | programEv :: (E.Choose E.:? e) => Int -> E.Eff e (Int, Int, Int) 39 | programEv upbound = do 40 | x <- E.perform E.choose upbound 41 | y <- E.perform E.choose upbound 42 | z <- E.perform E.choose upbound 43 | if x*x + y*y == z*z then return (x,y,z) else E.perform (\r -> E.none r) () 44 | {-# NOINLINE programEv #-} 45 | 46 | pythEv :: Int -> [(Int, Int, Int)] 47 | pythEv n = E.runEff $ E.chooseAll $ programEv n 48 | 49 | pythEvDeep :: Int -> [(Int, Int, Int)] 50 | pythEvDeep n = E.runEff $ run $ run $ run $ run $ run $ E.chooseAll $ run $ run $ run $ run $ run $ programEv n 51 | where run = E.reader () 52 | 53 | #ifdef SPEFF_BENCH_FREER_SIMPLE 54 | programFreer :: FS.Member FS.NonDet es => Int -> FS.Eff es (Int, Int, Int) 55 | programFreer upbound = do 56 | x <- choice upbound 57 | y <- choice upbound 58 | z <- choice upbound 59 | if x*x + y*y == z*z then return (x,y,z) else empty 60 | where 61 | choice 0 = empty 62 | choice n = choice (n - 1) <|> pure n 63 | {-# NOINLINE programFreer #-} 64 | 65 | pythFreer :: Int -> [(Int, Int, Int)] 66 | pythFreer n = FS.run $ FS.makeChoiceA $ programFreer n 67 | 68 | pythFreerDeep :: Int -> [(Int, Int, Int)] 69 | pythFreerDeep n = FS.run $ run $ run $ run $ run $ run $ FS.makeChoiceA $ run $ run $ run $ run $ run $ programFreer n 70 | where run = FS.runReader () 71 | #endif 72 | 73 | programFused :: (Monad m, Alternative m) => Int -> m (Int, Int, Int) 74 | programFused upbound = do 75 | x <- choice upbound 76 | y <- choice upbound 77 | z <- choice upbound 78 | if x*x + y*y == z*z then return (x,y,z) else empty 79 | where choice x = F.oneOf [1..x] 80 | {-# NOINLINE programFused #-} 81 | 82 | pythFused :: Int -> [(Int, Int, Int)] 83 | pythFused n = F.run $ F.runNonDetA $ programFused n 84 | 85 | pythFusedDeep :: Int -> [(Int, Int, Int)] 86 | pythFusedDeep n = F.run $ run $ run $ run $ run $ run $ F.runNonDetA $ run $ run $ run $ run $ run $ programFused n 87 | where run = F.runReader () 88 | 89 | programSem :: P.Member P.NonDet es => Int -> P.Sem es (Int, Int, Int) 90 | programSem upbound = do 91 | x <- choice upbound 92 | y <- choice upbound 93 | z <- choice upbound 94 | if x*x + y*y == z*z then return (x,y,z) else empty 95 | where 96 | choice 0 = empty 97 | choice n = choice (n - 1) <|> pure n 98 | {-# NOINLINE programSem #-} 99 | 100 | pythSem :: Int -> [(Int, Int, Int)] 101 | pythSem n = P.run $ P.runNonDet $ programSem n 102 | 103 | pythSemDeep :: Int -> [(Int, Int, Int)] 104 | pythSemDeep n = P.run $ run $ run $ run $ run $ run $ P.runNonDet $ run $ run $ run $ run $ run $ programSem n 105 | where run = P.runReader () 106 | -------------------------------------------------------------------------------- /bench/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main where 3 | 4 | import BenchCatch 5 | import BenchCountdown 6 | import BenchLocal 7 | import BenchPyth 8 | import Data.Functor ((<&>)) 9 | import Test.Tasty.Bench 10 | 11 | main :: IO () 12 | main = defaultMain 13 | [ bgroup "countdown" $ [10000] <&> \x -> bgroup (show x) 14 | [ bench "sp.shallow" $ nf countdownSp x 15 | , bench "sp.deep" $ nf countdownSpDeep x 16 | #if SPEFF_BENCH_EFFECTFUL 17 | , bench "effectful.shallow" $ nf countdownEffectful x 18 | , bench "effectful.deep" $ nf countdownEffectfulDeep x 19 | #endif 20 | , bench "ev.shallow" $ nf countdownEv x 21 | , bench "ev.deep" $ nf countdownEvDeep x 22 | #if SPEFF_BENCH_FREER_SIMPLE 23 | , bench "freer.shallow" $ nf countdownFreer x 24 | , bench "freer.deep" $ nf countdownFreerDeep x 25 | #endif 26 | , bench "mtl.shallow" $ nf countdownMtl x 27 | , bench "mtl.deep" $ nf countdownMtlDeep x 28 | , bench "fused.shallow" $ nf countdownFused x 29 | , bench "fused.deep" $ nf countdownFusedDeep x 30 | , bench "sem.shallow" $ nf countdownSem x 31 | , bench "sem.deep" $ nf countdownSemDeep x 32 | ] 33 | , bgroup "pyth" $ [32] <&> \x -> bgroup (show x) 34 | [ bench "sp.shallow" $ nf pythSp x 35 | , bench "sp.deep" $ nf pythSpDeep x 36 | , bench "ev.shallow" $ nf pythEv x 37 | , bench "ev.deep" $ nf pythEvDeep x 38 | #ifdef SPEFF_BENCH_FREER_SIMPLE 39 | , bench "freer.shallow" $ nf pythFreer x 40 | , bench "freer.deep" $ nf pythFreerDeep x 41 | #endif 42 | , bench "fused.shallow" $ nf pythFused x 43 | , bench "fused.deep" $ nf pythFusedDeep x 44 | , bench "sem.shallow" $ nf pythSem x 45 | , bench "sem.deep" $ nf pythSemDeep x 46 | ] 47 | , bgroup "catch" $ [10000] <&> \x -> bgroup (show x) 48 | [ bench "sp.shallow" $ nf catchSp x 49 | , bench "sp.deep" $ nf catchSpDeep x 50 | #if SPEFF_BENCH_EFFECTFUL 51 | , bench "effectful.shallow" $ nf catchEffectful x 52 | , bench "effectful.deep" $ nf catchEffectfulDeep x 53 | #endif 54 | , bench "fused.shallow" $ nf catchFused x 55 | , bench "fused.deep" $ nf catchFusedDeep x 56 | , bench "sem.shallow" $ nf catchSem x 57 | , bench "sem.deep" $ nf catchSemDeep x 58 | ] 59 | , bgroup "local" $ [10000] <&> \x -> bgroup (show x) 60 | [ bench "sp.shallow" $ nf localSp x 61 | , bench "sp.deep" $ nf localSpDeep x 62 | #if SPEFF_BENCH_EFFECTFUL 63 | , bench "effectful.shallow" $ nf localEffectful x 64 | , bench "effectful.deep" $ nf localEffectfulDeep x 65 | #endif 66 | , bench "fused.shallow" $ nf localFused x 67 | , bench "fused.deep" $ nf localFusedDeep x 68 | , bench "sem.shallow" $ nf localSem x 69 | , bench "sem.deep" $ nf localSemDeep x 70 | ] 71 | ] 72 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: speff.cabal 2 | jobs: $ncpus 3 | benchmarks: True 4 | 5 | package * 6 | ghc-options: -haddock 7 | 8 | if impl(ghc >= 9.4) 9 | allow-newer: freer-simple:template-haskell 10 | 11 | if impl(ghc >= 9.8) 12 | allow-newer: base 13 | -------------------------------------------------------------------------------- /docs/InScope.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/re-xyr/speff/705bf6949dcb78a5d486f68c628e42977660278e/docs/InScope.pdf -------------------------------------------------------------------------------- /docs/img/bench/catch.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | catch.1000000.sp.shallow 307 ms 4 | 5 | 307 ms ± 6.8 ms 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | catch.1000000.sp.deep 14 | 538 ms 15 | 16 | 17 | 538 ms ± 44 ms 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | catch.1000000.fused.shallow 26 | 725 ms 27 | 28 | 29 | 725 ms ± 52 ms 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | catch.1000000.fused.deep 38 | 1.983 s 39 | 40 | 41 | 1.983 s ± 128 ms 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | catch.1000000.sem.shallow 50 | 826 ms 51 | 52 | 53 | 826 ms ± 78 ms 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | catch.1000000.sem.deep 62 | 1.397 s 63 | 64 | 65 | 1.397 s ± 60 ms 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | -------------------------------------------------------------------------------- /docs/img/bench/countdown.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | countdown.1000000.sp.shallow 17.6 ms 4 | 5 | 17.6 ms ± 691 μs 6 | 7 | 8 | 9 | 10 | 11 | 12 | countdown.1000000.sp.deep 17.7 ms 13 | 14 | 17.7 ms ± 738 μs 15 | 16 | 17 | 18 | 19 | 20 | 21 | countdown.1000000.ev.shallow 37.6 ms 22 | 23 | 37.6 ms ± 3.6 ms 24 | 25 | 26 | 27 | 28 | 29 | 30 | countdown.1000000.ev.deep 38.4 ms 31 | 32 | 38.4 ms ± 2.2 ms 33 | 34 | 35 | 36 | 37 | 38 | 39 | countdown.1000000.freer.shallow 43.6 ms 40 | 41 | 43.6 ms ± 2.3 ms 42 | 43 | 44 | 45 | 46 | 47 | 48 | countdown.1000000.freer.deep 155 ms 49 | 50 | 155 ms ± 3.0 ms 51 | 52 | 53 | 54 | 55 | 56 | 57 | countdown.1000000.mtl.shallow 52.3 ms 58 | 59 | 52.3 ms ± 2.1 ms 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | countdown.1000000.mtl.deep 68 | 641 ms 69 | 70 | 71 | 641 ms ± 50 ms 72 | 73 | 74 | 75 | 76 | 77 | 78 | countdown.1000000.fused.shallow 101 ms 79 | 80 | 101 ms ± 8.0 ms 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | countdown.1000000.fused.deep 89 | 1.216 s 90 | 91 | 92 | 1.216 s ± 10 ms 93 | 94 | 95 | 96 | 97 | 98 | 99 | countdown.1000000.sem.shallow 245 ms 100 | 101 | 245 ms ± 7.6 ms 102 | 103 | 104 | 105 | 106 | 107 | 108 | countdown.1000000.sem.deep 346 ms 109 | 110 | 346 ms ± 13 ms 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | -------------------------------------------------------------------------------- /docs/img/bench/local.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | local.1000000.sp.shallow 63.5 ms 4 | 5 | 63.5 ms ± 2.9 ms 6 | 7 | 8 | 9 | 10 | 11 | 12 | local.1000000.sp.deep 67.6 ms 13 | 14 | 67.6 ms ± 3.4 ms 15 | 16 | 17 | 18 | 19 | 20 | 21 | local.1000000.fused.shallow 251 ms 22 | 23 | 251 ms ± 2.7 ms 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | local.1000000.fused.deep 32 | 564 ms 33 | 34 | 35 | 564 ms ± 17 ms 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | local.1000000.sem.shallow 44 | 730 ms 45 | 46 | 47 | 730 ms ± 44 ms 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | local.1000000.sem.deep 56 | 1.056 s 57 | 58 | 59 | 1.056 s ± 35 ms 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | -------------------------------------------------------------------------------- /docs/img/bench/pyth.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | pyth.128.sp.shallow 107 ms 4 | 5 | 107 ms ± 9.5 ms 6 | 7 | 8 | 9 | 10 | 11 | 12 | pyth.128.sp.deep 276 ms 13 | 14 | 276 ms ± 12 ms 15 | 16 | 17 | 18 | 19 | 20 | 21 | pyth.128.ev.shallow 119 ms 22 | 23 | 119 ms ± 8.1 ms 24 | 25 | 26 | 27 | 28 | 29 | 30 | pyth.128.ev.deep 287 ms 31 | 32 | 287 ms ± 4.5 ms 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | pyth.128.freer.shallow 41 | 675 ms 42 | 43 | 44 | 675 ms ± 30 ms 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | pyth.128.freer.deep 53 | 967 ms 54 | 55 | 56 | 967 ms ± 46 ms 57 | 58 | 59 | 60 | 61 | 62 | 63 | pyth.128.fused.shallow 76.8 ms 64 | 65 | 76.8 ms ± 2.3 ms 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | pyth.128.fused.deep 74 | 851 ms 75 | 76 | 77 | 851 ms ± 17 ms 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | pyth.128.sem.shallow 86 | 2.070 s 87 | 88 | 89 | 2.070 s ± 6.6 ms 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | pyth.128.sem.deep 98 | 2.070 s 99 | 100 | 101 | 2.070 s ± 9.9 ms 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | - path: "src" 4 | component: "lib:speff" 5 | - path: "bench" 6 | component: "speff:bench:speff-bench" 7 | -------------------------------------------------------------------------------- /speff.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: speff 3 | version: 0.1.0.0 4 | author: Xy Ren 5 | maintainer: xy.r@outlook.com 6 | license: BSD-3-Clause 7 | copyright: 2022 Xy Ren 8 | homepage: https://github.com/re-xyr/speff 9 | bug-reports: https://github.com/re-xyr/speff/issues 10 | category: Control, Effect, Language 11 | synopsis: Efficient higher-order effect handlers 12 | license-file: LICENSE 13 | extra-source-files: README.md 14 | tested-with: 15 | GHC ==8.6.5 16 | || ==8.8.4 17 | || ==8.10.7 18 | || ==9.0.2 19 | || ==9.2.8 20 | || ==9.4.8 21 | || ==9.6.3 22 | || ==9.8.1 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/re-xyr/speff 27 | 28 | common lang 29 | default-language: Haskell2010 30 | build-depends: 31 | , base >=4.12 && <4.20 32 | , exceptions ^>=0.10 33 | , primitive >=0.8 && <0.10 34 | 35 | ghc-options: 36 | -Wall -Widentities -Wincomplete-record-updates 37 | -Wincomplete-uni-patterns -Wno-unticked-promoted-constructors 38 | -Wpartial-fields -Wunused-type-patterns 39 | 40 | default-extensions: 41 | NoStarIsType 42 | BangPatterns 43 | BlockArguments 44 | ConstraintKinds 45 | DataKinds 46 | DeriveAnyClass 47 | DerivingVia 48 | EmptyCase 49 | FlexibleContexts 50 | FlexibleInstances 51 | FunctionalDependencies 52 | GADTs 53 | LambdaCase 54 | MagicHash 55 | PolyKinds 56 | RankNTypes 57 | RoleAnnotations 58 | ScopedTypeVariables 59 | TupleSections 60 | TypeApplications 61 | TypeFamilies 62 | TypeOperators 63 | UndecidableInstances 64 | UndecidableSuperClasses 65 | UnicodeSyntax 66 | 67 | common dump 68 | ghc-options: 69 | -ddump-simpl -ddump-to-file -dsuppress-all -dsuppress-uniques 70 | -ddump-hi 71 | 72 | flag native-delcont 73 | description: 74 | Build with native delimited continuation support from GHC 9.6+. This makes non-scoped tail-resumptive operations 75 | faster, but also makes scoped operations and (especially) operations that manipulate the control flow slower. 76 | 77 | default: False 78 | manual: True 79 | 80 | library 81 | import: lang, dump 82 | hs-source-dirs: src 83 | ghc-options: -fdicts-strict -flate-dmd-anal -fspec-constr 84 | exposed-modules: 85 | Sp.Eff 86 | Sp.Eff.Exception 87 | Sp.Error 88 | Sp.Internal.Env 89 | Sp.Internal.Monad 90 | Sp.Util 91 | Sp.NonDet 92 | Sp.Reader 93 | Sp.State 94 | Sp.Writer 95 | 96 | other-modules: 97 | Sp.Internal.Handle 98 | Sp.Internal.Vec 99 | 100 | if flag(native-delcont) 101 | cpp-options: -DSPEFF_NATIVE_DELCONT 102 | other-modules: Sp.Internal.Ctl.Native 103 | 104 | else 105 | other-modules: Sp.Internal.Ctl.Monadic 106 | 107 | benchmark speff-bench 108 | import: lang, dump 109 | type: exitcode-stdio-1.0 110 | hs-source-dirs: bench 111 | main-is: Main.hs 112 | ghc-options: -rtsopts -with-rtsopts=-T 113 | build-depends: 114 | , eveff ^>=1.0 115 | , freer-simple ^>=1.2 116 | , fused-effects ^>=1.1 117 | , mtl >=2.2 && <2.4 118 | , polysemy ^>=1.9 119 | , speff 120 | , tasty-bench ^>=0.3 121 | 122 | cpp-options: -DSPEFF_BENCH_FREER_SIMPLE 123 | 124 | if impl(ghc >=8.8) 125 | cpp-options: -DSPEFF_BENCH_EFFECTFUL 126 | build-depends: effectful-core ^>=2.3 127 | 128 | other-modules: 129 | BenchCatch 130 | BenchCountdown 131 | BenchLocal 132 | BenchPyth 133 | -------------------------------------------------------------------------------- /src/Sp/Eff.hs: -------------------------------------------------------------------------------- 1 | -- | 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 | -- 8 | -- Sp is an effect library supporting higher-order effects and scoped delimited control. It strives to be fast, sound, 9 | -- and easy to use. 10 | module Sp.Eff 11 | ( -- * Basic types and operations 12 | Effect 13 | , Eff 14 | , IOE 15 | , (:>) 16 | -- ** Performing effects 17 | , send 18 | -- ** Unwrapping 19 | , runIOE 20 | , runEff 21 | -- * Effect handling 22 | , HandleTag 23 | , Handler 24 | -- ** Providing handlers 25 | , Suffix 26 | , type (++) 27 | -- *** Interpret 28 | , Interpret 29 | , interpret 30 | , interpret0 31 | , interpret1 32 | , interpret2 33 | , interpret3 34 | , interpretN 35 | -- *** Interpose 36 | , Interpose 37 | , interpose 38 | , interpose0 39 | , interpose1 40 | , interpose2 41 | , interpose3 42 | , interposeN 43 | -- *** Replace 44 | , Replace 45 | , replace 46 | , replace0 47 | , replace1 48 | , replace2 49 | , replace3 50 | , replaceN 51 | -- ** Combinators to use in handlers 52 | , embed 53 | , withUnembed 54 | , abort 55 | , control 56 | , Localized 57 | -- * Trivial transformations 58 | , KnownList 59 | , KnownSubset 60 | -- ** Lift 61 | , Lift 62 | , lift 63 | , lift1 64 | , lift2 65 | , lift3 66 | , liftN 67 | -- ** Lift Under 68 | , LiftNUnder 69 | , liftUnder1 70 | , lift1Under1 71 | , lift2Under1 72 | , lift3Under1 73 | , liftNUnder1 74 | , LiftUnderN 75 | , lift1Under2 76 | , lift1Under3 77 | , lift1UnderN 78 | , liftNUnderN 79 | -- ** Subsume 80 | , Subsume 81 | , subsume1 82 | , subsume2 83 | , subsume3 84 | , subsumeN 85 | -- ** Miscellaneous 86 | , Subset 87 | , inject 88 | , rearrange 89 | , rearrangeN 90 | ) where 91 | 92 | import Sp.Internal.Env (KnownList, KnownSubset, Subset, Suffix, type (++), (:>)) 93 | import Sp.Internal.Handle 94 | import Sp.Internal.Monad 95 | -------------------------------------------------------------------------------- /src/Sp/Eff/Exception.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Copyright: (c) 2023 Xy Ren 3 | -- License: BSD3 4 | -- Maintainer: xy.r@outlook.com 5 | -- Stability: experimental 6 | -- Portability: non-portable (GHC only) 7 | -- 8 | -- Exception-related facilities for the @Eff@ monad. A large part are reexports of the barebones definitions from the 9 | -- @exceptions@ package; for saner defaults, consider using a wrapper package like @safe-exceptions@. 10 | module Sp.Eff.Exception 11 | ( -- * Throwing 12 | MonadThrow (throwM) 13 | -- * @bracket@-like operation 14 | , dynamicWind 15 | -- * Catching 16 | , MonadCatch (catch) 17 | , catchAll 18 | , catchIOError 19 | , catchJust 20 | , catchIf 21 | , Handler (..) 22 | , catches 23 | , handle 24 | , handleAll 25 | , handleIOError 26 | , handleJust 27 | , handleIf 28 | , try 29 | , tryJust 30 | , onException 31 | -- * Masking 32 | , mask 33 | , mask_ 34 | , uninterruptibleMask 35 | , uninterruptibleMask_ 36 | , interruptible 37 | -- * Reexports 38 | , Exception 39 | , SomeException 40 | ) where 41 | 42 | import Control.Monad.Catch (Exception, Handler (..), MonadCatch (catch), MonadThrow (throwM), SomeException, 43 | catchAll, catchIOError, catchIf, catchJust, catches, handle, handleAll, 44 | handleIOError, handleIf, handleJust, onException, try, tryJust) 45 | import Sp.Internal.Env ((:>)) 46 | import Sp.Internal.Monad (Eff, IOE, dynamicWind, interruptible, mask, uninterruptibleMask) 47 | 48 | -- | Lifted version of 'Control.Exception.mask_'. 49 | mask_ :: IOE :> es => Eff es a -> Eff es a 50 | mask_ m = mask \_ -> m 51 | {-# INLINE mask_ #-} 52 | 53 | -- | Lifted version of 'Control.Exception.uninterruptibleMask_'. 54 | uninterruptibleMask_ :: IOE :> es => Eff es a -> Eff es a 55 | uninterruptibleMask_ m = uninterruptibleMask \_ -> m 56 | {-# INLINE uninterruptibleMask_ #-} 57 | -------------------------------------------------------------------------------- /src/Sp/Error.hs: -------------------------------------------------------------------------------- 1 | module Sp.Error 2 | ( -- * Error 3 | Error (..) 4 | , throwError 5 | , tryError 6 | , catchError 7 | , runError 8 | ) where 9 | 10 | import Data.Kind (Type) 11 | import Sp.Eff 12 | 13 | -- | Allows you to throw error values of type @e@ and catching these errors too. 14 | data Error (e :: Type) :: Effect where 15 | ThrowError :: e -> Error e m a 16 | TryError :: m a -> Error e m (Either e a) 17 | 18 | -- | Throw an error. 19 | throwError :: Error e :> es => e -> Eff es a 20 | throwError e = send (ThrowError e) 21 | 22 | -- | Catch any error thrown by a computation and return the result as an 'Either'. 23 | tryError :: Error e :> es => Eff es a -> Eff es (Either e a) 24 | tryError m = send (TryError m) 25 | 26 | -- | Catch any error thrown by a computation and handle it with a function. 27 | catchError :: Error e :> es => Eff es a -> (e -> Eff es a) -> Eff es a 28 | catchError m h = tryError m >>= either h pure 29 | 30 | handleError :: ∀ e es a. Handler (Error e) es (Either e a) 31 | handleError tag = \case 32 | ThrowError e -> abort tag (pure $ Left e) 33 | TryError m -> replace (handleError @e) (Right <$> m) 34 | 35 | -- | Run the 'Error' effect. If there is any unhandled error, it is returned as a 'Left'. 36 | runError :: ∀ e es a. Eff (Error e : es) a -> Eff es (Either e a) 37 | runError = interpret (handleError @e) . fmap Right 38 | -------------------------------------------------------------------------------- /src/Sp/Internal/Ctl/Monadic.hs: -------------------------------------------------------------------------------- 1 | -- | 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 | -- 8 | -- Delimited control monad based on the design of Xie et al. This implementation imposes much less cost (albeit still 9 | -- noticeable) on computations not utilizing delimited control than the naive implementation. It also doesn't rely on 10 | -- compiler-supplied primitive operations. 11 | module Sp.Internal.Ctl.Monadic 12 | ( Marker 13 | , Ctl 14 | , freshMarker 15 | , prompt 16 | , control 17 | , abort 18 | , promptState 19 | , runCtl 20 | , dynamicWind 21 | , mask 22 | , uninterruptibleMask 23 | , interruptible 24 | ) where 25 | 26 | import Control.Exception (MaskingState (MaskedInterruptible, MaskedUninterruptible, Unmasked), 27 | SomeException, getMaskingState) 28 | import qualified Control.Exception as Exception 29 | import Control.Monad (ap, liftM, (<=<)) 30 | import Control.Monad.Catch (MonadCatch, MonadThrow) 31 | import qualified Control.Monad.Catch as Catch 32 | import Control.Monad.IO.Class (MonadIO (liftIO)) 33 | import Data.IORef (IORef, readIORef, writeIORef) 34 | import Data.Kind (Type) 35 | import Data.Primitive.PrimVar (PrimVar, fetchAddInt, newPrimVar) 36 | import Data.Type.Equality (type (:~:) (Refl)) 37 | import GHC.Exts (RealWorld, maskAsyncExceptions#, maskUninterruptible#, unmaskAsyncExceptions#) 38 | import GHC.IO (IO (IO)) 39 | import System.IO.Unsafe (unsafePerformIO) 40 | import Unsafe.Coerce (unsafeCoerce) 41 | 42 | -- | The source from which we construct unique 'Marker's. 43 | uniqueSource :: PrimVar RealWorld Int 44 | uniqueSource = unsafePerformIO (newPrimVar 0) 45 | {-# NOINLINE uniqueSource #-} 46 | 47 | -- | Create a fresh 'Marker'. 48 | freshMarker :: ∀ a. Ctl (Marker a) 49 | freshMarker = liftIO $ Marker <$> fetchAddInt uniqueSource 1 50 | 51 | -- | A @'Marker' a@ marks a prompt frame over a computation returning @a@. 52 | type role Marker representational 53 | newtype Marker (a :: Type) = Marker Int 54 | 55 | -- | Check the equality of two markers, and if so provide a proof that the type parameters are equal. This does not 56 | -- warrant a @TestEquality@ instance because it requires decidable equality over the type parameters. 57 | eqMarker :: Marker a -> Marker b -> Maybe (a :~: b) 58 | eqMarker (Marker l) (Marker r) = 59 | if l == r then Just (unsafeCoerce Refl) else Nothing 60 | 61 | -- | Intermediate result of a `Ctl` computation. 62 | type role Result representational 63 | data Result (a :: Type) 64 | = Pure a 65 | -- ^ The computation returned normally. 66 | | ∀ (r :: Type). Abort !(Marker r) (Ctl r) 67 | -- ^ The computation replaced itself with another computation. 68 | | ∀ (r :: Type) (b :: Type). Control !(Marker r) ((Ctl b -> Ctl r) -> Ctl r) (Ctl b -> Ctl a) 69 | -- ^ The computation captured a resumption and gained control over it. Specifically, this uses @shift0@ semantics. 70 | 71 | -- | Extend the captured continuation with a function, if it exists. 72 | extend :: (Ctl a -> Ctl a) -> Result a -> Result a 73 | extend f = \case 74 | Pure a -> Pure a 75 | Abort mark r -> Abort mark r 76 | Control mark ctl cont -> Control mark ctl (f . cont) 77 | 78 | -- | The delimited control monad, with efficient support of tail-resumptive computations. 79 | type role Ctl representational 80 | newtype Ctl (a :: Type) = Ctl { unCtl :: IO (Result a) } 81 | 82 | instance Functor Ctl where 83 | fmap = liftM 84 | 85 | instance Applicative Ctl where 86 | pure = Ctl . pure . Pure 87 | (<*>) = ap 88 | 89 | instance Monad Ctl where 90 | (Ctl x) >>= f = Ctl $ x >>= \case 91 | Pure a -> unCtl (f a) 92 | Abort mark r -> pure $ Abort mark r 93 | Control mark ctl cont -> pure $ Control mark ctl (f `compose` cont) 94 | 95 | -- | This loopbreaker is crucial to the performance of the monad. 96 | compose :: (b -> Ctl c) -> (a -> Ctl b) -> a -> Ctl c 97 | compose = (<=<) 98 | {-# NOINLINE compose #-} 99 | 100 | -- | Lift an 'IO' function to a 'Ctl' function. The function must not alter the result. 101 | liftMap, liftMap' :: (IO (Result a) -> IO (Result a)) -> Ctl a -> Ctl a 102 | liftMap f (Ctl m) = Ctl $ extend (liftMap' f) <$> f m 103 | {-# INLINE liftMap #-} 104 | liftMap' = liftMap 105 | {-# NOINLINE liftMap' #-} 106 | 107 | -- | Install a prompt frame. 108 | prompt, prompt' :: Marker a -> Ctl a -> Ctl a 109 | prompt !mark (Ctl m) = Ctl $ m >>= \case 110 | Pure a -> pure $ Pure a 111 | Abort mark' r -> case eqMarker mark mark' of 112 | Just Refl -> unCtl r 113 | Nothing -> pure $ Abort mark' r 114 | Control mark' ctl cont -> case eqMarker mark mark' of 115 | Just Refl -> unCtl $ ctl (prompt' mark . cont) 116 | Nothing -> pure $ Control mark' ctl (prompt' mark . cont) 117 | {-# INLINE prompt #-} 118 | prompt' = prompt 119 | {-# NOINLINE prompt' #-} 120 | 121 | -- | Capture the resumption up to and including the prompt frame specified by the 'Marker'. 122 | control :: Marker r -> ((Ctl a -> Ctl r) -> Ctl r) -> Ctl a 123 | control !mark f = Ctl $ pure $ Control mark f id 124 | 125 | -- | Replace the current computation up to and including the prompt with a new one. 126 | abort :: Marker r -> Ctl r -> Ctl a 127 | abort !mark r = Ctl $ pure $ Abort mark r 128 | 129 | -- | Introduce a mutable state that behaves well wrt reentry. 130 | promptState, promptState' :: IORef s -> Ctl r -> Ctl r 131 | promptState !ref (Ctl m) = Ctl $ m >>= \case 132 | Pure x -> pure $ Pure x 133 | Abort mark x -> pure $ Abort mark x 134 | Control mark ctl cont -> do 135 | s0 <- liftIO (readIORef ref) 136 | pure $ Control mark ctl \x -> do 137 | liftIO (writeIORef ref s0) 138 | promptState' ref (cont x) 139 | {-# INLINE promptState #-} 140 | promptState' = promptState 141 | {-# NOINLINE promptState' #-} 142 | 143 | -- | Unwrap the 'Ctl' monad. 144 | runCtl :: Ctl a -> IO a 145 | runCtl (Ctl m) = m >>= \case 146 | Pure a -> pure a 147 | Abort {} -> error "Sp.Ctl: Unhandled abort operation. Forgot to pair it with a prompt?" 148 | Control {} -> error "Sp.Ctl: Unhandled control operation. Forgot to pair it with a prompt?" 149 | 150 | instance MonadIO Ctl where 151 | liftIO = Ctl . fmap Pure 152 | 153 | instance MonadThrow Ctl where 154 | throwM = Ctl . Exception.throwIO 155 | 156 | -- | Note that although both catching and masking are possible, implementing 'Catch.generalBracket' via them will not 157 | -- be well-behaved wrt reentry; hence 'Ctl' is not 'Catch.MonadMask'. 158 | instance MonadCatch Ctl where 159 | catch m h = liftMap (Exception.handle (unCtl . h)) m 160 | 161 | -- | Install pre- and post-actions that are well-behaved wrt reentry. Specifically, pre- and post-actions are always 162 | -- guaranteed to act in pairs. 163 | dynamicWind, dynamicWind' :: Ctl () -> Ctl () -> Ctl a -> Ctl a 164 | dynamicWind before after (Ctl action) = do 165 | res <- before >> Ctl do 166 | res <- Exception.try @SomeException action 167 | pure $ Pure res 168 | after >> Ctl case res of 169 | Left se -> Exception.throwIO se 170 | Right y -> pure $ extend (dynamicWind' before after) y 171 | {-# INLINE dynamicWind #-} 172 | dynamicWind' = dynamicWind 173 | {-# NOINLINE dynamicWind' #-} 174 | 175 | block, unblock, blockUninterruptible :: Ctl a -> Ctl a 176 | block = liftMap \(IO m) -> IO $ maskAsyncExceptions# m 177 | unblock = liftMap \(IO m) -> IO $ unmaskAsyncExceptions# m 178 | blockUninterruptible = liftMap \(IO m) -> IO $ maskUninterruptible# m 179 | 180 | -- | Lifted version of 'Exception.mask'. 181 | mask :: ((∀ x. Ctl x -> Ctl x) -> Ctl a) -> Ctl a 182 | mask io = liftIO getMaskingState >>= \case 183 | Unmasked -> block $ io unblock 184 | MaskedInterruptible -> io block 185 | MaskedUninterruptible -> io blockUninterruptible 186 | 187 | -- | Lifted version of 'Exception.uninterruptibleMask'. 188 | uninterruptibleMask :: ((∀ x. Ctl x -> Ctl x) -> Ctl a) -> Ctl a 189 | uninterruptibleMask io = liftIO getMaskingState >>= \case 190 | Unmasked -> blockUninterruptible $ io unblock 191 | MaskedInterruptible -> blockUninterruptible $ io block 192 | MaskedUninterruptible -> io blockUninterruptible 193 | 194 | -- | Lifted version of 'Exception.interruptible'. 195 | interruptible :: Ctl a -> Ctl a 196 | interruptible io = liftIO getMaskingState >>= \case 197 | Unmasked -> io 198 | MaskedInterruptible -> unblock io 199 | MaskedUninterruptible -> io 200 | -------------------------------------------------------------------------------- /src/Sp/Internal/Ctl/Native.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE UnboxedTuples #-} 3 | {-# LANGUAGE UnliftedNewtypes #-} 4 | -- | 5 | -- Copyright: (c) 2023 Xy Ren 6 | -- License: BSD3 7 | -- Maintainer: xy.r@outlook.com 8 | -- Stability: experimental 9 | -- Portability: non-portable (GHC only) 10 | -- 11 | -- Delimited control monad based on the GHC primops introduced by Alexis King. This implementation is zero cost for 12 | -- computations not utilizing delimited control. On the other hand, frequent capture in this monad is slower than the 13 | -- monadic implementation. 14 | module Sp.Internal.Ctl.Native 15 | ( Marker 16 | , Ctl 17 | , freshMarker 18 | , prompt 19 | , control 20 | , abort 21 | , promptState 22 | , runCtl 23 | , dynamicWind 24 | , mask 25 | , uninterruptibleMask 26 | , interruptible 27 | ) where 28 | 29 | import Control.Exception (Exception (fromException), SomeException) 30 | import qualified Control.Exception as Exception 31 | import Control.Monad.Catch (MonadCatch (catch), MonadThrow) 32 | import Control.Monad.Catch.Pure (MonadThrow (throwM)) 33 | import Control.Monad.IO.Class (MonadIO (liftIO)) 34 | import Data.IORef (IORef, readIORef, writeIORef) 35 | import Data.Kind (Type) 36 | import Data.Type.Equality ((:~:) (Refl)) 37 | import GHC.Exts (Any, RealWorld) 38 | #if __GLASGOW_HASKELL__ >= 906 39 | import GHC.Exts (PromptTag#, control0#, newPromptTag#, prompt#) 40 | #else 41 | import GHC.Exts (ByteArray#, RuntimeRep, State#, TYPE) 42 | #endif 43 | import Data.Primitive.PrimVar (PrimVar, fetchAddInt, newPrimVar) 44 | import GHC.IO (IO (IO), unIO) 45 | import System.IO.Unsafe (unsafePerformIO) 46 | import Unsafe.Coerce (unsafeCoerce) 47 | 48 | -- Stub definitions intended for developing with GHC < 9.6, which do not have the proper primops 49 | #if __GLASGOW_HASKELL__ < 906 50 | newtype PromptTag# (a :: Type) = PromptTag# ByteArray# 51 | 52 | newPromptTag# :: State# RealWorld -> (# State# RealWorld, PromptTag# a #) 53 | newPromptTag# _ = error "newPromptTag#" 54 | 55 | prompt# 56 | :: PromptTag# a 57 | -> (State# RealWorld -> (# State# RealWorld, a #)) 58 | -> State# RealWorld -> (# State# RealWorld, a #) 59 | prompt# _ _ = error "prompt#" 60 | 61 | control0# 62 | :: ∀ (a :: Type) (r :: RuntimeRep) (b :: TYPE r) 63 | . PromptTag# a 64 | -> (((State# RealWorld -> (# State# RealWorld, b #)) 65 | -> State# RealWorld -> (# State# RealWorld, a #)) 66 | -> State# RealWorld -> (# State# RealWorld, a #)) 67 | -> State# RealWorld -> (# State# RealWorld, b #) 68 | control0# _ _ _ = error "control0#" 69 | #endif 70 | 71 | data PromptTag (a :: Type) = PromptTag (PromptTag# a) 72 | 73 | -- | We do not utilize the 'PromptTag#' mechanism built into the primops, as they do not support any kind of unwinding 74 | -- handlers to be installed in the middle of the prompt frame and the control call. 75 | thePromptTag :: PromptTag a 76 | thePromptTag = unsafePerformIO $ IO 77 | \s0 -> case newPromptTag# s0 of 78 | (# s1, tag #) -> (# s1, PromptTag tag #) 79 | {-# NOINLINE thePromptTag #-} 80 | 81 | -- | Install a generic prompt frame without a specific tag. 82 | promptIO :: IO a -> IO a 83 | promptIO (IO m) = case thePromptTag of 84 | PromptTag tag -> IO (prompt# tag m) 85 | 86 | -- | Unwind the stack with the continuation until the first prompt frame created by 'promptIO'. 87 | control0IO :: (∀ r. (IO a -> IO r) -> IO r) -> IO a 88 | control0IO f = case thePromptTag of 89 | PromptTag tag -> IO $ control0# tag \cont -> unIO $ f \io -> IO (cont $ unIO io) 90 | 91 | -- | The source from which we construct unique 'Marker's. 92 | uniqueSource :: PrimVar RealWorld Int 93 | uniqueSource = unsafePerformIO (newPrimVar 0) 94 | {-# NOINLINE uniqueSource #-} 95 | 96 | -- | Create a fresh 'Marker'. 97 | freshMarker :: ∀ a. Ctl (Marker a) 98 | freshMarker = liftIO $ Marker <$> fetchAddInt uniqueSource 1 99 | 100 | -- | A @'Marker' a@ marks a prompt frame over a computation returning @a@. 101 | type role Marker representational 102 | newtype Marker (a :: Type) = Marker Int 103 | 104 | -- | Check the equality of two markers, and if so provide a proof that the type parameters are equal. This does not 105 | -- warrant a @TestEquality@ instance because it requires decidable equality over the type parameters. 106 | eqMarker :: Marker a -> Marker b -> Maybe (a :~: b) 107 | eqMarker (Marker l) (Marker r) = 108 | if l == r then Just (unsafeCoerce Refl) else Nothing 109 | 110 | -- | Intermediate result of a `Ctl` computation. 111 | data Result a 112 | = Finished a 113 | | Raised SomeException 114 | | Unwound (Unwind a) 115 | 116 | -- | Unwinding of a 'Ctl' computation. 117 | data Unwind a 118 | = ∀ (r :: Type) (b :: Type). 119 | Control !(Marker r) ((Ctl b -> Ctl r) -> Ctl r) (Ctl b -> Ctl a) 120 | | ∀ (r :: Type). 121 | Abort !(Marker r) (Ctl r) 122 | 123 | -- | Unwindings are thrown to each prompt frame so that they can manipulate them. The absense of type parameters (hence 124 | -- 'Any') allows us to avoid @Typeable@. 125 | newtype UnwindException = UnwindException (Unwind Any) 126 | deriving anyclass Exception 127 | 128 | instance Show UnwindException where 129 | show _ = "Escaped unwinding" 130 | 131 | -- | The delimited control monad, with efficient support of tail-resumptive computations. 132 | type role Ctl representational 133 | newtype Ctl (a :: Type) = Ctl { runCtl :: IO a } 134 | deriving (Functor, Applicative, Monad, MonadIO) via IO 135 | 136 | -- | Install an general handler. 137 | handle' :: Ctl a -> (Result a -> Ctl b) -> Ctl b 138 | handle' (Ctl m) f = Ctl $ runCtl . f =<< Exception.catch (Finished <$> promptIO m) 139 | \se -> pure case fromException se of 140 | Just (UnwindException y) -> Unwound $ unsafeCoerce y 141 | Nothing -> Raised se 142 | 143 | -- | Install a handler that only modifies unwindings. 144 | handle :: Ctl a -> (Unwind a -> Ctl a) -> Ctl a 145 | handle (Ctl m) f = Ctl $ Exception.catch (promptIO m) 146 | \(UnwindException y) -> runCtl $ f $ unsafeCoerce y 147 | 148 | -- | Unwind to the nearest handler. 149 | unwind :: Unwind r -> Ctl a 150 | unwind x = Ctl $ Exception.throwIO $ UnwindException $ unsafeCoerce $ x 151 | {-# INLINE unwind #-} 152 | 153 | -- | Unwind-with-current-continuation. Useful when the unwind is a control. 154 | unwindCC :: (∀ r. (Ctl a -> Ctl r) -> Unwind r) -> Ctl a 155 | unwindCC f = Ctl $ control0IO \cont -> runCtl $ unwind $ f (Ctl . cont . runCtl) 156 | {-# INLINE unwindCC #-} 157 | 158 | -- | Prompt/reset with a specific marker. This is unsafe. 159 | prompt, prompt' :: Marker a -> Ctl a -> Ctl a 160 | prompt !mark m = handle m \case 161 | Abort mark' r -> case eqMarker mark mark' of 162 | Just Refl -> r 163 | Nothing -> abort mark' r 164 | Control mark' ctl cont -> case eqMarker mark mark' of 165 | Just Refl -> ctl (prompt' mark . cont) 166 | Nothing -> unwindCC \cont' -> Control mark' ctl (cont' . prompt' mark . cont) 167 | {-# INLINE prompt #-} 168 | prompt' = prompt 169 | {-# NOINLINE prompt' #-} 170 | 171 | -- | Take over control of the continuation up to the prompt frame specified by 'Marker'. 172 | control :: Marker r -> ((Ctl a -> Ctl r) -> Ctl r) -> Ctl a 173 | control !mark ctl = unwindCC \cont -> Control mark ctl cont 174 | 175 | -- | Aborts the computation with a value to the prompt frame specified by 'Marker'. 176 | abort :: Marker r -> Ctl r -> Ctl a 177 | abort !mark r = unwind $ Abort mark r 178 | 179 | -- | Set up backtracking on a specific state variable. This is unsafe. 180 | promptState, promptState' :: IORef s -> Ctl a -> Ctl a 181 | promptState !ref m = handle m \case 182 | Abort mark r -> abort mark r 183 | Control mark ctl cont -> do 184 | s0 <- liftIO $ readIORef ref 185 | unwindCC \cont' -> Control mark ctl \x -> cont' do 186 | liftIO $ writeIORef ref s0 187 | promptState' ref (cont x) 188 | {-# INLINE promptState #-} 189 | promptState' = promptState 190 | {-# NOINLINE promptState' #-} 191 | 192 | instance MonadThrow Ctl where 193 | throwM = Ctl . Exception.throwIO 194 | 195 | instance MonadCatch Ctl where 196 | catch (Ctl m) h = Ctl $ Exception.catch m \se -> 197 | -- Stop users from catching unwindings by catching 'SomeException' 198 | case fromException @UnwindException se of 199 | Just u -> Exception.throwIO u 200 | Nothing -> case fromException se of 201 | Just e -> runCtl $ h e 202 | Nothing -> Exception.throwIO se 203 | 204 | -- | Attach pre- and post-actions that are well-behaved in the presence of controls. The downside is that it doesn't 205 | -- support passing the pre-action's result to the main action. 206 | dynamicWind, dynamicWind' :: Ctl () -> Ctl () -> Ctl a -> Ctl a 207 | dynamicWind before after action = 208 | before >> handle' action \v -> after >> case v of 209 | Finished a -> pure a 210 | Raised se -> throwM se 211 | Unwound y -> case y of 212 | Abort mark r -> abort mark r 213 | Control mark ctl cont -> unwindCC \cont' -> 214 | Control mark ctl (cont' . dynamicWind' before after . cont) 215 | {-# INLINE dynamicWind #-} 216 | dynamicWind' = dynamicWind 217 | {-# NOINLINE dynamicWind' #-} 218 | 219 | -- | Lifted version of 'Exception.mask'. 220 | mask :: ((∀ x. Ctl x -> Ctl x) -> Ctl a) -> Ctl a 221 | mask io = Ctl $ Exception.mask \unmask -> runCtl $ io (Ctl . unmask . runCtl) 222 | 223 | -- | Lifted version of 'Exception.uninterruptibleMask'. 224 | uninterruptibleMask :: ((∀ x. Ctl x -> Ctl x) -> Ctl a) -> Ctl a 225 | uninterruptibleMask io = Ctl $ Exception.uninterruptibleMask \unmask -> runCtl $ io (Ctl . unmask . runCtl) 226 | 227 | -- | Lifted version of 'Exception.interruptible'. 228 | interruptible :: Ctl a -> Ctl a 229 | interruptible io = Ctl $ Exception.interruptible $ runCtl io 230 | -------------------------------------------------------------------------------- /src/Sp/Internal/Env.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 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 module defines an immutable extensible record type, similar to @vinyl@ and @data-diverse@. However this 10 | -- implementation focuses on fast reads, hence has very different performance characteristics from other libraries: 11 | -- 12 | -- * Lookup: Amortized /O/(1). 13 | -- * Update: /O/(/n/). 14 | -- * Shrink: /O/(1). 15 | -- * Append: /O/(/n/). 16 | module Sp.Internal.Env 17 | ( Rec 18 | , length 19 | -- * Construction 20 | , empty 21 | , cons 22 | , pad 23 | , type (++) 24 | , concat 25 | -- * Deconstruction 26 | , head 27 | , tail 28 | , type KnownList 29 | , drop 30 | , take 31 | -- * Retrieval & Update 32 | , type (:>) 33 | , index 34 | , update 35 | -- * Subset operations 36 | , type Suffix 37 | , suffix 38 | , type KnownSubset 39 | , pick 40 | , type AllMembers 41 | , type Subset 42 | , extract 43 | ) where 44 | 45 | import Data.Kind (Constraint, Type) 46 | import GHC.Exts (Any) 47 | import GHC.TypeLits (ErrorMessage (ShowType, Text, (:<>:)), TypeError) 48 | import Prelude hiding (concat, drop, head, length, tail, take) 49 | import qualified Sp.Internal.Vec as Vec 50 | import Sp.Internal.Vec (ConcatPhase (..), DropPhase (..), Vec) 51 | import Unsafe.Coerce (unsafeCoerce) 52 | 53 | -- | Extensible record type supporting efficient /O/(1) reads. 54 | type role Rec representational nominal 55 | newtype Rec (f :: k -> Type) (es :: [k]) = Rec (Vec Any) 56 | 57 | -- | Get the length of the record. 58 | length :: Rec f es -> Int 59 | length (Rec vec) = Vec.length vec 60 | {-# INLINE length #-} 61 | 62 | unreifiable :: String -> String -> a 63 | unreifiable clsName comp = error $ 64 | "Sp.Internal.Env: Attempting to access " <> comp <> " without a reflected value. This is perhaps because you are \ 65 | \trying to define an instance for the '" <> clsName <> "' typeclass, which you should not be doing whatsoever. If \ 66 | \that seems unlikely, please report this as a bug." 67 | 68 | -------------------------------------------------------------------------------- 69 | -- Construction ---------------------------------------------------------------- 70 | -------------------------------------------------------------------------------- 71 | 72 | -- | Create an empty record. /O/(1). 73 | empty :: Rec f '[] 74 | empty = Rec Vec.empty 75 | {-# INLINE empty #-} 76 | 77 | -- | Prepend one entry to the record. /O/(/n/). 78 | cons :: f e -> Rec f es -> Rec f (e ': es) 79 | cons x (Rec vec) = Rec $ Vec.cons (toAny x) vec 80 | {-# INLINE cons #-} 81 | 82 | -- | Prepend one null entry to the record. This entry can be normally evaluated (different from 'undefined'), but any 83 | -- attempt to use it will cause a runtime error. /O/(/n/). 84 | pad :: Rec f es -> Rec f (e ': es) 85 | pad (Rec vec) = Rec $ Vec.pad vec 86 | {-# INLINE pad #-} 87 | 88 | -- | Type level list concatenation. 89 | type family (xs :: [k]) ++ (ys :: [k]) where 90 | '[] ++ ys = ys 91 | (x ': xs) ++ ys = x ': (xs ++ ys) 92 | infixr 5 ++ 93 | 94 | -- | Concatenate two records. /O/(/m/ + /n/). 95 | concat :: Rec f es -> Rec f es' -> Rec f (es ++ es') 96 | concat (Rec vec) (Rec vec') = Rec $ Vec.concat vec vec' 97 | {-# INLINE concat #-} 98 | 99 | -------------------------------------------------------------------------------- 100 | -- Deconstruction -------------------------------------------------------------- 101 | -------------------------------------------------------------------------------- 102 | 103 | -- | Get the head of the record. /O/(1). 104 | head :: Rec f (e ': es) -> f e 105 | head (Rec vec) = fromAny $ Vec.head vec 106 | {-# INLINE head #-} 107 | 108 | -- | Slice off one entry from the top of the record. /O/(1). 109 | tail :: Rec f (e ': es) -> Rec f es 110 | tail (Rec vec) = Rec $ Vec.tail vec 111 | {-# INLINE tail #-} 112 | 113 | -- | The list @es@ list is concrete, i.e. is of the form @'[a1, a2, ..., an]@ therefore having a known length. 114 | class KnownList (es :: [k]) where 115 | -- | Get the length of the list. 116 | reifyLen :: Int 117 | reifyLen = unreifiable "KnownList" "the length of a type-level list" 118 | 119 | instance KnownList '[] where 120 | reifyLen = 0 121 | 122 | instance KnownList es => KnownList (e ': es) where 123 | reifyLen = 1 + reifyLen @_ @es 124 | 125 | -- | Slice off several entries from the top of the record. Amortized /O/(1). 126 | drop :: ∀ es es' f. KnownList es => Rec f (es ++ es') -> Rec f es' 127 | drop (Rec vec) = Rec $ Vec.drop (reifyLen @_ @es) vec 128 | {-# INLINE drop #-} 129 | 130 | -- | Take elements from the top of the record. /O/(/m/). 131 | take :: ∀ es es' f. KnownList es => Rec f (es ++ es') -> Rec f es 132 | take (Rec vec) = Rec $ Vec.take (reifyLen @_ @es) vec 133 | {-# INLINE take #-} 134 | 135 | -------------------------------------------------------------------------------- 136 | -- Retrieval & Update ---------------------------------------------------------- 137 | -------------------------------------------------------------------------------- 138 | 139 | -- | The element @e@ is present in the list @es@. 140 | class (e :: k) :> (es :: [k]) where 141 | -- | Get the index of the element. 142 | reifyIndex :: Int 143 | reifyIndex = unreifiable "Elem" "an element of a type-level list" 144 | infix 0 :> 145 | 146 | instance {-# OVERLAPPING #-} e :> e : es where 147 | reifyIndex = 0 148 | 149 | instance e :> es => e :> e' : es where 150 | reifyIndex = 1 + reifyIndex @_ @e @es 151 | 152 | type ElemNotFound e = 'Text "The element '" ':<>: 'ShowType e ':<>: 'Text "' is not present in the constraint" 153 | 154 | instance TypeError (ElemNotFound e) => e :> '[] where 155 | reifyIndex = error "Sp.Env: Attempting to refer to a nonexistent member. Please report this as a bug." 156 | 157 | -- | Get an element in the record. Amortized /O/(1). 158 | index :: ∀ e es f. e :> es => Rec f es -> f e 159 | index (Rec vec) = fromAny $ Vec.index (reifyIndex @_ @e @es) vec 160 | {-# INLINE index #-} 161 | 162 | -- | Update an entry in the record. /O/(/n/). 163 | update :: ∀ e es f. e :> es => f e -> Rec f es -> Rec f es 164 | update x (Rec vec) = Rec $ Vec.update (reifyIndex @_ @e @es) (toAny x) vec 165 | {-# INLINE update #-} 166 | 167 | -------------------------------------------------------------------------------- 168 | -- Subset Operations ----------------------------------------------------------- 169 | -------------------------------------------------------------------------------- 170 | 171 | -- | @es@ is a suffix of @es'@. This works even if both has a shared polymorphic tail, e.g. this typeclass recognizes 172 | -- @2 : 3 : es@ is a suffix of @0 : 1 : 2 : 3 : es@. 173 | class Suffix (es :: [k]) (es' :: [k]) where 174 | reifyPrefix :: Int 175 | reifyPrefix = unreifiable "Subset" "a prefix of a type-level list" 176 | 177 | instance Suffix es es where 178 | reifyPrefix = 0 179 | 180 | -- | This is morally coherent because if it actually turned out that @es ~ e : es'@, the search will simply fail 181 | -- instead of producing a different instance. 182 | instance {-# INCOHERENT #-} Suffix es es' => Suffix es (e : es') where 183 | reifyPrefix = 1 + reifyPrefix @_ @es @es' 184 | 185 | -- | Get a suffix of the record. Amortized /O/(1). 186 | suffix :: ∀ es es' f. Suffix es es' => Rec f es' -> Rec f es 187 | suffix (Rec vec) = Rec $ Vec.drop (reifyPrefix @_ @es @es') vec 188 | {-# INLINE suffix #-} 189 | 190 | -- | Shorthand for @(e1 ':>' es, e2 :> es, e3 :> es, ...)@. 191 | type family AllMembers (es :: [k]) (es' :: [k]) :: Constraint where 192 | AllMembers '[] _ = () 193 | AllMembers (e : es) es' = (e :> es', AllMembers es es') 194 | 195 | -- | @es@ is a known subset of @es'@, i.e. all members of @es@ have a statically known index in @es'@. 196 | class (KnownList es, AllMembers es es') => KnownSubset (es :: [k]) (es' :: [k]) where 197 | -- | Get a list of indices of the elements. 198 | reifyIndices :: [Int] 199 | reifyIndices = unreifiable "KnownSubset" "multiple elements of a type-level list" 200 | 201 | instance KnownSubset '[] es where 202 | reifyIndices = [] 203 | 204 | instance (KnownSubset es es', e :> es') => KnownSubset (e ': es) es' where 205 | reifyIndices = reifyIndex @_ @e @es' : reifyIndices @_ @es @es' 206 | 207 | -- | Get a known subset of the record. Amortized /O/(/m/). 208 | pick :: ∀ es es' f. KnownSubset es es' => Rec f es' -> Rec f es 209 | pick (Rec vec) = Rec $ Vec.pick (reifyLen @_ @es) (reifyIndices @_ @es @es') vec 210 | {-# INLINE pick #-} 211 | 212 | -- | @es@ is a subset of @es'@. This works on both known lists and lists with polymorphic tails. E.g. all of the 213 | -- following work: 214 | -- 215 | -- @ 216 | -- Subset '[3, 1] '[1, 2, 3] 217 | -- Subset '[3, 1] (1 : 2 : 3 : es) 218 | -- Subset (3 : 1 : es) (1 : 2 : 3 : es) 219 | -- @ 220 | class Subset (es :: [k]) (es' :: [k]) where 221 | reifyExtraction :: ConcatPhase 222 | reifyExtraction = unreifiable "Subset" "a subsequence of a type-level list" 223 | 224 | instance Subset '[] es' where 225 | reifyExtraction = IdOp EmptyOp 226 | 227 | instance (e :> es', Subset es es') => Subset (e : es) es' where 228 | reifyExtraction = case reifyExtraction @_ @es @es' of 229 | IdOp ro -> ConcatOp 1 [reifyIndex @_ @e @es'] ro 230 | ConcatOp n xs ro -> ConcatOp (1 + n) (reifyIndex @_ @e @es' : xs) ro 231 | 232 | instance {-# INCOHERENT #-} Suffix es es' => Subset es es' where 233 | reifyExtraction = IdOp (DropOp $ reifyPrefix @_ @es @es') 234 | 235 | -- | Extract a subset out of the record. /O/(/n/). 236 | extract :: ∀ es es' f. Subset es es' => Rec f es' -> Rec f es 237 | extract (Rec vec) = Rec $ Vec.extract (reifyExtraction @_ @es @es') vec 238 | {-# INLINE extract #-} 239 | 240 | -------------------------------------------------------------------------------- 241 | -- Any ------------------------------------------------------------------------- 242 | -------------------------------------------------------------------------------- 243 | 244 | -- | Coerce any boxed value into 'GHC.Exts.Any'. 245 | toAny :: a -> Any 246 | toAny = unsafeCoerce 247 | 248 | -- | Coerce an 'GHC.Exts.Any' value to a certain type. This is generally unsafe and it is your responsibility to ensure 249 | -- that the type you're coercing into is the original type that the 'GHC.Exts.Any' value is coerced from. 250 | fromAny :: Any -> a 251 | fromAny = unsafeCoerce 252 | -------------------------------------------------------------------------------- /src/Sp/Internal/Handle.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | -- | 3 | -- Copyright: (c) 2022 Xy Ren 4 | -- License: BSD3 5 | -- Maintainer: xy.r@outlook.com 6 | -- Stability: experimental 7 | -- Portability: non-portable (GHC only) 8 | -- 9 | -- Functions for effect handling, as well as effect stack manipulating. 10 | module Sp.Internal.Handle 11 | ( -- * Interpret 12 | Interpret 13 | , interpret 14 | , interpret0 15 | , interpret1 16 | , interpret2 17 | , interpret3 18 | , interpretN 19 | -- * Interpose 20 | , Interpose 21 | , interpose 22 | , interpose0 23 | , interpose1 24 | , interpose2 25 | , interpose3 26 | , interposeN 27 | -- * Replace 28 | , Replace 29 | , replace 30 | , replace0 31 | , replace1 32 | , replace2 33 | , replace3 34 | , replaceN 35 | -- * Lift 36 | , Lift 37 | , lift 38 | , lift1 39 | , lift2 40 | , lift3 41 | , liftN 42 | -- * Lift Under 43 | , LiftNUnder 44 | , liftUnder1 45 | , lift1Under1 46 | , lift2Under1 47 | , lift3Under1 48 | , liftNUnder1 49 | , LiftUnderN 50 | , lift1Under2 51 | , lift1Under3 52 | , lift1UnderN 53 | , liftNUnderN 54 | -- * Subsume 55 | , Subsume 56 | , subsume1 57 | , subsume2 58 | , subsume3 59 | , subsumeN 60 | -- * Miscellaneous 61 | , inject 62 | , rearrange 63 | , rearrangeN 64 | ) where 65 | 66 | import qualified Sp.Internal.Env as Rec 67 | import Sp.Internal.Env (KnownList, KnownSubset, Subset, Suffix, type (++), (:>)) 68 | import Sp.Internal.Monad 69 | 70 | -------------------------------------------------------------------------------- 71 | -- Interpret ------------------------------------------------------------------- 72 | -------------------------------------------------------------------------------- 73 | 74 | -- | The family of /interpreting/ functions. Eliminate an effect from the top of the stack via a handler, and 75 | -- optionally add some other effects (@es'@) that could be used in the handler. Adding these effects instead of 76 | -- requiring them on the client side achieves effect encapsulation. 77 | type Interpret es' = ∀ e es a. Handler e (es' ++ es) a -> Eff (e : es) a -> Eff (es' ++ es) a 78 | 79 | -- | Interpret and add extra effects based on type inference. If this does not work consider using the more concrete 80 | -- functions below. 81 | interpret :: Suffix es es' => Handler e es' a -> Eff (e : es) a -> Eff es' a 82 | interpret = handle \ih es -> Rec.cons ih $ Rec.suffix es 83 | {-# INLINE interpret #-} 84 | 85 | -- | Interpret and don't add extra effects. 86 | interpret0 :: Interpret '[] 87 | interpret0 = interpret 88 | {-# INLINE interpret0 #-} 89 | 90 | -- | Interpret and add 1 extra effect. 91 | interpret1 :: Interpret '[e'] 92 | interpret1 = interpret 93 | {-# INLINE interpret1 #-} 94 | 95 | -- | Interpret and add 2 extra effects. 96 | interpret2 :: Interpret '[e', e''] 97 | interpret2 = interpret 98 | {-# INLINE interpret2 #-} 99 | 100 | -- | Interpret and add 3 extra effects. 101 | interpret3 :: Interpret '[e', e'', e'''] 102 | interpret3 = interpret 103 | {-# INLINE interpret3 #-} 104 | 105 | -- | Interpret and add a list of extra effects specified explicitly via @TypeApplications@. 106 | interpretN :: ∀ es'. KnownList es' => Interpret es' 107 | interpretN = handle \ih es -> Rec.cons ih $ Rec.drop @es' es 108 | {-# INLINE interpretN #-} 109 | 110 | -------------------------------------------------------------------------------- 111 | -- Interpose ------------------------------------------------------------------- 112 | -------------------------------------------------------------------------------- 113 | 114 | -- | The family of /interposing/ functions. Modify the implementation of an effect in the stack via a new handler, and 115 | -- optionally add some other effects (@es'@) that could be used in said handler. 116 | type Interpose es' = ∀ e es a. e :> es => Handler e (es' ++ es) a -> Eff es a -> Eff (es' ++ es) a 117 | 118 | -- | Interpose and add extra effects based on type inference. If this does not work consider using the more concrete 119 | -- functions below. 120 | interpose :: (e :> es, Suffix es es') => Handler e es' a -> Eff es a -> Eff es' a 121 | interpose = handle \ih es -> Rec.update ih $ Rec.suffix es 122 | {-# INLINE interpose #-} 123 | 124 | -- | Interpose and don't add extra effects. 125 | interpose0 :: Interpose '[] 126 | interpose0 = interpose 127 | {-# INLINE interpose0 #-} 128 | 129 | -- | Interpose and add 1 extra effect. 130 | interpose1 :: Interpose '[e'] 131 | interpose1 = interpose 132 | {-# INLINE interpose1 #-} 133 | 134 | -- | Interpose and add 2 extra effects. 135 | interpose2 :: Interpose '[e', e''] 136 | interpose2 = interpose 137 | {-# INLINE interpose2 #-} 138 | 139 | -- | Interpose and add 3 extra effects. 140 | interpose3 :: Interpose '[e', e'', e'''] 141 | interpose3 = interpose 142 | {-# INLINE interpose3 #-} 143 | 144 | -- | Interpose and add a list of extra effects specified explicitly via @TypeApplications@. 145 | interposeN :: ∀ es'. KnownList es' => Interpose es' 146 | interposeN = handle \ih es -> Rec.update ih $ Rec.drop @es' es 147 | {-# INLINE interposeN #-} 148 | 149 | -------------------------------------------------------------------------------- 150 | -- Replace --------------------------------------------------------------------- 151 | -------------------------------------------------------------------------------- 152 | 153 | -- | The family of /interposing/ functions. Modify the implementation of an effect in the stack via a new handler, and 154 | -- optionally add some other effects (@es'@) that could be used in said handler. 155 | type Replace es' = ∀ e es a. e :> es => Handler e (es' ++ es) a -> Eff es a -> Eff (es' ++ es) a 156 | 157 | -- | Replace and add extra effects based on type inference. If this does not work consider using the more concrete 158 | -- functions below. 159 | replace :: (e :> es, Suffix es es') => Handler e es' a -> Eff es a -> Eff es' a 160 | replace = rehandle \es -> Rec.suffix es 161 | {-# INLINE replace #-} 162 | 163 | -- | Replace and don't add extra effects. 164 | replace0 :: Replace '[] 165 | replace0 = replace 166 | {-# INLINE replace0 #-} 167 | 168 | -- | Replace and add 1 extra effect. 169 | replace1 :: Replace '[e'] 170 | replace1 = replace 171 | {-# INLINE replace1 #-} 172 | 173 | -- | Replace and add 2 extra effects. 174 | replace2 :: Replace '[e', e''] 175 | replace2 = replace 176 | {-# INLINE replace2 #-} 177 | 178 | -- | Replace and add 3 extra effects. 179 | replace3 :: Replace '[e', e'', e'''] 180 | replace3 = replace 181 | {-# INLINE replace3 #-} 182 | 183 | -- | Replace and add a list of extra effects specified explicitly via @TypeApplications@. 184 | replaceN :: ∀ es'. KnownList es' => Replace es' 185 | replaceN = rehandle \es -> Rec.drop @es' es 186 | {-# INLINE replaceN #-} 187 | 188 | -------------------------------------------------------------------------------- 189 | -- Lift ------------------------------------------------------------------------ 190 | -------------------------------------------------------------------------------- 191 | 192 | -- | The family of /lifting/ functions. They trivially lift a computation over some effects into a larger effect 193 | -- context. It can be also seen as masking a set of effects from the inner computation. 194 | type Lift es' = ∀ es a. Eff es a -> Eff (es' ++ es) a 195 | 196 | -- | Lift over some effects based on type inference. If this does not work consider using the more concrete functions 197 | -- below. 198 | lift :: Suffix es es' => Eff es a -> Eff es' a 199 | lift = alter Rec.suffix 200 | {-# INLINE lift #-} 201 | 202 | -- | Lift over 1 effect. 203 | lift1 :: Lift '[e'] 204 | lift1 = lift 205 | {-# INLINE lift1 #-} 206 | 207 | -- | Lift over 2 effects. 208 | lift2 :: Lift '[e', e''] 209 | lift2 = lift 210 | {-# INLINE lift2 #-} 211 | 212 | -- | Lift over 3 effects. 213 | lift3 :: Lift '[e', e'', e'''] 214 | lift3 = lift 215 | {-# INLINE lift3 #-} 216 | 217 | -- | Lift pver a list of effects supplied explicitly via @TypeApplications@. 218 | liftN :: ∀ es'. KnownList es' => Lift es' 219 | liftN = alter (Rec.drop @es') 220 | {-# INLINE liftN #-} 221 | 222 | -------------------------------------------------------------------------------- 223 | -- Lift Under ------------------------------------------------------------------ 224 | -------------------------------------------------------------------------------- 225 | 226 | -- | The family of /lifting-under-1/ functions. They lift over several effects /under/ one effect. 227 | type LiftNUnder es' = ∀ e es a. Eff (e : es) a -> Eff (e : es' ++ es) a 228 | 229 | -- | Lift over several effect under 1 effect, based on type inference. If this does not work consider using the more 230 | -- concrete functions below. 231 | liftUnder1 :: Suffix es es' => Eff (e : es) a -> Eff (e : es') a 232 | liftUnder1 = alter \es -> Rec.cons (Rec.head es) $ Rec.suffix es 233 | {-# INLINE liftUnder1 #-} 234 | 235 | -- | Lift over 1 effect under 1 effect. 236 | lift1Under1 :: LiftNUnder '[e'] 237 | lift1Under1 = liftUnder1 238 | {-# INLINE lift1Under1 #-} 239 | 240 | -- | Lift over 2 effects under 1 effect. 241 | lift2Under1 :: LiftNUnder '[e', e''] 242 | lift2Under1 = liftUnder1 243 | {-# INLINE lift2Under1 #-} 244 | 245 | -- | Lift over 3 effects under 1 effect. 246 | lift3Under1 :: LiftNUnder '[e', e'', e'''] 247 | lift3Under1 = liftUnder1 248 | {-# INLINE lift3Under1 #-} 249 | 250 | -- | Lift over a list of effects under 1 effect. The list of effects is supplied explicitly via @TypeApplications@. 251 | liftNUnder1 :: ∀ es'. KnownList es' => LiftNUnder es' 252 | liftNUnder1 = alter \es -> Rec.cons (Rec.head es) $ Rec.drop @(_ : es') es 253 | {-# INLINE liftNUnder1 #-} 254 | 255 | -- | The family of /lifting-1-under/ functions. They lift over an effect /under several effects/. This family of 256 | -- functions don't have inferred variants because they're hard to formulate. 257 | type LiftUnderN es' = ∀ e es a. Eff (es' ++ es) a -> Eff (es' ++ e : es) a 258 | 259 | -- | Lift over 1 effect under 2 effects. 260 | lift1Under2 :: ∀ e' e''. LiftUnderN '[e', e''] 261 | lift1Under2 = lift1UnderN @'[e', e''] 262 | {-# INLINE lift1Under2 #-} 263 | 264 | -- | Lift over 1 effect under 3 effects. 265 | lift1Under3 :: ∀ e' e'' e'''. LiftUnderN '[e', e'', e'''] 266 | lift1Under3 = lift1UnderN @'[e', e'', e'''] 267 | {-# INLINE lift1Under3 #-} 268 | 269 | -- | Lift over 1 effect under a list effects explicitly supplied via @TypeApplications@. 270 | lift1UnderN :: ∀ es' e es a. KnownList es' => Eff (es' ++ es) a -> Eff (es' ++ e : es) a 271 | lift1UnderN = alter \es -> Rec.concat (Rec.take @es' @(e : es) es) $ Rec.tail $ Rec.drop @es' @(e : es) es 272 | {-# INLINE lift1UnderN #-} 273 | 274 | -- | The most general /lifting-under/ function. Lifts over a list of effects under another list of effects. Both 275 | -- lists are to supplied explicitly via @TypeApplications@. 276 | liftNUnderN :: ∀ es'' es' es a. (KnownList es', KnownList es'') => Eff (es' ++ es) a -> Eff (es' ++ es'' ++ es) a 277 | liftNUnderN = alter \es -> 278 | Rec.concat (Rec.take @es' @(es'' ++ es) es) $ Rec.drop @es'' @es $ Rec.drop @es' @(es'' ++ es) es 279 | {-# INLINE liftNUnderN #-} 280 | 281 | -------------------------------------------------------------------------------- 282 | -- Subsume --------------------------------------------------------------------- 283 | -------------------------------------------------------------------------------- 284 | 285 | -- | The family of /subsumption/ functions. They trivially eliminate duplicate effects from the top of the stack. This 286 | -- functions don't have inferred variants because they're hard to formulate. 287 | type Subsume es' = ∀ es a. KnownSubset es' es => Eff (es' ++ es) a -> Eff es a 288 | 289 | -- | Subsume 1 duplicate effect. 290 | subsume1 :: ∀ e'. Subsume '[e'] 291 | subsume1 = subsumeN @'[e'] 292 | {-# INLINE subsume1 #-} 293 | 294 | -- | Subsume 2 duplicate effects. 295 | subsume2 :: ∀ e' e''. Subsume '[e', e''] 296 | subsume2 = subsumeN @'[e', e''] 297 | {-# INLINE subsume2 #-} 298 | 299 | -- | Subsume 3 duplicate effects. 300 | subsume3 :: ∀ e' e'' e'''. Subsume '[e', e'', e'''] 301 | subsume3 = subsumeN @'[e', e'', e'''] 302 | {-# INLINE subsume3 #-} 303 | 304 | -- | Subsume a list duplicate effects explicitly supplied via @TypeApplications@. 305 | subsumeN :: ∀ es'. KnownList es' => Subsume es' 306 | subsumeN = alter \es -> Rec.concat (Rec.pick @es' es) es 307 | {-# INLINE subsumeN #-} 308 | 309 | -------------------------------------------------------------------------------- 310 | -- Miscellaneous --------------------------------------------------------------- 311 | -------------------------------------------------------------------------------- 312 | 313 | -- | Inject a small effect context with all elements known into a larger effect context. 314 | inject :: KnownSubset es' es => Eff es' a -> Eff es a 315 | inject = alter Rec.pick 316 | {-# INLINE inject #-} 317 | 318 | -- | Arbitrarily rearrange the known prefix of the effect context of a computation, as long as the polymorphic tail 319 | -- is unchanged. This function is based on type inference, use 'inject' or 'rearrangeN' when it doesn't work properly. 320 | rearrange :: Subset es es' => Eff es a -> Eff es' a 321 | rearrange = alter Rec.extract 322 | {-# INLINE rearrange #-} 323 | 324 | -- | Like 'rearrange' but with the prefixes explicitly supplied via @TypeApplications@. 325 | rearrangeN :: ∀ es' es'' es a. (KnownList es'', KnownSubset es' (es'' ++ es)) => Eff (es' ++ es) a -> Eff (es'' ++ es) a 326 | rearrangeN = alter \es -> Rec.concat (Rec.pick @es' es) $ Rec.drop @es'' @es es 327 | {-# INLINE rearrangeN #-} 328 | -------------------------------------------------------------------------------- /src/Sp/Internal/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE CPP #-} 3 | -- | 4 | -- Copyright: (c) 2022 Xy Ren 5 | -- License: BSD3 6 | -- Maintainer: xy.r@outlook.com 7 | -- Stability: experimental 8 | -- Portability: non-portable (GHC only) 9 | -- 10 | -- The effect monad, along with handling combinators that enable delimited control and higher-order effects. 11 | module Sp.Internal.Monad 12 | ( Eff 13 | , Env 14 | , HandlerCell 15 | , Effect 16 | , HandleTag 17 | , Handler 18 | , unsafeIO 19 | , unsafeState 20 | , handle 21 | , rehandle 22 | , alter 23 | , send 24 | , Localized 25 | , Handling 26 | , embed 27 | , withUnembed 28 | , abort 29 | , control 30 | , runEff 31 | , IOE 32 | , runIOE 33 | , dynamicWind 34 | , mask 35 | , uninterruptibleMask 36 | , interruptible 37 | ) where 38 | 39 | #ifdef SPEFF_NATIVE_DELCONT 40 | #define CTL_MODULE Sp.Internal.Ctl.Native 41 | #else 42 | #define CTL_MODULE Sp.Internal.Ctl.Monadic 43 | #endif 44 | 45 | import Control.Monad (ap, liftM) 46 | import Control.Monad.Catch (MonadCatch, MonadThrow) 47 | import qualified Control.Monad.Catch as Catch 48 | import Control.Monad.IO.Class (MonadIO (liftIO)) 49 | import CTL_MODULE (Ctl, runCtl) 50 | import qualified CTL_MODULE as Ctl 51 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 52 | import Data.Kind (Type) 53 | import qualified Sp.Internal.Env as Rec 54 | import Sp.Internal.Env (Rec, (:>)) 55 | import System.IO.Unsafe (unsafePerformIO) 56 | 57 | #undef CTL_MODULE 58 | 59 | -- | The kind of higher-order effects, parameterized by (1) the monad in which it was performed, and (2) the result 60 | -- type. 61 | type Effect = (Type -> Type) -> Type -> Type 62 | 63 | -- | The concrete representation of an effect context: a record of internal handler representations. 64 | type Env = Rec HandlerCell 65 | 66 | newtype HandlerCell (e :: Effect) = HandlerCell { getHandlerCell :: IORef (InternalHandler e) } 67 | 68 | -- | The effect monad; it is parameterized by the /effect context/, i.e. a row of effects available. This monad is 69 | -- implemented with evidence passing and a delimited control monad with support of efficient tail-resumptive 70 | -- (non-capturing) computations and @IO@ embedding. 71 | type role Eff nominal representational 72 | newtype Eff (es :: [Effect]) (a :: Type) = Eff { unEff :: Env es -> Ctl a } 73 | 74 | -- | The internal representation of a handler of effect @e@. This representation is only valid within the original 75 | -- context in which the effect was introduced. 76 | type role InternalHandler nominal 77 | newtype InternalHandler e = InternalHandler 78 | { runHandler :: ∀ es a. e :> es => e (Eff es) a -> Eff es a } 79 | 80 | instance Functor (Eff es) where 81 | fmap = liftM 82 | {-# INLINE fmap #-} 83 | 84 | instance Applicative (Eff es) where 85 | pure x = Eff \_ -> pure x 86 | {-# INLINE pure #-} 87 | (<*>) = ap 88 | {-# INLINE (<*>) #-} 89 | 90 | instance Monad (Eff es) where 91 | Eff m >>= f = Eff \es -> m es >>= \x -> unEff (f x) es 92 | {-# INLINE (>>=) #-} 93 | 94 | -- | The tag associated to a handler that was /introduced/ in context @es@ over an computation with 95 | -- /eventual result type/ @r@. Value of this type enables delimited control and scoped effects. 96 | data HandleTag (tag :: Type) (es :: [Effect]) (r :: Type) = HandleTag (Env es) !(Ctl.Marker r) 97 | 98 | -- | A handler of effect @e@ introduced in context @es@ over a computation returning @r@. 99 | type Handler e es r = ∀ tag esSend a. e :> esSend => HandleTag tag es r -> e (Eff esSend) a -> Eff (Handling tag : esSend) a 100 | 101 | -- | This "unsafe" @IO@ function is perfectly safe in the sense that it won't panic or otherwise cause undefined 102 | -- behaviors; it is only unsafe when it is used to embed arbitrary @IO@ actions in any effect environment, 103 | -- therefore breaking effect abstraction. 104 | unsafeIO :: IO a -> Eff es a 105 | unsafeIO m = Eff (const $ liftIO m) 106 | {-# INLINE unsafeIO #-} 107 | 108 | -- | Introduce a mutable state that is well-behaved with respect to reentry. That is, no branch will observe mutations 109 | -- by any other simultaneous branch. This stops behaving as expected if you pass the 'IORef' out of scope. 110 | unsafeState :: s -> (IORef s -> Eff es a) -> Eff es a 111 | unsafeState x0 f = Eff \es -> do 112 | ref <- liftIO $ newIORef x0 113 | Ctl.promptState ref $ unEff (f ref) es 114 | {-# INLINE unsafeState #-} 115 | 116 | -- | Convert an effect handler into an internal representation with respect to a certain effect context and prompt 117 | -- frame. 118 | toInternalHandler :: ∀ e es r. Ctl.Marker r -> Env es -> Handler e es r -> InternalHandler e 119 | toInternalHandler mark es hdl = InternalHandler \e -> alter Rec.pad $ hdl (HandleTag @() es mark) e 120 | 121 | -- | Do a trivial transformation over the effect context. 122 | alter :: (Env es' -> Env es) -> Eff es a -> Eff es' a 123 | alter f = \(Eff m) -> Eff \es -> m $! f es 124 | {-# INLINE alter #-} 125 | 126 | -- | General effect handling. Introduce a prompt frame, convert the supplied handler to an internal one wrt that 127 | -- frame, and then supply the internal handler to the given function to let it add that to the effect context. 128 | handle :: (HandlerCell e -> Env es' -> Env es) -> Handler e es' a -> Eff es a -> Eff es' a 129 | handle f = \hdl (Eff m) -> Eff \es -> do 130 | mark <- Ctl.freshMarker 131 | cell <- liftIO $ newIORef $ toInternalHandler mark es hdl 132 | Ctl.prompt mark $ m $! f (HandlerCell cell) es 133 | {-# INLINE handle #-} 134 | 135 | rehandle :: e :> es => (Env es' -> Env es) -> Handler e es' a -> Eff es a -> Eff es' a 136 | rehandle f = \hdl (Eff m) -> Eff \es -> do 137 | mark <- Ctl.freshMarker 138 | let es' = f es 139 | let cell = getHandlerCell $ Rec.index es' 140 | oldHdl <- liftIO $ readIORef cell 141 | Ctl.dynamicWind 142 | (liftIO $ writeIORef cell $ toInternalHandler mark es hdl) 143 | (liftIO $ writeIORef cell oldHdl) 144 | (Ctl.prompt mark $ m es') 145 | {-# INLINE rehandle #-} 146 | 147 | -- | Perform an effect operation. 148 | send :: e :> es => e (Eff es) a -> Eff es a 149 | send e = Eff \es -> do 150 | ih <- liftIO $ readIORef $ getHandlerCell $ Rec.index es 151 | unEff (runHandler ih e) es 152 | {-# INLINE send #-} 153 | 154 | -- | A "localized computaton"; this should be parameterized with an existential variable so the computation with this 155 | -- effect cannot escape a certain scope. 156 | data Localized (tag :: Type) :: Effect 157 | data Handling (tag :: Type) :: Effect 158 | 159 | -- | Perform an operation from the handle-site. 160 | embed :: Handling tag :> esSend => HandleTag tag es r -> Eff es a -> Eff esSend a 161 | embed (HandleTag es _) (Eff m) = Eff \_ -> m es 162 | {-# INLINE embed #-} 163 | 164 | -- | Perform an operation from the handle-site, while being able to convert an operation from the perform-site to the 165 | -- handle-site. 166 | withUnembed 167 | :: Handling tag :> esSend 168 | => HandleTag tag es r 169 | -> (∀ tag'. (∀ x. Eff esSend x -> Eff (Localized tag' : es) x) -> Eff (Localized tag' : es) a) 170 | -> Eff esSend a 171 | withUnembed (HandleTag es _) f = 172 | Eff \esSend -> unEff (f \(Eff m) -> Eff \_ -> m esSend) $! Rec.pad es 173 | {-# INLINE withUnembed #-} 174 | 175 | -- | Abort with a result value. 176 | abort :: Handling tag :> esSend => HandleTag tag es r -> Eff es r -> Eff esSend a 177 | abort (HandleTag es mark) (Eff m) = Eff \_ -> Ctl.abort mark $ m es 178 | {-# INLINE abort #-} 179 | 180 | -- | Capture and gain control of the resumption. The resumption cannot escape the scope of the controlling function. 181 | control 182 | :: Handling tag :> esSend 183 | => HandleTag tag es r 184 | -> (∀ tag'. (Eff esSend a -> Eff (Localized tag' : es) r) -> Eff (Localized tag' : es) r) 185 | -> Eff esSend a 186 | control (HandleTag es mark) f = 187 | Eff \esSend -> Ctl.control mark \cont -> unEff (f \(Eff x) -> Eff \_ -> cont $ x esSend) $! Rec.pad es 188 | {-# INLINE control #-} 189 | 190 | -- | Unwrap the 'Eff' monad. 191 | runEff :: Eff '[] a -> a 192 | runEff (Eff m) = unsafePerformIO (runCtl $ m Rec.empty) 193 | {-# INLINE runEff #-} 194 | 195 | -- | Ability to embed 'IO' side effects. 196 | data IOE :: Effect 197 | 198 | instance IOE :> es => MonadIO (Eff es) where 199 | liftIO = unsafeIO 200 | {-# INLINE liftIO #-} 201 | 202 | instance MonadThrow (Eff es) where 203 | throwM x = Eff \_ -> Catch.throwM x 204 | {-# INLINE throwM #-} 205 | 206 | instance IOE :> es => MonadCatch (Eff es) where 207 | catch (Eff m) h = Eff \es -> Catch.catch (m es) \ex -> unEff (h ex) es 208 | {-# INLINE catch #-} 209 | 210 | -- | Unwrap an 'Eff' monad with 'IO' computations. 211 | runIOE :: Eff '[IOE] a -> IO a 212 | runIOE m = runCtl $ unEff m (Rec.pad Rec.empty) 213 | {-# INLINE runIOE #-} 214 | 215 | -- | Attach a pre- and a post-action to a computation. The pre-action runs immediately before the computation, and the 216 | -- post-action runs immediately after the computation exits, whether normally, via an error, or via an exception. 217 | -- Additionally, the post-action runs immediately after any suspension of the enclosed computation and the pre-action 218 | -- runs immediately before any resumption of such suspension. 219 | -- 220 | -- Therefore, this function acts like 'Control.Exception.bracket_' when there is no resumption of suspensions involved, 221 | -- except providing no protection against async exceptions. If you want such protection, please manually supply masked 222 | -- actions. 223 | -- 224 | -- In all cases, it is guaranteed that pre- and post-actions are always executed in pairs; that is to say, it is 225 | -- impossible to have two calls to the pre-action without a call to the post-action interleaving them, or vice versa. 226 | -- This also means that the pre- and post-action are always executed the same number of times, discounting 227 | -- interruptions caused by async exceptions. 228 | dynamicWind :: Eff es () -> Eff es () -> Eff es a -> Eff es a 229 | dynamicWind (Eff before) (Eff after) (Eff action) = 230 | Eff \es -> Ctl.dynamicWind (before es) (after es) (action es) 231 | {-# INLINE dynamicWind #-} 232 | 233 | -- | Lifted version of 'Control.Exception.mask'. 234 | mask :: IOE :> es => ((∀ x. Eff es x -> Eff es x) -> Eff es a) -> Eff es a 235 | mask f = Eff \es -> Ctl.mask \unmask -> unEff (f \(Eff m) -> Eff \es' -> unmask (m es')) es 236 | {-# INLINE mask #-} 237 | 238 | -- | Lifted version of 'Control.Exception.uninterruptibleMask'. 239 | uninterruptibleMask :: IOE :> es => ((∀ x. Eff es x -> Eff es x) -> Eff es a) -> Eff es a 240 | uninterruptibleMask f = Eff \es -> Ctl.uninterruptibleMask \unmask -> unEff (f \(Eff m) -> Eff \es' -> unmask (m es')) es 241 | {-# INLINE uninterruptibleMask #-} 242 | 243 | -- | Lifted version of 'Control.Exception.interruptible'. 244 | interruptible :: IOE :> es => Eff es a -> Eff es a 245 | interruptible (Eff m) = Eff \es -> Ctl.interruptible (m es) 246 | {-# INLINE interruptible #-} 247 | -------------------------------------------------------------------------------- /src/Sp/Internal/Vec.hs: -------------------------------------------------------------------------------- 1 | -- | 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 Sp.Internal.Vec 8 | ( Vec 9 | , length 10 | , empty 11 | , cons 12 | , pad 13 | , concat 14 | , head 15 | , tail 16 | , drop 17 | , take 18 | , index 19 | , update 20 | , pick 21 | , extract 22 | , DropPhase (..) 23 | , ConcatPhase (..) 24 | ) where 25 | 26 | import Control.Monad.ST (ST) 27 | import Data.Foldable (for_) 28 | import Data.Kind (Type) 29 | import Data.Primitive.Array (Array, MutableArray, copyArray, emptyArray, indexArray, newArray, runArray, 30 | writeArray) 31 | import Prelude hiding (concat, drop, head, length, tail, take) 32 | 33 | -- | A vector (i.e. array slice) type. One special feature of this type is that it supports efficient (/O/(1)) 34 | -- prepending of "inaccessible" elements. 35 | data Vec (a :: Type) = Vec !Int !Int !(Array a) 36 | 37 | nil :: a 38 | nil = error "Sp.Internal.Vec: uninitialized element" 39 | 40 | copyArrayOffset :: MutableArray s a -> Int -> Array a -> Int -> Int -> ST s () 41 | copyArrayOffset marr ix arr off len = copyArray marr (ix - min 0 off) arr (max 0 off) len 42 | 43 | indexArrayOffset :: Array a -> Int -> a 44 | indexArrayOffset arr ix 45 | | ix < 0 = nil 46 | | otherwise = indexArray arr ix 47 | 48 | -- | Get the length of the vector. \( O(1) \). 49 | length :: Vec a -> Int 50 | length (Vec _ len _) = len 51 | 52 | -- | Create an empty record. \( O(1) \). 53 | empty :: Vec a 54 | empty = Vec 0 0 $ emptyArray 55 | 56 | -- | Prepend one entry to the vector. \( O(n) \). 57 | cons :: a -> Vec a -> Vec a 58 | cons x (Vec off len arr) = Vec 0 (len + 1) $ runArray do 59 | marr <- newArray (len + 1) x 60 | copyArrayOffset marr 1 arr off len 61 | pure marr 62 | 63 | -- | Prepend an inaccessible entry to the vector. \( O(n) \). 64 | pad :: Vec a -> Vec a 65 | pad (Vec off len arr) = Vec (off - 1) (len + 1) arr 66 | 67 | -- | Concatenate two vectors. \( O(m+n) \). 68 | concat :: Vec a -> Vec a -> Vec a 69 | concat (Vec off len arr) (Vec off' len' arr') = Vec 0 (len + len') $ runArray do 70 | marr <- newArray (len + len') nil 71 | copyArrayOffset marr 0 arr off len 72 | copyArrayOffset marr len arr' off' len' 73 | pure marr 74 | 75 | -- | Get the head of the vector. \( O(1) \). 76 | head :: Vec a -> a 77 | head (Vec off _ arr) = indexArray arr off 78 | 79 | -- | Slice off one entry from the head of the vector. \( O(1) \). 80 | tail :: Vec a -> Vec a 81 | tail (Vec off len arr) = Vec (off + 1) (len - 1) arr 82 | 83 | -- | Slice off several entries from the head of the vector. \( O(1) \). 84 | drop :: Int -> Vec a -> Vec a 85 | drop len' (Vec off len arr) = Vec (off + len') (len - len') arr 86 | 87 | -- | Take elements from the head of the vector. \( O(m) \). 88 | take :: Int -> Vec a -> Vec a 89 | take len (Vec off _ arr) = Vec 0 len $ runArray do 90 | marr <- newArray len nil 91 | copyArrayOffset marr 0 arr off (off + len) 92 | pure marr 93 | 94 | -- | Get an element in the vector. \( O(1) \). 95 | index :: Int -> Vec a -> a 96 | index ix (Vec off _ arr) = indexArray arr (off + ix) 97 | 98 | -- | Update an entry in the record. \( O(n) \). 99 | update :: Int -> a -> Vec a -> Vec a 100 | update ix x (Vec off len arr) = Vec 0 len $ runArray do 101 | marr <- newArray len nil 102 | copyArrayOffset marr 0 arr off (off + len) 103 | writeArray marr ix x 104 | pure marr 105 | 106 | -- | Get a known subset of the vector. \( O(m) \). 107 | pick :: Int -> [Int] -> Vec a -> Vec a 108 | pick len ixs (Vec off _ arr) = Vec 0 len $ runArray do 109 | marr <- newArray len nil 110 | for_ (zip [0..] ixs) \(newIx, oldIx) -> 111 | writeArray marr newIx $ indexArrayOffset arr (off + oldIx) 112 | pure marr 113 | 114 | -- | A drop operation: either empty the entire vector or drop a certain number of entries from the head. 115 | data DropPhase = EmptyOp | DropOp !Int 116 | 117 | -- | A drop-and-concat operation: perform a drop operation, then optionally concat back some entries from the original 118 | -- vector. 119 | data ConcatPhase = IdOp DropPhase | ConcatOp !Int [Int] DropPhase 120 | 121 | -- | Extract a subset out of the vector. \( O(n) \). 122 | extract :: ConcatPhase -> Vec a -> Vec a 123 | extract ext (Vec off len arr) = case ext of 124 | IdOp ro -> case ro of 125 | EmptyOp -> Vec 0 0 emptyArray 126 | DropOp dropped -> Vec (off + dropped) (len - dropped) arr 127 | ConcatOp added addIxs ro -> case ro of 128 | EmptyOp -> Vec 0 added $ runArray do 129 | marr <- newArray added nil 130 | for_ (zip [0..] $ addIxs) \(newIx, oldIx) -> 131 | writeArray marr newIx $ indexArrayOffset arr (off + oldIx) 132 | pure marr 133 | DropOp dropped -> Vec 0 (len - dropped + added) $ runArray do 134 | marr <- newArray (len - dropped + added) nil 135 | for_ (zip [0..] $ addIxs) \(newIx, oldIx) -> 136 | writeArray marr newIx $ indexArrayOffset arr (off + oldIx) 137 | for_ [0 .. len - dropped - 1] \ix -> 138 | writeArray marr (added + ix) $ indexArrayOffset arr (off + dropped + ix) 139 | pure marr 140 | -------------------------------------------------------------------------------- /src/Sp/NonDet.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | module Sp.NonDet 3 | ( -- * Nondeterminism 4 | NonDet (..) 5 | , choice 6 | , runNonDet 7 | -- Culling 8 | , Cull (..) 9 | , cull 10 | , runCull 11 | -- Cutting 12 | , Cut (..) 13 | , call 14 | , cutfail 15 | , cut 16 | , runCut 17 | ) where 18 | 19 | import Control.Applicative (Alternative (empty, (<|>))) 20 | import Debug.Trace 21 | import Sp.Eff 22 | import Sp.Error 23 | 24 | -- | Provides nondeterministic choice. 25 | data NonDet :: Effect where 26 | Empty :: NonDet m a 27 | Choice :: [a] -> NonDet m a 28 | 29 | -- | Nondeterministic choice. 30 | choice :: NonDet :> es => [a] -> Eff es a 31 | choice etc = send (Choice etc) 32 | 33 | handleNonDet :: Alternative f => Handler NonDet es (f a) 34 | handleNonDet tag = \case 35 | Empty -> abort tag $ pure empty 36 | Choice etc -> control tag \cont -> 37 | let collect [] acc = pure acc 38 | collect (e : etc') acc = do 39 | xs <- cont (pure e) 40 | collect etc' $! (acc <|> xs) 41 | in collect etc empty 42 | {-# INLINABLE handleNonDet #-} 43 | 44 | -- | Run the 'NonDet' effect, with the nondeterministic choice provided by an 'Alternative' instance. 45 | runNonDet :: Alternative f => Eff (NonDet : es) a -> Eff es (f a) 46 | runNonDet = interpret handleNonDet . fmap pure 47 | {-# INLINABLE runNonDet #-} 48 | 49 | instance NonDet :> es => Alternative (Eff es) where 50 | empty = send Empty 51 | m <|> n = do 52 | x <- send (Choice [True, False]) 53 | if x then m else n 54 | 55 | data Cull :: Effect where 56 | Cull :: NonDet :> esSend => Eff esSend a -> Cull (Eff esSend) a 57 | 58 | cull :: (Cull :> es, NonDet :> es) => Eff es a -> Eff es a 59 | cull m = send (Cull m) 60 | 61 | handleCull :: Handler Cull es a 62 | handleCull _tag = \case 63 | Cull m -> maybe empty pure 64 | =<< replace (handleNonDet @Maybe) (fmap Just m) 65 | 66 | runCull :: Eff (Cull : es) a -> Eff es a 67 | runCull = interpret handleCull 68 | 69 | data Cut :: Effect where 70 | Call :: NonDet :> esSend => Eff esSend a -> Cut (Eff esSend) a 71 | Cutfail :: Cut m a 72 | 73 | call :: (Cut :> es, NonDet :> es) => Eff es a -> Eff es a 74 | call m = send (Call m) 75 | 76 | cutfail :: Cut :> es => Eff es a 77 | cutfail = send Cutfail 78 | 79 | cut :: (Cut :> es, NonDet :> es) => Eff es () 80 | cut = pure () <|> cutfail 81 | 82 | data CutBail a = CutBail [a] 83 | 84 | handleCut :: forall a es. (NonDet :> es, Error (CutBail a) :> es) => Handler Cut es a 85 | handleCut tag = \case 86 | Call m -> do 87 | err <- runError $ replace0 handleNonDetCut $ fmap (:[]) $ replace handleCut m 88 | case err of 89 | Left (CutBail xs) -> choice xs 90 | Right xs -> choice xs 91 | Cutfail -> embed tag $ throwError $ CutBail @a [] 92 | 93 | handleNonDetCut :: forall a es. Error (CutBail a) :> es => Handler NonDet es [a] 94 | handleNonDetCut tag = \case 95 | Empty -> abort tag $ pure [] 96 | Choice etc -> control tag \cont -> 97 | let collect [] acc = pure acc 98 | collect (e : etc') acc = 99 | tryError (cont $ pure e) >>= \case 100 | Left (CutBail xs) -> trace "caught" $ throwError $ CutBail @a (acc ++ xs) 101 | Right xs -> collect etc' $! (acc ++ xs) 102 | in collect etc [] 103 | 104 | runCut :: NonDet :> es => Eff (Cut : es) a -> Eff es a 105 | runCut m = do 106 | err <- runError $ interpret handleCut $ send $ Call m 107 | case err of 108 | Left (CutBail xs) -> choice xs 109 | Right a -> pure a 110 | -------------------------------------------------------------------------------- /src/Sp/Reader.hs: -------------------------------------------------------------------------------- 1 | module Sp.Reader 2 | ( -- * Reader 3 | Reader (..) 4 | , ask 5 | , local 6 | , runReader 7 | ) where 8 | 9 | import Data.Kind (Type) 10 | import Sp.Eff 11 | 12 | -- | Provides an environment value of type @r@, and you can override it in a local scope. 13 | data Reader (r :: Type) :: Effect where 14 | Ask :: Reader r m r 15 | Local :: (r -> r) -> m a -> Reader r m a 16 | 17 | -- | Obtain the environment value. 18 | ask :: Reader r :> es => Eff es r 19 | ask = send Ask 20 | 21 | -- | Override the environment value in a local scope. 22 | local :: Reader r :> es => (r -> r) -> Eff es a -> Eff es a 23 | local f m = send (Local f m) 24 | 25 | handleReader :: r -> Handler (Reader r) es a 26 | handleReader !r _ = \case 27 | Ask -> pure r 28 | Local f m -> replace (handleReader $ f r) m 29 | 30 | -- | Run the 'Reader' effect with an environment value. 31 | runReader :: r -> Eff (Reader r : es) a -> Eff es a 32 | runReader r = interpret (handleReader r) 33 | -------------------------------------------------------------------------------- /src/Sp/State.hs: -------------------------------------------------------------------------------- 1 | module Sp.State 2 | ( -- * State 3 | State (..) 4 | , get 5 | , put 6 | , modify 7 | , state 8 | , runState 9 | ) where 10 | 11 | import Data.Functor (($>)) 12 | import Data.IORef (IORef, readIORef, writeIORef) 13 | import Sp.Eff 14 | import Sp.Internal.Monad (unsafeIO, unsafeState) 15 | 16 | 17 | -- | Provides a mutable state of type @s@. 18 | data State s :: Effect where 19 | Get :: State s m s 20 | Put :: s -> State s m () 21 | State :: (s -> (s, a)) -> State s m a 22 | 23 | -- | Get the mutable state. 24 | get :: State s :> es => Eff es s 25 | get = send Get 26 | 27 | -- | Write a new value to the mutable state. 28 | put :: State s :> es => s -> Eff es () 29 | put x = send (Put x) 30 | 31 | -- | Apply a function to the mutable state. 32 | modify :: State s :> es => (s -> s) -> Eff es () 33 | modify f = state ((, ()) . f) 34 | 35 | -- | Apply a function of type @s -> (s, a)@ on the mutable state, using the returned @s@ as the new state and 36 | -- returning the @a@. 37 | state :: State s :> es => (s -> (s, a)) -> Eff es a 38 | state f = send (State f) 39 | 40 | handleState :: IORef s -> Handler (State s) es a 41 | handleState r _ = \case 42 | Get -> unsafeIO (readIORef r) 43 | Put s -> unsafeIO (writeIORef r s) 44 | State f -> unsafeIO do 45 | (!s1, x) <- f <$> readIORef r 46 | writeIORef r s1 $> x 47 | 48 | -- | Run the 'State' effect with an initial value for the mutable state. 49 | runState :: s -> Eff (State s : es) a -> Eff es (a, s) 50 | runState s m = unsafeState s \r -> do 51 | x <- interpret (handleState r) m 52 | s' <- unsafeIO (readIORef r) 53 | pure (x, s') 54 | -------------------------------------------------------------------------------- /src/Sp/Writer.hs: -------------------------------------------------------------------------------- 1 | module Sp.Writer 2 | ( -- * Writer 3 | Writer (..) 4 | , tell 5 | , listen 6 | , runWriter 7 | ) where 8 | 9 | import Data.Foldable (for_) 10 | import Data.IORef (IORef, modifyIORef', readIORef) 11 | import Data.Kind (Type) 12 | import Sp.Eff 13 | import Sp.Internal.Monad (unsafeIO, unsafeState) 14 | 15 | -- | Provides an append-only state, and also allows you to record what is appended in a specific scope. 16 | data Writer (w :: Type) :: Effect where 17 | Tell :: w -> Writer w m () 18 | Listen :: m a -> Writer w m (a, w) 19 | 20 | -- | Append a value to the state. 21 | tell :: Writer w :> es => w -> Eff es () 22 | tell x = send (Tell x) 23 | 24 | -- | Record what is appended in a specific scope. 25 | listen :: Writer w :> es => Eff es a -> Eff es (a, w) 26 | listen m = send (Listen m) 27 | 28 | handleWriter :: ∀ w es a. Monoid w => [IORef w] -> Handler (Writer w) es a 29 | handleWriter rs _ = \case 30 | Tell x -> for_ rs \r -> unsafeIO (modifyIORef' r (<> x)) 31 | Listen m -> unsafeState mempty \r -> do 32 | x <- replace (handleWriter $ r : rs) m 33 | w' <- unsafeIO (readIORef r) 34 | pure (x, w') 35 | {-# INLINABLE handleWriter #-} 36 | 37 | -- | Run the 'Writer' state, with the append-only state as a monoidal value. 38 | runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w) 39 | runWriter m = unsafeState mempty \r -> do 40 | x <- interpret (handleWriter [r]) m 41 | w' <- unsafeIO (readIORef r) 42 | pure (x, w') 43 | {-# INLINABLE runWriter #-} 44 | --------------------------------------------------------------------------------