bluefin-internal 0.3.3.0 → 0.3.4.0

raw patch · 9 files changed

+445/−86 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• bluefin-internal.cabal +5/−2
• src/Bluefin/Internal.hs +6/−2
• src/Bluefin/Internal/CloneableHandle.hs +6/−1
• src/Bluefin/Internal/Exception.hs +240/−0
• src/Bluefin/Internal/Exception/Scoped.hs +12/−3
• test/Main.hs +4/−78
• test/Test/GeneralBracket.hs +96/−0
• test/Test/SpecH.hs +68/−0

@@ -1,3 +1,11 @@+# 0.3.4.0++* Add `Bluefin.Internal.Exception` and tests, thanks to Shea Levy++* Export `Bluefin.Internal.Exception.Scoped.Exception` constructors++* Export `Bluefin.Internal.Exception.Scoped.check`+ # 0.3.3.0  * Add `finally`

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               bluefin-internal-version:            0.3.3.0+version:            0.3.4.0 license:            MIT license-file:       LICENSE author:             Tom Ellis@@ -76,7 +76,7 @@     hs-source-dirs: src     build-depends:       async >= 2.2 && < 2.3,-      base >= 4.14 && < 4.22,+      base >= 4.14 && < 4.23,       unliftio-core < 0.3,       transformers < 0.7,       transformers-base < 0.5,@@ -87,6 +87,7 @@       Bluefin.Internal.DslBuilder,       Bluefin.Internal.DslBuilderEffects,       Bluefin.Internal.Examples,+      Bluefin.Internal.Exception,       Bluefin.Internal.Exception.Scoped,       Bluefin.Internal.Key,       Bluefin.Internal.OneWayCoercible,@@ -99,6 +100,8 @@     type:             exitcode-stdio-1.0     hs-source-dirs:   test     main-is:          Main.hs+    other-modules:    Test.GeneralBracket,+                      Test.SpecH     build-depends:         base,         bluefin-internal

@@ -753,7 +753,7 @@   Eff es a ->   -- | Release the resource   (a -> Eff es ()) ->-  -- | Run the body+  -- | Run the body with resource   (a -> Eff es b) ->   Eff es b bracket before after body =@@ -764,9 +764,13 @@         (effToIO . useImpl . after)         (effToIO . useImpl . body) +-- | A simpler variant of 'bracket` for use when you don't need to+-- acquire a resource. finally ::-  -- | Run the body+  -- | Body   Eff es b ->+  -- | Final action to run after the body, regardless of whether the+  -- body terminated normally or via exception   Eff es () ->   Eff es b finally body after =

@@ -150,13 +150,18 @@   -- FIXME: These instances for higher rank types are annoying   oneWayCoercibleImpl = unsafeOneWayCoercible -abstract :: (Handle h2) => (forall e. h1 e -> h2 (e :& es)) -> (h1 :~> h2) es+abstract ::+  (Handle h2) =>+  (forall e. h1 e -> h2 (e :& es)) ->+  -- | ͘+  (h1 :~> h2) es abstract k = MkArrow (mapHandle . k)  app ::   (Handle h2) =>   (h1 :~> h2) e ->   h1 e ->+  -- | ͘   h2 e app (MkArrow f) h1 = makeOpHandle (f h1)   where

