Polysemy: intersperse combinator

changelog.d/5-internal/polysemy-intersperse

@@ -0,0 +1 @@
+Implemented a new intersperse combinator for Polysemy

libs/polysemy-wire-zoo/polysemy-wire-zoo.cabal

@@ -12,6 +12,7 @@ build-type:    Simple
 
 library
   exposed-modules:
+    Polysemy.Testing
     Polysemy.TinyLog
     Wire.Sem.Concurrency
     Wire.Sem.Concurrency.IO
@@ -94,3 +95,72 @@ library
     , wire-api
 
   default-language:   Haskell2010
+
+
+test-suite spec
+  type:               exitcode-stdio-1.0
+  main-is:            Spec.hs
+  other-modules:
+    Paths_polysemy_wire_zoo
+    Test.IntersperseSpec
+
+  hs-source-dirs:     test
+  default-extensions:
+    NoImplicitPrelude
+    AllowAmbiguousTypes
+    BangPatterns
+    ConstraintKinds
+    DataKinds
+    DefaultSignatures
+    DeriveFunctor
+    DeriveGeneric
+    DeriveLift
+    DeriveTraversable
+    DerivingStrategies
+    DerivingVia
+    EmptyCase
+    FlexibleContexts
+    FlexibleInstances
+    FunctionalDependencies
+    GADTs
+    InstanceSigs
+    KindSignatures
+    LambdaCase
+    MultiParamTypeClasses
+    MultiWayIf
+    NamedFieldPuns
+    OverloadedStrings
+    PackageImports
+    PatternSynonyms
+    PolyKinds
+    QuasiQuotes
+    RankNTypes
+    ScopedTypeVariables
+    StandaloneDeriving
+    TupleSections
+    TypeApplications
+    TypeFamilies
+    TypeFamilyDependencies
+    TypeOperators
+    UndecidableInstances
+    ViewPatterns
+
+  ghc-options:
+    -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates
+    -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -j
+    -Wno-redundant-constraints -Werror -threaded -rtsopts
+    -with-rtsopts=-N
+
+  build-tool-depends: hspec-discover:hspec-discover
+  build-depends:
+      base
+    , containers
+    , hspec
+    , imports
+    , polysemy
+    , polysemy-check             >=0.9
+    , polysemy-plugin
+    , polysemy-wire-zoo
+    , unliftio
+
+  default-language:   Haskell2010

libs/polysemy-wire-zoo/src/Polysemy/Testing.hs

@@ -0,0 +1,17 @@
+module Polysemy.Testing where
+
+import Imports
+import Polysemy
+import Polysemy.Internal
+
+-- | @'intersperse' m a@ runs @m@ before every action in @a@. In this way, it's
+-- like injecting logic into each bind. Useful for polling asynchronous results
+-- when testing IO.
+intersperse ::
+  Sem r () ->
+  Sem r a ->
+  Sem r a
+intersperse a (Sem m) =
+  Sem $ \k -> m $ \u -> do
+    usingSem k a
+    k u

libs/polysemy-wire-zoo/test/Spec.hs

@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

libs/polysemy-wire-zoo/test/Test/IntersperseSpec.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE NumDecimals #-}
+{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
+
+module Test.IntersperseSpec where
+
+import qualified Data.Set as S
+import Imports hiding (intersperse)
+import Polysemy
+import Polysemy.Output (output)
+import Polysemy.State (evalState, get, modify)
+import Polysemy.Testing
+import Polysemy.Trace
+import Test.Hspec
+import UnliftIO (async)
+
+{-# ANN spec ("HLint: ignore Redundant pure" :: String) #-}
+spec :: Spec
+spec = do
+  -- This test spins up an async thread that communicates with the main
+  -- polysemy monad via an 'MVar'. We then use 'intersperse' to inject polling
+  -- logic between each bind in order to read from the 'MVar'.
+  it "should poll from async-written channel" $ do
+    result <- liftIO test
+    let desired =
+          S.fromList $
+            mconcat
+              [ fmap ("loaded: " <>) ["hello", "world", "last"],
+                fmap (show @Int) [1 .. 4],
+                ["finished"]
+              ]
+    result `shouldBe` desired
+
+  -- Example showing how intersperse lays out actions
+  it "should stick code before every action" $ do
+    let result =
+          fst $
+            run $
+              runTraceList $
+                outputToTrace show $
+                  evalState @Int 0 $
+                    intersperse ((output =<< get) <* modify (+ 1)) $ do
+                      -- 0
+                      trace "start"
+                      pure ()
+                      -- 1
+                      trace "middle"
+                      -- 2
+                      _ <- get
+                      -- 3
+                      trace "end"
+    result `shouldBe` ["0", "start", "1", "middle", "2", "3", "end"]
+
+pull :: (Member (Embed IO) r, Member Trace r) => MVar String -> Sem r ()
+pull chan = do
+  embed (tryTakeMVar chan) >>= \case
+    Nothing -> pure ()
+    Just s -> do
+      trace $ "loaded: " <> s
+      pull chan
+
+push :: MVar String -> IO ()
+push chan = do
+  putMVar chan "hello"
+  putMVar chan "world"
+  putMVar chan "last"
+
+test :: IO (Set String)
+test = fmap S.fromList $ do
+  chan <- newEmptyMVar @_ @String
+  _ <- async $ push chan
+  fmap fst $
+    runM $
+      runTraceList $
+        intersperse (pull chan) $ do
+          for_ [1 .. 4] $ \i -> do
+            trace $ show @Int i
+            liftIO $ threadDelay 1e5
+          trace "finished"