bluefin-internal 0.6.0.0 → 0.7.0.0

raw patch · 6 files changed

+173/−63 lines, 6 filesdep +vaultPVP ok

version bump matches the API change (PVP)

Dependencies added: vault

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• bluefin-internal.cabal +5/−3
• src/Bluefin/Internal.hs +79/−34
• src/Bluefin/Internal/CloneableHandle.hs +9/−9
• src/Bluefin/Internal/Vault.hs +37/−0
• test/Main.hs +36/−17

@@ -1,3 +1,10 @@+# 0.7.0.0++* Fix `Reader` bug that caused incorrect scoping in+  `awaitYield`/`connectRequests`/`streamConsume`/`connectCoroutines`++  <https://github.com/tomjaguarpaw/bluefin/issues/98>+ # 0.6.0.0  * Changed type of `runEff` to match `runEff_`

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               bluefin-internal-version:            0.6.0.0+version:            0.7.0.0 license:            MIT license-file:       LICENSE author:             Tom Ellis@@ -82,7 +82,8 @@       primitive >= 0.8 && < 0.10,       transformers < 0.7,       transformers-base < 0.5,-      monad-control < 1.1+      monad-control < 1.1,+      vault >= 0.3     exposed-modules:       Bluefin.Internal,       Bluefin.Internal.CloneableHandle,@@ -97,7 +98,8 @@       Bluefin.Internal.OneWayCoercible,       Bluefin.Internal.Pipes,       Bluefin.Internal.Prim,-      Bluefin.Internal.System.IO+      Bluefin.Internal.System.IO,+      Bluefin.Internal.Vault  test-suite bluefin-test     import:           defaults