@@ -0,0 +1,240 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE RecordWildCards #-}++module Bluefin.Internal.Exception where++import Bluefin.Internal hiding (UnsafeMkEff, b)+import Bluefin.Internal.CloneableHandle (app, (:~>))+import Bluefin.Internal.Exception.Scoped (InFlight)+import Bluefin.Internal.Exception.Scoped qualified as SE+import Bluefin.Internal.OneWayCoercible+  ( Generic,+    OneWayCoercible (oneWayCoercibleImpl),+    gOneWayCoercible,+    oneWayCoerce,+    unsafeOneWayCoercible,+  )+import Control.Exception qualified as CE+import Data.Proxy (Proxy)++data HandledKey ret = forall ex. MkHandledKey !(SE.Exception ex) (ex -> ret)++checkHandledKey :: HandledKey ret -> InFlight -> Maybe ret+checkHandledKey (MkHandledKey k handler) inflight =+  handler <$> SE.checkException k inflight++instance Functor HandledKey where+  fmap f (MkHandledKey ex r) = MkHandledKey ex (fmap f r)++runBodyWithHandlers ::+  ( [HandledKey (r -> Eff es a)],+    BracketBase b r a es+  ) ->+  Eff es a+runBodyWithHandlers (handledKeys, bb) =+  unsafeProvideIO $ \io -> withEffToIO_ io $ \runInIO -> do+    let MkBracketBase {..} = useImplBracketBase bb+    CE.mask $ \unmasked -> do+      resource <- runInIO acquire+      eBodyRes <-+        (CE.try . unmasked . runInIO . body) resource+      runInIO $ case eBodyRes of+        Right bodyRes -> normalRelease resource bodyRes+        Left e -> case CE.fromException e >>= findHandler handledKeys of+          Nothing -> do+            unknownExceptionRelease resource+            effIO io (CE.throwIO e)+          Just handler -> useImpl (handler resource)+  where+    firstJust _ [] = Nothing+    firstJust f (x : xs) = case f x of+      Nothing -> firstJust f xs+      Just r -> Just r++    findHandler :: [HandledKey a] -> SE.InFlight -> Maybe a+    findHandler hks inflight = firstJust (flip checkHandledKey inflight) hks++-- | To create a @MakeExceptions@ use 'catchWithResource' and the+-- @Applicative@-like functions that produce and combine them.+newtype MakeExceptions r a h es+  = MkMakeExceptions (Eff es (HandlerUnwrapped r a h es))++data HandlerUnwrapped r a h es+  = MkHandlerUnwrapped+      [HandledKey (r -> Eff es a)]+      (forall b. (forall e. h e -> Eff (e :& es) b) -> Eff es b)++instance (Handle h) => Handle (MakeExceptions r a h) where+  handleImpl = handleOneWayCoercible++instance (Handle h) => Handle (HandlerUnwrapped r a h) where+  handleImpl = handleOneWayCoercible++instance+  (Handle h, e :> es) =>+  OneWayCoercible (MakeExceptions r a h e) (MakeExceptions r a h es)+  where+  oneWayCoercibleImpl = unsafeOneWayCoercible++instance+  (Handle h, e :> es) =>+  OneWayCoercible (HandlerUnwrapped r a h e) (HandlerUnwrapped r a h es)+  where+  oneWayCoercibleImpl = unsafeOneWayCoercible++pureHandlerUnwrapped :: h e -> HandlerUnwrapped r a h e+pureHandlerUnwrapped h = MkHandlerUnwrapped [] (\k -> makeOp (k h))++-- | Analogous to 'Control.Applicative.pure'+pureMakeExceptions ::+  h e ->+  -- | ͘+  MakeExceptions r a h e+pureMakeExceptions h = MkMakeExceptions (pure (pureHandlerUnwrapped h))++apHandlerUnwrapped ::+  (Handle h1, Handle h2) =>+  HandlerUnwrapped r a (h1 :~> h2) e ->+  HandlerUnwrapped r a h1 e ->+  HandlerUnwrapped r a h2 e+apHandlerUnwrapped+  hrh1h2@(MkHandlerUnwrapped l1 _)+  hrh1@(MkHandlerUnwrapped l2 _) =+    MkHandlerUnwrapped+      (l1 <> l2)+      ( \k -> case mapHandle hrh1h2 of+          MkHandlerUnwrapped _ f -> f $ \h1h2 ->+            case mapHandle hrh1 of+              MkHandlerUnwrapped _ x -> x $ \h1 ->+                useImplIn k (app (mapHandle h1h2) (mapHandle h1))+      )++-- | Analogous to 'Control.Monad.ap' and 'Control.Applicative.<*>'+apMakeExceptions ::+  (Handle h1, Handle h2) =>+  MakeExceptions r a (h1 :~> h2) e ->+  MakeExceptions r a h1 e ->+  -- | ͘+  MakeExceptions r a h2 e+apMakeExceptions (MkMakeExceptions mh1h2) (MkMakeExceptions mh1) = MkMakeExceptions $ do+  h1h2 <- mh1h2+  h1 <- mh1+  pure (apHandlerUnwrapped h1h2 h1)++fmapHandlerUnwrapped ::+  (Handle h1, Handle h2) =>+  (h1 :~> h2) e ->+  HandlerUnwrapped r a h1 e ->+  HandlerUnwrapped r a h2 e+fmapHandlerUnwrapped f h = pureHandlerUnwrapped f `apHandlerUnwrapped` h++-- | Analogous to 'Prelude.fmap' and 'Prelude.<$>'+fmapMakeExceptions ::+  (Handle h1, Handle h2) =>+  (h1 :~> h2) e ->+  MakeExceptions r a h1 e ->+  -- | ͘+  MakeExceptions r a h2 e+fmapMakeExceptions f (MkMakeExceptions mh1) = MkMakeExceptions $ do+  h1 <- mh1+  pure (fmapHandlerUnwrapped f h1)++catchWithResource ::+  forall ex r a es.+  (r -> ex -> Eff es a) ->+  -- | ͘+  MakeExceptions r a (Exception ex) es+catchWithResource f = MkMakeExceptions $ unsafeProvideIO $ \io -> do+  scopedEx <- effIO io (SE.newException @ex)+  let hk = MkHandledKey scopedEx (flip f)+  pure+    ( MkHandlerUnwrapped+        [hk]+        ( \k -> do+            let ex = MkException (\e -> unsafeProvideIO $ \io' -> effIO io' (SE.throw scopedEx e))+            makeOp (k ex)+        )+    )++-- | A generalization of 'bracket' that enables distinguishing+-- exceptional from normal exit.+--+-- [@r@]: The type of the resource+-- [@b@]: The result type of the body+-- [@a@]: The type of the overall result+-- [@h@]: The handle of exceptions available in the body++-- Alsa+-- https://www.stackage.org/haddock/lts-24.26/exceptions-0.10.9/Control-Monad-Catch.html#v:generalBracket+generalBracket ::+  forall r b h a es.+  (Handle h) =>+  -- | Acquire the resource+  Eff es r ->+  -- | Construct the handle @h@ of exceptions to pass into the body,+  -- and determine what to run when the body terminates via one of+  -- those exceptions.+  MakeExceptions r a h es ->+  -- | To run on normal termination+  (r -> b -> Eff es a) ->+  -- | To run on unknown exception+  (r -> Eff es ()) ->+  -- | Body+  (forall e. h e -> r -> Eff (e :& es) b) ->+  Eff es a+generalBracket+  acquire'+  (MkMakeExceptions handlers)+  normalRelease'+  unknownExceptionRelease'+  body' =+    do+      MkHandlerUnwrapped handledKeys k <- handlers+      k $ \h -> do+        _ :: Proxy e1 <- handleTag h+        let bb :: BracketBase b r a (e1 :& es)+            bb =+              MkBracketBase+                { acquire = useImpl acquire',+                  normalRelease = \r b -> useImpl (normalRelease' r b),+                  unknownExceptionRelease =+                    \r -> useImpl (unknownExceptionRelease' r),+                  body = \resource -> useImpl (body' h resource)+                }+        runBodyWithHandlers ((fmap . fmap . fmap) useImpl handledKeys, bb)++data BracketBase bodyRes r a es = MkBracketBase+  { -- | Acquire the resource+    --+    -- This is run inside an asynchronous exception 'CE.mask'.+    acquire :: !(Eff es r),+    -- | Release the resource after normal exit+    --+    -- This is run inside an asynchronous exception 'CE.mask'.+    normalRelease :: !(r -> bodyRes -> Eff es a),+    -- | Release the resource after exit due to an unknown exception.+    --+    -- The exception will continue to be raised after this.+    --+    -- This is run inside an asynchronous exception 'CE.mask'.+    unknownExceptionRelease :: !(r -> Eff es ()),+    -- | Use the resource+    body :: !(r -> Eff es bodyRes)+  }+  deriving (Generic)++instance+  (e :> es) =>+  OneWayCoercible+    (BracketBase bodyRes r a e)+    (BracketBase bodyRes r a es)+  where+  oneWayCoercibleImpl = gOneWayCoercible++useImplBracketBase ::+  (e :> es) =>+  BracketBase b r a e ->+  BracketBase b r a es+useImplBracketBase = oneWayCoerce

