bluefin-internal 0.3.1.0 → 0.3.2.0

raw patch · 4 files changed

+305/−2 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• bluefin-internal.cabal +2/−1
• src/Bluefin/Internal.hs +10/−1
• src/Bluefin/Internal/CloneableHandle.hs +289/−0

@@ -1,3 +1,7 @@+# 0.3.2.0++* Add `Bluefin.Internal.CloneHandle`+ # 0.3.1.0  * Add `Bluefin.Internal.DslBuilder`

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               bluefin-internal-version:            0.3.1.0+version:            0.3.2.0 license:            MIT license-file:       LICENSE author:             Tom Ellis@@ -83,6 +83,7 @@       monad-control < 1.1     exposed-modules:       Bluefin.Internal,+      Bluefin.Internal.CloneableHandle,       Bluefin.Internal.DslBuilder,       Bluefin.Internal.DslBuilderEffects,       Bluefin.Internal.Examples,

@@ -38,7 +38,7 @@ import Data.Proxy (Proxy (Proxy)) import Data.Type.Coercion (Coercion (Coercion)) import GHC.Exts (Proxy#, proxy#)-import GHC.Generics (Generic)+import GHC.Generics (Generic, M1 (M1), Rec1 (Rec1), (:*:) ((:*:))) import System.IO.Unsafe (unsafePerformIO) import Unsafe.Coerce (unsafeCoerce) import Prelude hiding (drop, head, read, return)@@ -464,6 +464,15 @@   -- | ͘   HandleD h handleOneWayCoercion owc = MkHandleD (oneWayCoerceWith owc)++instance (Handle h) => Handle (Rec1 h) where+  handleImpl = handleMapHandle $ \(Rec1 h) -> Rec1 (mapHandle h)++instance (Handle h) => Handle (M1 i t h) where+  handleImpl = handleMapHandle $ \(M1 h) -> M1 (mapHandle h)++instance (Handle h1, Handle h2) => Handle (h1 :*: h2) where+  handleImpl = handleMapHandle $ \(h1 :*: h2) -> mapHandle h1 :*: mapHandle h2  -- { OneWayCoercibleHandle 

@@ -0,0 +1,289 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE UndecidableInstances #-}++module Bluefin.Internal.CloneableHandle+  ( module Bluefin.Internal.CloneableHandle,+    MonadUnliftIO (withRunInIO),+    MonadIO (liftIO),+    Generic1,+  )+where++import Bluefin.Internal hiding (b, race, w)+import Bluefin.Internal.OneWayCoercible+  ( OneWayCoercible (..),+    unsafeOneWayCoercible,+  )+import Control.Monad.IO.Unlift (MonadIO (liftIO), MonadUnliftIO (withRunInIO))+import Data.Coerce (coerce)+import GHC.Generics+  ( Generic1 (..),+    M1 (M1),+    Rec1 (Rec1),+    (:*:) ((:*:)),+  )+import GHC.TypeLits (ErrorMessage (Text), TypeError)++withEffToIOCloneHandle ::+  (e1 :> es, CloneableHandle h) =>+  IOE e1 ->+  -- | Handle accessible in the continuation+  h es ->+  -- | Continuation with the unlifting function in scope.+  ((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')++newtype HandleCloner h1 h2 es+  = MkHandleCloner+      ( forall r.+        h1 es ->+        (forall e. h2 e -> Eff (e :& es) r) ->+        Eff es r+      )++instance (Handle h1, Handle h2) => Handle (HandleCloner h1 h2) where+  handleImpl = handleOneWayCoercible++instance+  (Handle h1, Handle h2) =>+  OneWayCoercible+    (HandleCloner h1 h2 e)+    (HandleCloner h1 h2 es)+  where+  -- FIXME: These instances for higher rank types are annoying+  oneWayCoercibleImpl = unsafeOneWayCoercible++cloneHandle2 ::+  (Handle h1, Handle h2, e1 :> es) =>+  HandleCloner h1 h2 es ->+  h1 e1 ->+  (forall e. h2 e -> Eff (e :& es) r) ->+  Eff es r+cloneHandle2 (MkHandleCloner c) h1 = c (mapHandle h1)++instance CloneableHandle IOE where+  cloneableHandleImpl = MkCloneableHandleD hcIOE++hcIOE :: HandleCloner IOE IOE e+hcIOE = MkHandleCloner $ \io k -> do+  useImplIn k (mapHandle io)++-- | Cloning a @State@ copies its contents to a new @State@.  Changes+-- to one will not effect the other.+instance CloneableHandle (State s) where+  cloneableHandleImpl = MkCloneableHandleD hcState++hcState :: HandleCloner (State s) (State s) e+hcState = MkHandleCloner $ \st k -> do+  s <- get st+  evalState s $ \st' ->+    useImplIn k (mapHandle st')++instance CloneableHandle (Exception a) where+  cloneableHandleImpl = MkCloneableHandleD hcException++hcException :: HandleCloner (Exception ex) (Exception ex) e+hcException = MkHandleCloner $ \ex k -> do+  useImplIn k (mapHandle ex)++instance CloneableHandle (Reader r) where+  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'))++-- | Cloning a @HandleReader@ copies its contents to a new+-- @HandleReader@.  Changes to one will not effect the other.+instance (CloneableHandle h) => CloneableHandle (HandleReader h) where+  cloneableHandleImpl = MkCloneableHandleD hcHandleReader++cloneHandleClass ::+  (e1 :> es, CloneableHandle h) =>+  h e1 ->+  (forall e. h e -> Eff (e :& es) r) ->+  Eff es r+cloneHandleClass =+  cloneHandle2 (case cloneableHandleImpl of MkCloneableHandleD c' -> c')++hcHandleReader :: (CloneableHandle h) => HandleCloner (HandleReader h) (HandleReader h) e+hcHandleReader = MkHandleCloner $ \hr k -> do+  h <- askHandle hr+  cloneHandleClass h $ \h' -> do+    runHandleReader h' $ \hr' -> do+      useImplIn k (mapHandle hr')++instance+  (TypeError (Text "Coroutine cannot be cloned. Perhaps you want an STM channel?")) =>+  CloneableHandle (Coroutine a b)+  where+  cloneableHandleImpl =+    error "instance CloneableHandle (Coroutine a b) not implemented"++instance+  (TypeError (Text "Writer cannot be cloned. Perhaps you want an STM channel?")) =>+  CloneableHandle (Writer w)+  where+  cloneableHandleImpl =+    error "instance CloneableHandle (Writer a) not implemented"++newtype (h1 :~> h2) es = MkArrow (forall e. h1 e -> h2 (e :& es))++instance (Handle h1, Handle h2) => Handle (h1 :~> h2) where+  handleImpl = handleOneWayCoercible++instance+  (Handle h1, Handle h2) =>+  OneWayCoercible+    ((h1 :~> h2) e)+    ((h1 :~> h2) es)+  where+  -- 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 k = MkArrow (mapHandle . k)++app ::+  (Handle h2) =>+  (h1 :~> h2) e ->+  h1 e ->+  h2 e+app (MkArrow f) h1 = makeOpHandle (f h1)+  where+    makeOpHandle :: forall h e. (Handle h) => h (e :& e) -> h e+    makeOpHandle = case have @(e :& e) @e (subsume1 (eq ZW)) of+      Dict -> mapHandle++lmapHC ::+  (Handle h, Handle h2) =>+  (h1 :~> h2) e ->+  HandleCloner h2 h e ->+  HandleCloner h1 h e+lmapHC f hc = MkHandleCloner $ \h1 k1 -> cloneHandle2 hc (app f h1) k1++pureHC :: h2 e -> HandleCloner h1 h2 e+pureHC h2 = MkHandleCloner $ \_ k -> makeOp (k h2)++fmapHC ::+  (Handle h, Handle h1, Handle h2) =>+  (h1 :~> h2) e ->+  HandleCloner h h1 e ->+  HandleCloner h h2 e+fmapHC f h = pureHC f `apHC` h++apHC ::+  (Handle h, Handle h1, Handle h2) =>+  HandleCloner h (h1 :~> h2) e ->+  HandleCloner h h1 e ->+  HandleCloner h h2 e+apHC cf c1 = MkHandleCloner $ \h k2 -> do+  cloneHandle2 (mapHandle cf) h $ \hf -> do+    cloneHandle2 (mapHandle c1) h $ \h1 -> do+      useImplIn k2 (app (mapHandle hf) (mapHandle h1))++liftHC2 ::+  forall h h1 h2 hr es.+  (Handle h, Handle h1, Handle h2) =>+  (forall e. h1 e -> h2 e -> hr e) ->+  HandleCloner h h1 es ->+  HandleCloner h h2 es ->+  HandleCloner h hr es+liftHC2 f c1 c2 = MkHandleCloner $ \h kr -> do+  cloneHandle2 c1 h $ \h1 -> do+    cloneHandle2 (mapHandle c2) h $ \h2 -> do+      useImplIn kr (f (mapHandle h1) (mapHandle h2))++infixr 9 :~>++infixl 9 `apHC`++-- | You can use @DerivingVia@ with @GenericCloneableHandle@ to derive+-- a 'CloneableHandle' instance for your type, as long as it is a+-- product type of @CloneableHandle@s.+newtype GenericCloneableHandle h e = MkGenericCloneableHandle (h e)++instance (Handle h) => Handle (GenericCloneableHandle h) where+  handleImpl = handleMapHandle $ \(MkGenericCloneableHandle h) ->+    MkGenericCloneableHandle (mapHandle h)++instance+  (Handle h, Generic1 h, GCloneableHandle (Rep1 h)) =>+  CloneableHandle (GenericCloneableHandle h)+  where+  cloneableHandleImpl = coerce (gCloneableHandle @h)++newtype CloneableHandleD h = MkCloneableHandleD (forall e. HandleCloner h h e)++getHandleCloner :: (GCloneableHandle h) => HandleCloner h h e+getHandleCloner = case gCloneableHandleImpl of MkCloneableHandleD c -> c++gCloneableHandle ::+  forall h.+  (Handle h, Generic1 h) =>+  (GCloneableHandle (Rep1 h)) =>+  CloneableHandleD h+gCloneableHandle =+  MkCloneableHandleD+    ( fmapHC+        (abstract (mapHandle . to1))+        (lmapHC (abstract (mapHandle . from1)) getHandleCloner)+    )++-- | You can define a @CloneableHandle@ instance for your @Handle@ as+-- long as it is a product type of @CloneableHandle@s.  To define the+-- instance, use @DerivingVia@ and 'GenericCloneableHandle'.  For+-- example:+--+-- @+-- data MyHandle e = MkMyHandle ('Bluefin.Exception.Exception' String e) ('Bluefin.State.State' Int e)+--   deriving ('Bluefin.Compound.Generic', 'Generic1')+--   deriving ('Bluefin.Compound.Handle') via t'Bluefin.Compound.OneWayCoercibleHandle' MyHandle+--   deriving ('CloneableHandle') via 'GenericCloneableHandle' MyHandle+--+-- instance (e t'Bluefin.Eff.:>' es) => t'Bluefin.Compound.OneWayCoercible' (MyHandle e) (MyHandle es) where+--   'Bluefin.Compound.oneWayCoercibleImpl' = 'Bluefin.Compound.gOneWayCoercible'+-- @+class (Handle h) => CloneableHandle h where+  -- | Blah+  cloneableHandleImpl :: CloneableHandleD h++-- | @Generic@ implementation detail of+-- 'GenericCloneableHandle'. Bluefin users should never need to use+-- this directly.+class (Handle h) => GCloneableHandle h where+  gCloneableHandleImpl :: CloneableHandleD h++-- | A cloneable handle is generically cloneable+instance+  (CloneableHandle h) =>+  GCloneableHandle (Rec1 h)+  where+  gCloneableHandleImpl = coerce (cloneableHandleImpl @h)++-- | An annotated cloneable handle is generically cloneable+instance+  (GCloneableHandle h) =>+  GCloneableHandle (M1 i t h)+  where+  gCloneableHandleImpl = coerce (gCloneableHandleImpl @h)++-- | A pair of cloneable handles is generically cloneable+instance+  (GCloneableHandle h1, GCloneableHandle h2) =>+  GCloneableHandle (h1 :*: h2)+  where+  gCloneableHandleImpl =+    MkCloneableHandleD $+      (abstract $ \h1 -> abstract $ \h2 -> mapHandle h1 :*: mapHandle h2)+        `fmapHC` lmapHC (abstract $ \(h1 :*: _) -> mapHandle h1) getHandleCloner+        `apHC` lmapHC (abstract $ \(_ :*: h2) -> mapHandle h2) getHandleCloner