@@ -16,11 +16,16 @@ import Bluefin.Internal.OneWayCoercible   ( OneWayCoercible (oneWayCoercibleImpl),     OneWayCoercibleD,+    OneWayCoercion,     gOneWayCoercible,     oneWayCoerce,     oneWayCoercible,+    oneWayCoercion,+    unsafeCoercionOfOneWayCoercion,     unsafeOneWayCoercible,   )+import Bluefin.Internal.Vault (Vault)+import Bluefin.Internal.Vault qualified as Vault import Control.Concurrent.Async qualified as Async import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import Control.Exception qualified@@ -30,10 +35,11 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) import Control.Monad.Trans.Control (MonadBaseControl, StM, liftBaseWith, restoreM)+import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Trans.Reader qualified as Reader import Data.Coerce (coerce) import Data.Foldable (for_)-import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.IORef (IORef, modifyIORef, newIORef, readIORef, writeIORef) import Data.Kind (Type) import Data.Proxy (Proxy (Proxy)) import Data.Type.Coercion (Coercion (Coercion))@@ -55,14 +61,16 @@  type (:&) = Union -newtype Eff (es :: Effects) a = UnsafeMkEff {unsafeUnEff :: IO a}+type Env = IORef Vault++newtype Eff (es :: Effects) a = UnsafeMkEff {unsafeUnEff :: Env -> IO a}   deriving stock (Functor)-  deriving newtype (Applicative, Monad, MonadFix)+  deriving (Applicative, Monad, MonadFix) via ReaderT Env IO  type role Eff nominal representational  instance (e <: es) => OneWayCoercible (Eff e) (Eff es) where-  oneWayCoercibleImpl = oneWayCoercible+  oneWayCoercibleImpl = unsafeOneWayCoercible  instance (e <: es) => OneWayCoercible (Eff e r) (Eff es r) where   oneWayCoercibleImpl = oneWayCoercible@@ -89,7 +97,7 @@   ((forall r. (forall e1. IOE e1 -> Eff (e1 :& es) r) -> IO r) -> IO a) ->   IOE e2 ->   Eff es a-withEffToIO k io = effIO io (k (\f -> unsafeUnEff (f io)))+withEffToIO k io = UnsafeMkEff (\env -> k (\f -> unsafeUnEff (f io) env))  withEffToIO' ::   (e2 <: es) =>@@ -142,15 +150,24 @@   Eff es a race x y io = do   r <- withEffToIO' io $ \toIO ->-    Async.race (toIO x) (toIO y)+    Async.race (toIO (withClonedEnv . x)) (toIO (withClonedEnv . y))    pure $ case r of     Left a -> a     Right a -> a +withClonedEnv :: Eff es r -> Eff es r+withClonedEnv m = UnsafeMkEff $ \vault -> do+  vault' <- cloneIORef vault+  case m of UnsafeMkEff m' -> m' vault'+  where+    cloneIORef ref = do+      orig <- readIORef ref+      newIORef orig+ -- | Connect two coroutines.  Their execution is interleaved by--- exchanging @a@s and @b@s. When the first yields its first @a@ it--- starts the second (which is awaiting an @a@).+-- exchanging @a@s and @b@s. When the former yields its first @a@ it+-- starts the latter (which is awaiting an @a@). connectCoroutines ::   forall es a b r.   (forall e. Coroutine a b e -> Eff (e :& es) r) ->@@ -1491,7 +1508,7 @@   IO a ->   -- | ͘   Eff es a-effIO MkIOE = UnsafeMkEff+effIO MkIOE = UnsafeMkEff . const  -- | Run an 'Eff' whose only unhandled effect is 'IO'. --@@ -1520,7 +1537,9 @@   (forall e. IOE e -> Eff e a) ->   -- | ͘   IO a-runEff_ eff = unsafeUnEff (eff MkIOE)+runEff_ eff = do+  emptyEnv <- newIORef Vault.empty+  unsafeUnEff (eff MkIOE) emptyEnv  unsafeProvideIO ::   (forall e. IOE e -> Eff (e :& es) a) ->@@ -1616,18 +1635,25 @@   Eff es () tell (Writer y) = yield y -newtype Reader r e = MkReader (State r e)-  deriving newtype (Handle)+newtype Reader r e = MkReader (Vault.Key r)+  deriving (Handle) via OneWayCoercibleHandle (Reader r)  instance (e <: es) => OneWayCoercible (Reader r e) (Reader r es) where   oneWayCoercibleImpl = oneWayCoercible +type role Reader representational nominal+ runReader ::   -- | Initial value for @Reader@.   r ->   (forall e. Reader r e -> Eff (e :& es) a) ->   Eff es a-runReader r f = evalState r (f . MkReader)+runReader r f = do+  k <- UnsafeMkEff $ \vault -> do+    k <- Vault.newKey+    modifyIORef vault (\v -> Vault.insert k r v)+    pure k+  makeOp (f (MkReader k))  -- | Read the value.  Note that @ask@ has the property that these two -- operations are always equivalent:@@ -1649,7 +1675,22 @@   -- | ͘   Reader r e ->   Eff es r-ask (MkReader st) = get st+ask (MkReader k) = UnsafeMkEff $ \vault -> do+  v <- readIORef vault+  case Vault.lookup k v of+    Nothing -> error msg+    Just ref -> pure ref+  where+    msg =+      unlines+        [ "ask called on out of scope reference",+          unwords+            [ "If you haven't subverted Bluefin's type system",+              "then this is a Bluefin bug.",+              "Please report it at",+              "https://github.com/tomjaguarpaw/bluefin/issues/new"+            ]+        ]  -- | Read the value modified by a function asks ::@@ -1658,7 +1699,7 @@   -- | Read the value modified by this function   (r -> a) ->   Eff es a-asks (MkReader st) f = fmap f (get st)+asks r f = fmap f (ask r)  -- | Locally override the value in the @Reader@. It will be restored -- when the @local@ block ends.@@ -1670,14 +1711,14 @@   -- | Body   Eff es a ->   Eff es a-local (MkReader st) f k = do-  orig <- get st-  bracket-    (put st (f orig))-    (\() -> put st orig)-    (\() -> k)+local (MkReader key) f k = UnsafeMkEff $ \env@vault -> do+  orig <- readIORef vault+  Control.Exception.bracket+    (writeIORef vault (Vault.adjust f key orig))+    (\() -> writeIORef vault orig)+    (\() -> case k of UnsafeMkEff m -> m env) -newtype HandleReader h e = UnsafeMkHandleReader (State (h e) e)+newtype HandleReader h e = UnsafeMkHandleReader (Reader (h e) e)   deriving (Handle) via OneWayCoercibleHandle (HandleReader h)  -- In general this is really tremendously unsafe because we could take@@ -1695,8 +1736,12 @@   HandleReader h es mapHandleReader = case coerceH of Coercion -> coerce   where+    oneWayCoerceH :: OneWayCoercion (h e) (h es)+    oneWayCoerceH = case handleDictOfHandleD (handleImpl @h) of+      MkHandleDict -> oneWayCoercion+     coerceH :: Coercion (h e) (h es)-    coerceH = unsafeCoerce (Coercion :: Coercion (h e) (h e))+    coerceH = unsafeCoercionOfOneWayCoercion oneWayCoerceH  localHandle ::   (e <: es, Handle h) =>@@ -1705,20 +1750,16 @@   Eff es r ->   -- | ͘   Eff es r-localHandle hh@(UnsafeMkHandleReader st) f k = do-  let UnsafeMkHandleReader st' = mapHandle hh-  orig <- get st-  bracket-    (put st' (f (mapHandle orig)))-    (\() -> put st orig)-    (\() -> k)+localHandle hh f k = do+  let UnsafeMkHandleReader st = mapHandle hh+  local st f k  askHandle ::   (e <: es, Handle h) =>   HandleReader h e ->   -- | ͘   Eff es (h es)-askHandle hh = let UnsafeMkHandleReader st = mapHandle hh in get st+askHandle hh = let UnsafeMkHandleReader st = mapHandle hh in ask st  asksHandle ::   (e1 <: es, Handle h) =>@@ -1737,11 +1778,15 @@   -- | ͘   Eff es r runHandleReader h k = do-  evalState (mapHandle h) $ \(st :: State (h es) e) -> do+  runReader (mapHandle h) $ \(st :: Reader (h es) e) -> do+    let oneWayCoerceH :: OneWayCoercion (h es) (h (e :& es))+        oneWayCoerceH = case handleDictOfHandleD (handleImpl @h) of+          MkHandleDict -> oneWayCoercion+     let coerceH :: Coercion (h es) (h (e :& es))-        coerceH = unsafeCoerce (Coercion :: Coercion (h es) (h es))+        coerceH = unsafeCoercionOfOneWayCoercion oneWayCoerceH -    let mapS :: State (h es) e' -> State (h (e :& es)) e'+    let mapS :: Reader (h es) e' -> Reader (h (e :& es)) e'         mapS = case coerceH of Coercion -> coerce      let h' :: HandleReader h (e :& es)

