feat: change underlying rep of environment

spago.dhall

@@ -24,9 +24,13 @@ to generate this file without the comments in this block.
   , "transformers"
   , "typelevel-prelude"
   , "unsafe-coerce"
+  , "variant"
+  , "veither"
+  , "refs"
+  , "tuples"
   ]
 , packages = ./packages.dhall
-, sources = [ "src/**/*.purs" ]
+, sources = [ "src/**/*.purs", "test/**/*.purs" ]
 , license = "MPL-2.0"
 , repository = "https://github.com/the-dr-lazy/purescript-effectful"
 }

src/Control/Eff.purs

@@ -1,7 +1,7 @@
 {-|
 Module     : Control.Eff
 Maintainer : Mohammad Hasani (the-dr-lazy.github.io) <[email protected]>
-Copyright  : (c) 2021-2022 Effecful
+Copyright  : (c) 2021-2024 Effecful
 License    : MPL 2.0
 
 This Source Code Form is subject to the terms of the Mozilla Public
@@ -10,29 +10,33 @@ file, You can obtain one at http://mozilla.org/MPL/2.0/.
 -}
 
 module Control.Eff
-  ( module Control.Eff.Algebra
+  ( Eff(..)
   , Environment
-  , Action(..)
-  , Eff(..)
-  , mk
-  , un
-  , unsafeMkFromAff
+  , Handler
+  , expand
+  , impose
+  , interpose
   , interpret
-  , intercept
+  , module Control.Eff.Algebra
   , reinterpret
-  , expand
-  , send
   , run
+  , send
+  , un
+  , unsafeMkFromAff
+  , addHandler
   ) where
 
+import Control.Eff.Algebra
 import Prelude
 
-import Control.Eff.Algebra
 import Control.Eff.Algebra as Eff
-import Control.Eff.Variant as Eff
-import Control.Eff.Variant as Eff.Variant
+import Control.Eff.Variant (Variant)
+import Control.Eff.Variant as Variant
 import Data.Symbol (class IsSymbol)
 import Effect.Aff (Aff)
+import Effect.Class (liftEffect)
+import Effect.Ref (Ref)
+import Effect.Ref as Ref
 import Type.Proxy (Proxy)
 import Type.Row as Row
 import Unsafe.Coerce (unsafeCoerce)
@@ -54,77 +58,123 @@ instance Applicative (Eff r) where
 instance Bind (Eff r) where
   bind (UnsafeMk m) f = UnsafeMk \environment -> do
     x <- m environment
-    un (f x) environment
+    un environment (f x)
 
 instance Monad (Eff r)
 
-type Environment r = Eff.Variant r (Eff r) ~> Action r
+type Handler :: Type
+type Handler = forall a. Variant -> Aff a
 
-data Action r a = Intercept (Environment r) (Eff r a) | Interpret (Eff r a) | Perform (Aff a)
+type Environment :: Row Algebra -> Type
+type Environment r = Ref Handler
 
-mk :: forall r. Eff.Variant r (Eff r) ~> Eff r
-mk f = UnsafeMk \environment -> do
-  case environment f of
-    Perform m -> m
-    Interpret (UnsafeMk m) -> m environment
-    Intercept env (UnsafeMk m) -> m env
+-- mk :: forall r a. Variant -> Eff r a
+-- mk f = UnsafeMk \m -> m f
 
 unsafeMkFromAff :: forall r. Aff ~> Eff r
 unsafeMkFromAff m = UnsafeMk \_ -> m
 
-un :: forall r a. Eff r a -> Environment r -> Aff a
-un (UnsafeMk m) = m
+un :: forall r a. Environment r -> Eff r a -> Aff a
+un ref (UnsafeMk m) = m ref
+
+type EffectHandler f fr = f (Eff fr) ~> Eff fr
+
+handle :: forall tag f r fr. IsSymbol tag => Row.Cons tag f r fr => Environment fr -> Proxy tag -> f (Eff fr) ~> Aff
+handle environment ptag f = do
+  handler <- liftEffect $ Ref.read environment
+
+  handler (Variant.inject ptag f)
+
+addHandler :: forall tag f r fr a. IsSymbol tag => Row.Cons tag f r fr => Environment r -> Proxy tag -> (f (Eff fr) a -> Eff fr a) -> Aff (Environment fr)
+addHandler environment ptag handler = do
+  liftEffect $ Ref.modify_ (Variant.on ptag (un environment <<< handler)) (unsafeCoerce environment)
+
+  pure (unsafeCoerce environment)
+
+getHandler :: forall tag f r fr a. IsSymbol tag => Row.Cons tag f r fr => Environment fr -> Proxy tag -> Aff (Eff fr a -> Eff r a)
+getHandler environment ptag = do
+  handler <- liftEffect $ Ref.read environment
+  environment' <- liftEffect $ Ref.new (unsafeCoerce handler)
+
+  pure $ \(UnsafeMk m) -> UnsafeMk \_ -> m environment'
 
 send
-  :: forall tag f r fr a
+  :: forall tag f r fr
    . IsSymbol tag
   => Functor (f (Eff fr))
   => Row.Cons tag f r fr
   => Proxy tag
-  -> f (Eff fr) a
-  -> Eff fr a
-send ptag f = mk (Eff.Variant.inject ptag f)
+  -> f (Eff fr)
+       ~> Eff fr
+send ptag f = UnsafeMk \environment -> handle environment ptag f
 
 interpret
-  :: forall tag from r fromr
-   . Row.Cons tag from r fromr
-  => Functor (from (Eff fromr))
+  :: forall tag f r fr
+   . Row.Cons tag f r fr
+  => Functor (f (Eff fr))
   => IsSymbol tag
   => Proxy tag
-  -> (from (Eff fromr) ~> Eff fromr)
-  -> Eff fromr
+  -> EffectHandler f fr
+  -> Eff fr
        ~> Eff r
 interpret ptag interpreter (UnsafeMk m) =
-  UnsafeMk \environment ->
-    m (Eff.Variant.interpret ptag (Interpret <<< interpreter) (unsafeCoerce environment))
+  UnsafeMk \r -> do
+    fr <- addHandler r ptag interpreter
+    m fr
+
+reinterpret
+  :: forall tag f r fr h a b
+   . Row.Cons tag f r fr
+  => IsSymbol tag
+  => Functor (f (Eff fr))
+  => Proxy tag
+  -> (Eff h a -> Eff fr b)
+  -> EffectHandler f h
+  -> Eff fr a
+  -> Eff r b
+reinterpret ptag run handler m =
+  (unsafeCoerce run) $ interpret ptag (unsafeCoerce handler) m
 
-intercept
-  :: forall tag from r fromr
-   . Row.Cons tag from r fromr
+interpose
+  :: forall tag f r fr a
+   . Row.Cons tag f r fr
   => IsSymbol tag
-  => Functor (from (Eff fromr))
+  => Functor (f (Eff fr))
   => Proxy tag
-  -> (from (Eff fromr) ~> Eff fromr)
-  -> Eff fromr
-       ~> Eff fromr
-intercept ptag interceptor (UnsafeMk m) =
-  UnsafeMk \environment ->
-    m (Eff.Variant.intercept ptag (interceptor >>> Intercept environment) environment)
+  -> EffectHandler f fr
+  -> Eff fr a
+  -> Eff fr a
+interpose ptag handler (UnsafeMk m) =
+  UnsafeMk \environment -> do
+    run <- getHandler environment ptag
 
-expand :: forall from r fromr. Row.Union from r fromr => Eff from ~> Eff fromr
-expand = unsafeCoerce
+    let
+      f :: f (Eff fr) a -> Eff r a
+      f = run <<< handler
 
-reinterpret
-  :: forall tag from r tor fromr fromtor
-   . Row.Cons tag from r fromr
-  => Row.Cons tag from tor fromtor
-  => IsSymbol tag
-  => Functor (from (Eff fromtor))
+      u :: f (Eff fr) a -> Eff fr a
+      u = unsafeCoerce
+
+    _ <- addHandler environment ptag u
+
+    m environment
+
+impose
+  :: forall tag f r fr h a b
+   . IsSymbol tag
+  => Row.Cons tag f r fr
+  => Functor (f (Eff fr))
   => Proxy tag
-  -> (from (Eff fromtor) ~> Eff fromtor)
-  -> Eff fromr
-       ~> Eff tor
-reinterpret ptag reinterpreter m = interpret ptag reinterpreter (unsafeCoerce m)
+  -> (Eff h a -> Eff fr b)
+  -> EffectHandler f h
+  -> Eff fr a
+  -> Eff fr b
+impose ptag run handler m = (unsafeCoerce run) $ interpose ptag (unsafeCoerce handler) m
+
+expand :: forall from r fromr. Row.Union from r fromr => Eff from ~> Eff fromr
+expand = unsafeCoerce
 
-run :: forall a. Eff () a -> Aff a
-run (UnsafeMk m) = m Eff.Variant.empty
+run :: Eff () ~> Aff
+run (UnsafeMk m) = do
+  ref <- liftEffect $ unsafeCoerce (Ref.new Variant.empty)
+  m ref

src/Control/Eff/Algebra.purs

@@ -1,7 +1,7 @@
 {-|
 Module     : Control.Eff.Algebra
 Maintainer : Mohammad Hasani (the-dr-lazy.github.io) <[email protected]>
-Copyright  : (c) 2021-2022 Effecful
+Copyright  : (c) 2021-2024 Effecful
 License    : MPL 2.0
 
 This Source Code Form is subject to the terms of the Mozilla Public

src/Control/Eff/Except.js

@@ -1,25 +1,29 @@
 /*
  * Maintainer : Mohammad Hasani (the-dr-lazy.github.io) <[email protected]>
- * Copyright  : (c) 2021-2022 Effecful
+ * Copyright  : (c) 2021-2024 Effecful
  * License    : MPL 2.0
  *
  * This Source Code Form is subject to the terms of the Mozilla Public
  * License, version 2.0. If a copy of the MPL was not distributed with this
  * file, You can obtain one at http://mozilla.org/MPL/2.0/.
  */
 
+var _symbol = Symbol('Except')
+
 exports.foreign_mkCustomError = function (r) {
     var e = new Error('Control.Eff.Except: unhandled exception (' + r.tag + ')')
-    e._tag = r.tag
-    e._value = r.value
+
+    e[_symbol] = r
 
     return e
 }
 
-exports.foreign_parseCustomError = function (r) {
-    if (r.error._tag !== r.tag) {
+exports.foreign_parseCustomError = function (error) {
+    const r = e[_symbol]
+
+    if (r !== undefined) {
         return null
     }
 
-    return r.error._value
+    return r
 }

src/Control/Eff/Except.purs

@@ -1,7 +1,7 @@
 {-|
 Module     : Control.Eff.Except
 Maintainer : Mohammad Hasani (the-dr-lazy.github.io) <[email protected]>
-Copyright  : (c) 2021-2022 Effecful
+Copyright  : (c) 2021-2024 Effecful
 License    : MPL 2.0
 
 This Source Code Form is subject to the terms of the Mozilla Public
@@ -11,18 +11,21 @@ file, You can obtain one at http://mozilla.org/MPL/2.0/.
 
 module Control.Eff.Except where
 
-import Data.Either
-import Data.Maybe
 import Prelude
-import Type.Proxy
 
 import Control.Eff (Eff)
 import Control.Eff as Eff
 import Control.Monad.Error.Class (catchError, throwError)
+import Data.Either (Either(..))
+import Data.Maybe (Maybe(..))
 import Data.Nullable (Nullable)
 import Data.Nullable as Nullable
 import Data.Symbol (class IsSymbol, reflectSymbol)
+import Data.Variant (Variant)
+import Data.Variant.Internal (VariantRep(..))
+import Data.Veither (Veither(..))
 import Effect.Exception (Error)
+import Type.Proxy (Proxy(..))
 import Type.Row (type (+))
 import Type.Row as Row
 import Unsafe.Coerce (unsafeCoerce)
@@ -56,13 +59,24 @@ catchAs
   -> Eff (Except es + r) a
   -> Eff (Except s + r) a
 catchAs ptag handler (Eff.UnsafeMk m) = Eff.UnsafeMk \environment ->
-  m (unsafeCoerce environment) `catchError` \error -> case parseCustomError ptag error of
-    Just e -> Eff.un (handler e) environment
+  m (unsafeCoerce environment) `catchError` \error -> case parseCustomErrorAs ptag error of
+    Just e -> Eff.un environment (handler e)
     Nothing -> throwError error
 
 catch :: forall e s r a. (e -> Eff (Except s + r) a) -> Eff (Except (error :: e | s) + r) a -> Eff (Except s + r) a
 catch = catchAs (Proxy :: Proxy "error")
 
+catchAll
+  :: forall es r fr a
+   . Row.Cons "except" (ExceptF es) r fr
+  => (Variant es -> Eff r a)
+  -> Eff fr a
+  -> Eff r a
+catchAll handler (Eff.UnsafeMk m) = Eff.UnsafeMk \environment ->
+  m (unsafeCoerce environment) `catchError` \error -> case parseCustomError error of
+    Just e -> Eff.un environment (handler e)
+    Nothing -> throwError error
+
 tryAs
   :: forall tag e s es r a
    . Row.Cons tag e s es
@@ -75,6 +89,14 @@ tryAs ptag m = catchAs ptag (pure <<< Left) (Right <$> m)
 try :: forall e s r a. Eff (Except (error :: e | s) + r) a -> Eff (Except s + r) (Either e a)
 try = tryAs (Proxy :: Proxy "error")
 
+tryAll
+  :: forall es r a
+   . Eff (Except es + r) a
+  -> Eff r (Veither es a)
+tryAll m = catchAll (pure <<< Veither <<< unsafeExpand) (pure <$> m)
+  where
+  unsafeExpand = unsafeCoerce :: forall r1 r2. Variant r1 -> Variant r2
+
 noteAs
   :: forall tag e s es r a
    . Row.Cons tag e s es
@@ -104,12 +126,31 @@ rethrowAs ptag = case _ of
 rethrow :: forall e s r a. Either e a -> Eff (Except (error :: e | s) + r) a
 rethrow = rethrowAs (Proxy :: Proxy "error")
 
+-- vrethrow :: forall es r a. Veither es a -> Eff (Except es + r) a
+-- vrethrow =
+
 run :: forall r. Eff (Except () + r) ~> Eff r
 run = unsafeCoerce
 
-foreign import foreign_mkCustomError :: forall es. { tag :: String, value :: es } -> Error
+type X e = { tag :: String, value :: e }
+
+foreign import foreign_mkCustomError :: forall e. X e -> Error
+
+foreign import foreign_parseCustomError :: forall e. Error -> Nullable (X e)
+
+parseCustomError :: forall es. Error -> Maybe (Variant es)
+parseCustomError error = toVariant <$> Nullable.toMaybe (foreign_parseCustomError error)
+  where
+  toVariant :: forall a. X a -> Variant es
+  toVariant e = unsafeCoerce (VariantRep { type: e.tag, value: e.value })
 
-foreign import foreign_parseCustomError :: forall es. { tag :: String, error :: Error } -> Nullable es
+parseCustomErrorAs :: forall tag e. IsSymbol tag => Proxy tag -> Error -> Maybe e
+parseCustomErrorAs ptag error = parseCustomError error >>= prj ptag
+  where
+  prj :: forall p r. IsSymbol p => Proxy p -> Variant r -> Maybe e
+  prj p r = case coerceV r of
+    VariantRep v | v.type == reflectSymbol p -> Just v.value
+    _ -> Nothing
 
-parseCustomError :: forall tag es. IsSymbol tag => Proxy tag -> Error -> Maybe es
-parseCustomError ptag error = Nullable.toMaybe (foreign_parseCustomError { tag: reflectSymbol ptag, error })
+  coerceV :: forall r. Variant r -> VariantRep e
+  coerceV = unsafeCoerce