@@ -1,7 +1,10 @@ module Bluefin.Internal.Exception.Scoped   ( Exception,+    InFlight,     try,     throw,+    newException,+    checkException,   ) where @@ -13,14 +16,17 @@  try :: (Exception e -> IO a) -> IO (Either e a) try k = do-  key <- newKey+  ex <- newException   tryJust-    (check key)-    (k (MkException key))+    (checkException ex)+    (k ex)  throw :: Exception e -> e -> IO a throw ex e = throwIO (MkInFlight ex e) +newException :: IO (Exception e)+newException = fmap MkException newKey+ -- Corresponds to what Bluefin calls an "Exception", i.e. "a handle to -- an exception" or "the capability to throw an exception". newtype Exception (e :: Type) = MkException (Key e)@@ -37,3 +43,6 @@ -- Like unlock from vault check :: Key a -> InFlight -> Maybe a check k1 (MkInFlight (MkException k2) e) = fmap (\HRefl -> e) (k1 `eqKey` k2)++checkException :: Exception e -> InFlight -> Maybe e+checkException (MkException key) = check key

@@ -4,10 +4,11 @@ module Main (main) where  import Bluefin.Internal+import Bluefin.Internal.DslBuilder import Control.Monad (when) import Data.Foldable (for_)-import Data.Monoid (All (All))-import System.Exit (ExitCode (ExitFailure), exitWith)+import Test.GeneralBracket (test_generalBracket)+import Test.SpecH (SpecH, assertEqual, runSpecH) import Prelude hiding (break, read)  main :: IO ()@@ -36,82 +37,7 @@       ([20, 30, 40], "Hello")      test_localInHandler y---- A SpecH yields pairs of------   (name, Maybe (stream of error text))-type SpecH = Stream (String, Maybe (SpecInfo ()))--assertEqual ::-  (e :> es, Eq a, Show a) => SpecH e -> String -> a -> a -> Eff es ()-assertEqual y n c1 c2 =-  yield-    y-    ( n,-      if c1 == c2-        then Nothing-        else Just $ withSpecInfo $ \y2 -> do-          yield y2 ("Expected: " ++ show c1)-          yield y2 ("But got: " ++ show c2)-    )--type SpecInfo r = Forall (Stream String :~> WrapEff r)--withSpecInfo ::-  (forall e es. (e :> es) => Stream String e -> Eff es r) ->-  SpecInfo r-withSpecInfo x = Forall (Nest (\s -> MkWrapEff (x s)))--newtype (h :~> t) es = Nest {unNest :: forall e. h e -> t (e :& es)}--newtype Forall t = Forall {unForall :: forall es. t es}--newtype WrapEff r es = MkWrapEff {unWrapEff :: Eff es r}--instance Handle (WrapEff r) where-  mapHandle (MkWrapEff e) = MkWrapEff (useImpl e)--runTests ::-  forall es e3.-  (e3 :> es) =>-  (forall e1. SpecH e1 -> Eff (e1 :& es) ()) ->-  Stream String e3 ->-  Eff es Bool-runTests f y = do-  ((), All passedAll) <- runWriter $ \passedAllSoFar -> do-    forEach (useImplUnder . f) $ \(name, mFailure) -> do-      let passed = case mFailure of-            Just _ -> False-            Nothing -> True--      tell passedAllSoFar (All passed)--      let mark = if passed then "✓" else "✗"--      yield y (mark ++ " " ++ name)--      case mFailure of-        Nothing -> pure ()-        Just n -> do-          yield y "" :: Eff (e2 :& es) ()-          _ <- forEach (unWrapEff . unNest (unForall n)) $ \entry -> do-            yield y ("    " ++ entry)-          yield y ""--  pure passedAll--runSpecH ::-  (e :> es) =>-  IOE e ->-  (forall e1. SpecH e1 -> Eff (e1 :& es) ()) ->-  Eff es ()-runSpecH ioe f = do-  passed <- forEach (runTests (useImplUnder . f)) $ \text ->-    effIO ioe (putStrLn text)--  effIO ioe $ case passed of-    True -> pure ()-    False -> exitWith (ExitFailure 1)+    test_generalBracket io y  (!?) :: [a] -> Int -> Maybe a xs !? i = runPureEff $