@@ -34,12 +34,13 @@   ((forall r. (forall e. IOE e -> h e -> Eff e r) -> IO r) -> IO a) ->   Eff es a withEffToIOCloneHandle io h k = do-  withEffToIO_ io $ \runInIO -> do-    k $ \body -> do-      runInIO $ do-        cloneHandleClass h $ \h' -> do-          cloneHandleClass io $ \io' -> do-            body (mapHandle io') (mapHandle h')+  withClonedEnv $ do+    withEffToIO_ io $ \runInIO -> do+      k $ \body -> do+        runInIO $ do+          cloneHandleClass h $ \h' -> do+            cloneHandleClass io $ \io' -> do+              body (mapHandle io') (mapHandle h')  newtype HandleCloner h1 h2 es   = MkHandleCloner@@ -98,9 +99,8 @@   cloneableHandleImpl = MkCloneableHandleD hcReader  hcReader :: HandleCloner (Reader r) (Reader r) e-hcReader = MkHandleCloner $ \(MkReader s) k -> do-  cloneHandleClass s $ \s' -> do-    useImplIn k (MkReader (mapHandle s'))+hcReader = MkHandleCloner $ \r k -> do+  useImplIn k (mapHandle r)  -- | Cloning a @HandleReader@ copies its contents to a new -- @HandleReader@.  Changes to one will not effect the other.

