Forklift interpretations (#128)

This PR provides a single function withLowerToIO, which runs a desired Sem r effect all the way down to IO, without needing to know the natural transformation beforehand. It does it by running the desired code in a new thread, and shipping all of the unhandled effects back to the main thread. The main thread turns into an event loop for the duration of the withLowerToIO block.

package.yaml

@@ -24,6 +24,8 @@ dependencies:
 - th-abstraction >= 0.3.1.0 && < 0.4
 - transformers >= 0.5.2.0 && < 0.6
 - first-class-families >= 0.5.0.0 && < 0.6
+- unagi-chan >= 0.4.0.0 && < 0.5
+- async >= 2.2 && < 3
 
 default-extensions:
   - DataKinds
@@ -90,7 +92,7 @@ tests:
     - hspec-discover >= 2.0
     dependencies:
     - polysemy
-    - inspection-testing >= 0.4.2.1 && < 0.5
+    - inspection-testing >= 0.4.2 && < 0.5
     - hspec >= 2.6.0 && < 3
     - doctest >= 0.16.0.1 && < 0.17
 

polysemy-plugin/package.yaml

@@ -43,7 +43,7 @@ tests:
     - polysemy-plugin
     - hspec >= 2.6.0 && < 3
     - should-not-typecheck >= 2.1.0 && < 3
-    - inspection-testing >= 0.4.2.1 && < 0.5
+    - inspection-testing >= 0.4.2 && < 0.5
 
 default-extensions:
   - DataKinds

polysemy-plugin/polysemy-plugin.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 67eaa9259909a5401e1bbdf179fc3263ec3b57afd9951ae709d347f390e9c541
+-- hash: d6541c6630b0beeaad870e361e1382face77df6d5864cd4b9b098d9b87697121
 
 name:           polysemy-plugin
 version:        0.2.1.0
@@ -71,7 +71,7 @@ test-suite polysemy-plugin-test
     , ghc >=8.4.4 && <9
     , ghc-tcplugins-extra >=0.3 && <0.4
     , hspec >=2.6.0 && <3
-    , inspection-testing >=0.4.2.1 && <0.5
+    , inspection-testing >=0.4.2 && <0.5
     , polysemy
     , polysemy-plugin
     , should-not-typecheck >=2.1.0 && <3

polysemy.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 3bb11d1562f0640e892b918e3de6086196562200410a660b14851704b64175a0
+-- hash: 3f07038fea02ea788ded67449bf361c83a48d3773798a68f15b6b03ac8032e2d
 
 name:           polysemy
 version:        0.4.0.0
@@ -47,6 +47,7 @@ library
       Polysemy.Internal.Combinators
       Polysemy.Internal.CustomErrors
       Polysemy.Internal.Fixpoint
+      Polysemy.Internal.Forklift
       Polysemy.Internal.Kind
       Polysemy.Internal.Lift
       Polysemy.Internal.NonDet
@@ -69,7 +70,8 @@ library
   default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UnicodeSyntax
   ghc-options: -Wall
   build-depends:
-      base >=4.9 && <5
+      async >=2.2 && <3
+    , base >=4.9 && <5
     , containers >=0.5 && <0.7
     , first-class-families >=0.5.0.0 && <0.6
     , mtl >=2.2.2 && <3
@@ -77,6 +79,7 @@ library
     , template-haskell >=2.12.0.0 && <3
     , th-abstraction >=0.3.1.0 && <0.4
     , transformers >=0.5.2.0 && <0.6
+    , unagi-chan >=0.4.0.0 && <0.5
   if impl(ghc < 8.6)
     default-extensions: MonadFailDesugaring TypeInType
   if flag(dump-core)
@@ -112,18 +115,20 @@ test-suite polysemy-test
   build-tool-depends:
       hspec-discover:hspec-discover >=2.0
   build-depends:
-      base >=4.9 && <5
+      async >=2.2 && <3
+    , base >=4.9 && <5
     , containers >=0.5 && <0.7
     , doctest >=0.16.0.1 && <0.17
     , first-class-families >=0.5.0.0 && <0.6
     , hspec >=2.6.0 && <3
-    , inspection-testing >=0.4.2.1 && <0.5
+    , inspection-testing >=0.4.2 && <0.5
     , mtl >=2.2.2 && <3
     , polysemy
     , syb >=0.7 && <0.8
     , template-haskell >=2.12.0.0 && <3
     , th-abstraction >=0.3.1.0 && <0.4
     , transformers >=0.5.2.0 && <0.6
+    , unagi-chan >=0.4.0.0 && <0.5
   if impl(ghc < 8.6)
     default-extensions: MonadFailDesugaring TypeInType
   default-language: Haskell2010
@@ -138,7 +143,8 @@ benchmark polysemy-bench
       bench
   default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UnicodeSyntax
   build-depends:
-      base >=4.9 && <5
+      async >=2.2 && <3
+    , base >=4.9 && <5
     , containers >=0.5 && <0.7
     , criterion
     , first-class-families >=0.5.0.0 && <0.6
@@ -150,6 +156,7 @@ benchmark polysemy-bench
     , template-haskell >=2.12.0.0 && <3
     , th-abstraction >=0.3.1.0 && <0.4
     , transformers >=0.5.2.0 && <0.6
+    , unagi-chan >=0.4.0.0 && <0.5
   if impl(ghc < 8.6)
     default-extensions: MonadFailDesugaring TypeInType
   default-language: Haskell2010

src/Polysemy.hs

@@ -3,6 +3,7 @@ module Polysemy
     Sem ()
   , Member
   , Members
+  , LastMember
 
   -- * Running Sem
   , run
@@ -120,4 +121,5 @@ import Polysemy.Internal.Combinators
 import Polysemy.Internal.Kind
 import Polysemy.Internal.TH.Effect
 import Polysemy.Internal.Tactics
+import Polysemy.Internal.Union
 

src/Polysemy/Internal/Forklift.hs

@@ -0,0 +1,93 @@
+{-# LANGUAGE NumDecimals     #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies    #-}
+
+module Polysemy.Internal.Forklift where
+
+import qualified Control.Concurrent.Async as A
+import           Control.Concurrent.Chan.Unagi
+import           Control.Concurrent.MVar
+import           Control.Monad
+import           Polysemy
+import           Polysemy.Internal
+import           Polysemy.Internal.Union
+
+
+------------------------------------------------------------------------------
+-- | A promise for interpreting an effect of the union @r@ in another thread.
+--
+-- TODO(sandy): @since
+data Forklift r = forall a. Forklift
+  { responseMVar :: MVar (Sem '[Lift IO] a)
+  , request      :: Union r (Sem r) a
+  }
+
+
+------------------------------------------------------------------------------
+-- | A strategy for automatically interpreting an entire stack of effects by
+-- just shipping them off to some other interpretation context.
+--
+-- TODO(sandy): @since
+runViaForklift
+    :: LastMember (Lift IO) r
+    => InChan (Forklift r)
+    -> Sem r a
+    -> Sem '[Lift IO] a
+runViaForklift chan (Sem m) = Sem $ \k -> m $ \u -> do
+  case decompLast u of
+    Left x -> usingSem k $ join $ sendM $ do
+      mvar <- newEmptyMVar
+      writeChan chan $ Forklift mvar x
+      takeMVar mvar
+    Right y -> k $ hoist (runViaForklift_b chan) y
+{-# INLINE runViaForklift #-}
+
+
+runViaForklift_b
+    :: LastMember (Lift IO) r
+    => InChan (Forklift r)
+    -> Sem r a
+    -> Sem '[Lift IO] a
+runViaForklift_b = runViaForklift
+{-# NOINLINE runViaForklift_b #-}
+
+
+------------------------------------------------------------------------------
+-- | Run an effect stack all the way down to 'IO' by running it in a new
+-- thread, and temporarily turning the current thread into an event poll.
+--
+-- This function creates a thread, and so should be compiled with @-threaded@.
+--
+-- TODO(sandy): @since
+withLowerToIO
+    :: LastMember (Lift IO) r
+    => ((forall x. Sem r x -> IO x) -> IO () -> IO a)
+       -- ^ A lambda that takes the lowering function, and a finalizing 'IO'
+       -- action to mark a the forked thread as being complete. The finalizing
+       -- action need not be called.
+    -> Sem r a
+withLowerToIO action = do
+  (inchan, outchan) <- sendM newChan
+  signal <- sendM newEmptyMVar
+
+  res <- sendM $ A.async $ do
+    a <- action (runM . runViaForklift inchan)
+                (putMVar signal ())
+    putMVar signal ()
+    pure a
+
+  let me = do
+        raced <- sendM $ A.race (takeMVar signal) $ readChan outchan
+        case raced of
+          Left () -> sendM $ A.wait res
+          Right (Forklift mvar req) -> do
+            resp <- liftSem req
+            sendM $ putMVar mvar $ pure resp
+            me_b
+      {-# INLINE me #-}
+
+      me_b = me
+      {-# NOINLINE me_b #-}
+
+  me
+

src/Polysemy/Internal/Kind.hs

@@ -4,9 +4,13 @@ import Data.Kind
 
 ------------------------------------------------------------------------------
 -- | The kind of effects.
+--
+-- TODO(sandy): @since
 type Effect    = (Type -> Type) -> Type -> Type
 
 ------------------------------------------------------------------------------
 -- | The kind of effect rows.
+--
+-- TODO(sandy): @since
 type EffectRow = [Effect]
 

src/Polysemy/Internal/Union.hs

@@ -1,11 +1,13 @@
-{-# LANGUAGE AllowAmbiguousTypes   #-}
-{-# LANGUAGE CPP                   #-}
-{-# LANGUAGE ConstraintKinds       #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE StrictData            #-}
-{-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE UndecidableInstances  #-}
+{-# LANGUAGE AllowAmbiguousTypes     #-}
+{-# LANGUAGE CPP                     #-}
+{-# LANGUAGE ConstraintKinds         #-}
+{-# LANGUAGE FlexibleInstances       #-}
+{-# LANGUAGE FunctionalDependencies  #-}
+{-# LANGUAGE MultiParamTypeClasses   #-}
+{-# LANGUAGE StrictData              #-}
+{-# LANGUAGE TypeFamilies            #-}
+{-# LANGUAGE UndecidableInstances    #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
 
 {-# OPTIONS_HADDOCK not-home #-}
 
@@ -27,8 +29,10 @@ module Polysemy.Internal.Union
   -- * Witnesses
   , SNat (..)
   , Nat (..)
+  , LastMember (..)
   ) where
 
+import Data.Bifunctor
 import Control.Monad
 import Data.Functor.Compose
 import Data.Functor.Identity
@@ -105,13 +109,17 @@ hoist f' (Union w (Yo e s nt f v)) = Union w $ Yo e s (f' . nt) f v
 type Member e r = Member' e r
 
 type Member' e r =
-  ( Find r e
-  , e ~ IndexOf r (Found r e)
+  ( MemberNoError e r
 #ifndef NO_ERROR_MESSAGES
   , Break (AmbiguousSend r e) (IndexOf r (Found r e))
 #endif
   )
 
+type MemberNoError e r =
+  ( Find r e
+  , e ~ IndexOf r (Found r e)
+  )
+
 
 ------------------------------------------------------------------------------
 -- | The kind of type-level natural numbers.
@@ -189,11 +197,12 @@ absurdU = absurdU
 
 ------------------------------------------------------------------------------
 -- | Weaken a 'Union' so it is capable of storing a new sort of effect.
-weaken :: Union r m a -> Union (e ': r) m a
+weaken :: forall e r m a. Union r m a -> Union (e ': r) m a
 weaken (Union n a) = Union (SS n) a
 {-# INLINE weaken #-}
 
 
+
 ------------------------------------------------------------------------------
 -- | Lift an effect @e@ into a 'Union' capable of holding it.
 inj :: forall r e a m. (Functor m , Member e r) => e m a -> Union r m a
@@ -233,3 +242,20 @@ decompCoerce (Union p a) =
 {-# INLINE decompCoerce #-}
 
 
+------------------------------------------------------------------------------
+-- | A proof that @end@ is the last effect in the row.
+--
+-- TODO(sandy): @since
+class MemberNoError end r => LastMember end r | r -> end where
+  decompLast
+      :: Union r m a
+      -> Either (Union r m a) (Union '[end] m a)
+
+instance {-# OVERLAPPABLE #-} (LastMember end r, MemberNoError end (eff ': r))
+      => LastMember end (eff ': r) where
+  decompLast (Union SZ u)     = Left $ Union SZ u
+  decompLast (Union (SS n) u) = first weaken $ decompLast $ Union n u
+
+instance LastMember end '[end] where
+  decompLast = Right
+

stack.yaml

@@ -13,4 +13,5 @@ extra-deps:
 - inspection-testing-0.4.2
 - monadLib-3.9
 - th-abstraction-0.3.1.0
+- unagi-chan-0.4.1.0