@@ -0,0 +1,96 @@+{-# LANGUAGE DerivingVia #-}++module Test.GeneralBracket where++import Bluefin.Internal+import Bluefin.Internal.CloneableHandle (abstract)+import Bluefin.Internal.Exception+import Bluefin.Internal.OneWayCoercible+import Control.Exception (ErrorCall)+import Test.SpecH (SpecH, assertEqual)++test_generalBracket :: (e1 :> es, e2 :> es) => IOE e1 -> SpecH e2 -> Eff es ()+test_generalBracket io s = do+  (actual, ()) <- yieldToList $ \y -> example io y++  assertEqual s "generalBracket" actual exampleResult++data ThreeExceptions e+  = MkThreeExceptions+      !(Exception Int e)+      !(Exception Bool e)+      !(Exception Char e)+  deriving (Generic)+  deriving (Handle) via OneWayCoercibleHandle ThreeExceptions++instance (e :> es) => OneWayCoercible (ThreeExceptions e) (ThreeExceptions es) where+  oneWayCoercibleImpl = gOneWayCoercible++threeExceptionsMakeExceptions ::+  forall es e1.+  (e1 :> es) =>+  Stream String e1 ->+  MakeExceptions String () ThreeExceptions es+threeExceptionsMakeExceptions y =+  ( abstract $ \e1 ->+      abstract $ \e2 ->+        abstract $ \e3 ->+          MkThreeExceptions (mapHandle e1) (mapHandle e2) (mapHandle e3)+  )+    `fmapMakeExceptions` catchAndReleasePrint+    `apMakeExceptions` catchAndReleasePrint+    `apMakeExceptions` catchAndReleasePrint+  where+    catchAndReleasePrint ::+      (Show ex) => MakeExceptions String () (Exception ex) es+    catchAndReleasePrint =+      catchWithResource (\i s -> yield y (show (i, s)))++example ::+  forall es e1 e2.+  (e1 :> es, e2 :> es) =>+  IOE e1 ->+  Stream String e2 ->+  Eff es ()+example io y = do+  let s = yield y++  s "Normal termination:"+  g (\_ _ -> pure ())+  s ""+  s "Known exception termination:"+  g (\(MkThreeExceptions e1 _ _) _ -> throw e1 5)+  s ""+  s "Unknown exception termination:"+  catch+    ( \ex -> rethrowIO @ErrorCall io ex $ do+        g (\_ _ -> undefined)+    )+    (\_ -> s "Caught ErrorCall")+  where+    -- If you want to avoid writing this signature use+    --  NoMonoLocalBinds and NoMonomorphismRestriction+    g ::+      (e2 :> es') =>+      ( forall e. ThreeExceptions e -> String -> Eff (e :& es') r+      ) ->+      Eff es' ()+    g =+      generalBracket+        (pure "Hello")+        (threeExceptionsMakeExceptions y)+        (\_ _ -> yield y "Terminating normally")+        (\_ -> yield y "Terminating with unknownn exception")++exampleResult :: [String]+exampleResult = fst $ runPureEff $ yieldToList $ \y -> do+  let e = yield y+  e "Normal termination:"+  e "Terminating normally"+  e ""+  e "Known exception termination:"+  e "(\"Hello\",5)"+  e ""+  e "Unknown exception termination:"+  e "Terminating with unknownn exception"+  e "Caught ErrorCall"

@@ -0,0 +1,68 @@+module Test.SpecH where++import System.Exit (ExitCode (ExitFailure), exitWith)+import Bluefin.Internal+import Bluefin.Internal.DslBuilder+import Data.Monoid (All (All))++-- A SpecH yields pairs of+--+--   (name, Maybe (stream of error text))+type SpecH = Stream (String, Maybe (SpecInfo ()))++assertEqual ::+  (e :> es, Eq a, Show a) => SpecH e -> String -> a -> a -> Eff es ()+assertEqual y n c1 c2 =+  yield+    y+    ( n,+      if c1 == c2+        then Nothing+        else Just $ dslBuilder $ \y2 -> do+          yield y2 ("Expected: " ++ show c1)+          yield y2 ("But got: " ++ show c2)+    )++type SpecInfo r = DslBuilder (Stream String) r++runTests ::+  forall es e3.+  (e3 :> es) =>+  (forall e1. SpecH e1 -> Eff (e1 :& es) ()) ->+  Stream String e3 ->+  Eff es Bool+runTests f y = do+  ((), All passedAll) <- runWriter $ \passedAllSoFar -> do+    forEach (useImplUnder . f) $ \(name, mFailure) -> do+      let passed = case mFailure of+            Just _ -> False+            Nothing -> True++      tell passedAllSoFar (All passed)++      let mark = if passed then "✓" else "✗"++      yield y (mark ++ " " ++ name)++      case mFailure of+        Nothing -> pure ()+        Just n -> do+          yield y "" :: Eff (e2 :& es) ()+          _ <- forEach (useImpl . flip runDslBuilder n) $ \entry -> do+            yield y ("    " ++ entry)+          yield y ""++  pure passedAll++runSpecH ::+  (e :> es) =>+  IOE e ->+  (forall e1. SpecH e1 -> Eff (e1 :& es) ()) ->+  Eff es ()+runSpecH ioe f = do+  passed <- forEach (runTests (useImplUnder . f)) $ \text ->+    effIO ioe (putStrLn text)++  effIO ioe $ case passed of+    True -> pure ()+    False -> exitWith (ExitFailure 1)