@@ -0,0 +1,37 @@+module Bluefin.Internal.Vault+  ( module Bluefin.Internal.Vault,+    Vault,+    Vault.empty,+  )+where++import Data.Kind (Type)+import Data.Vault.Strict (Vault)+import Data.Vault.Strict qualified as Vault+import GHC.Exts (Any)+import Unsafe.Coerce (unsafeCoerce)++-- Vault.Key doesn't have representational role for its "value"+-- argument. I think it should. We hack it.+--+--     https://github.com/HeinrichApfelmus/vault/issues/56+type Key :: Type -> Type+newtype Key a = MkKey (Vault.Key Any)++fromMine :: Key a -> Vault.Key a+fromMine (MkKey k) = unsafeCoerce k++toMine :: Vault.Key a -> Key a+toMine k = MkKey (unsafeCoerce k)++lookup :: Key a -> Vault -> Maybe a+lookup = Vault.lookup . fromMine++adjust :: (a -> a) -> Key a -> Vault -> Vault+adjust f = Vault.adjust f . fromMine++newKey :: IO (Key a)+newKey = fmap toMine Vault.newKey++insert :: Key a -> a -> Vault -> Vault+insert = Vault.insert . fromMine

@@ -39,6 +39,7 @@     test_generalBracket io y     test_streamConsumeReader y     test_streamConsumeHandleReader y+    test_unliftIOReader io y  (!?) :: [a] -> Int -> Maybe a xs !? i = runPureEff $@@ -90,9 +91,8 @@     (\y2 -> local re (const "local") (yield y2 ()))     (\() -> assertEqual y "Reader local" "local" =<< ask re) --- This test confirms the buggy behavior reported in------    https://github.com/tomjaguarpaw/bluefin/issues/98+-- local run in one branch of a streamConsume should not affect ask in+-- the other branch. test_streamConsumeReader :: (e <: es) => SpecH e -> Eff es () test_streamConsumeReader spech = do   runReader @Int 0 $ \r -> do@@ -102,23 +102,23 @@           let check i = assertEqual spech "Reader local" i =<< ask r           check 0           s-          check (-100) -- Should be 0+          check 0           s-          check (-200) -- Should be 0+          check 0           local r (+ 1) $ do-            check (-199) -- Should be 1+            check 1             s-            check (-299) -- Should be 1+            check 1             local r (+ 1) $ do-              check (-298) -- Should be 2+              check 2               s-              check (-398) -- Should be 2-            check (-299) -- Should be 1+              check 2+            check 1             s-            check (-299) -- Should be 1-          check (-200) -- Should be 0+            check 1+          check 0           s-          check (-200) -- Should be 0+          check 0       )       ( \a -> do           let p = await a@@ -133,9 +133,8 @@                   forever p       ) --- This test confirms the buggy behavior reported in------    https://github.com/tomjaguarpaw/bluefin/issues/98+-- localHandle run in one branch of a streamConsume should not affect+-- askHandle in the other branch. test_streamConsumeHandleReader :: (e <: es) => SpecH e -> Eff es () test_streamConsumeHandleReader spech = do   runConstEffect @Int 0 $ \ce ->@@ -148,7 +147,7 @@                   assertEqual spech "HandleReader local" i i'             check 0             s-            check (-100) -- Should be 0+            check 0         )         ( \a -> do             let p = await a@@ -156,3 +155,23 @@             localHandle r (\(MkConstEffect i) -> MkConstEffect (subtract 100 i)) $ do               forever p         )++-- Reader should interact well with withEffToIO_+test_unliftIOReader :: (e1 <: es, e2 <: es) => IOE e1 -> SpecH e2 -> Eff es ()+test_unliftIOReader io spech = do+  let foo :: (Int -> IO ()) -> (forall r. Int -> IO r -> IO r) -> IO ()+      foo myYield mySetLocal = do+        myYield 0+        mySetLocal 1 $ do+          myYield 1+          mySetLocal 2 $ do+            myYield 2++  runReader @Int 0 $ \r -> do+    withEffToIO_ io $ \effToIO -> do+      foo+        ( \i -> effToIO $ do+            i' <- ask r+            assertEqual spech "myLocal" i i'+        )+        (\x -> effToIO . local r (const x) . effIO io)