Refactor FirstToFinish and LastToFinish instances

cabal.project

@@ -5,6 +5,7 @@ packages: ./typed-protocols
           ./typed-protocols-examples
           ./ouroboros-network-testing
           ./monoidal-synchronisation
+          ./monoidal-synchronisation-test
           ./network-mux
           ./ouroboros-network-framework
           ./ouroboros-network
@@ -40,6 +41,9 @@ package Win32-network
 package io-classes
   flags: +asserts
 
+package monoidal-synchronisation-test
+  tests: True
+
 package strict-stm
   flags: +asserts
 

io-sim/io-sim.cabal

@@ -52,6 +52,7 @@ library
                        io-classes        >=0.2 && <0.3,
                        exceptions        >=0.10,
                        containers,
+                       monoidal-synchronisation,
                        parallel,
                        pretty-simple,
                        psqueues          >=0.2 && <0.3,

io-sim/src/Control/Monad/IOSim/Types.hs

@@ -97,7 +97,8 @@ import           Data.Bifoldable
 import           Data.Bifunctor (bimap)
 import           Data.Map.Strict (Map)
 import           Data.Maybe (fromMaybe)
-import           Data.Monoid (Endo (..))
+import           Data.Monoid (Alt (..), Endo (..))
+import           Data.Monoid.Synchronisation
 import           Data.Dynamic (Dynamic, toDyn)
 import           Data.Semigroup (Max (..))
 import           Data.Typeable
@@ -929,3 +930,51 @@ withStepTimelimit n e = e{explorationStepTimelimit = Just n}
 
 withReplay :: ScheduleControl -> ExplorationSpec
 withReplay r e = e{explorationReplay = Just r}
+
+
+instance Semigroup (FirstToFinish (IOSim s) a) where
+    FirstToFinish a <> FirstToFinish b = FirstToFinish $ either id id <$> race a b
+
+instance Monoid (FirstToFinish (IOSim s) a) where
+    mempty = FirstToFinish $ forever $ threadDelay 3600
+
+instance Semigroup (FirstToFinish (STM s) a) where
+    FirstToFinish a <> FirstToFinish b = FirstToFinish . getAlt
+                                       $ Alt a <|> Alt b
+instance Monoid (FirstToFinish (STM s) a) where
+    mempty = FirstToFinish . getAlt $ mempty
+
+instance Semigroup (LastToFinish (IOSim s) a) where
+    LastToFinish left <> LastToFinish right = LastToFinish $ do
+      withAsync left $ \a ->
+        withAsync right $ \b ->
+          MonadSTM.atomically $ runLastToFinish $
+               LastToFinish (waitSTM a)
+            <> LastToFinish (waitSTM b)
+
+instance Semigroup (LastToFinish (STM s) a) where
+    LastToFinish left <> LastToFinish right = LastToFinish $ do
+      a <-  Left  <$> left
+        <|> Right <$> right
+      case a of
+        Left  {} -> right
+        Right {} -> left
+
+instance Semigroup (LastToFinishM (IOSim s) a) where
+    LastToFinishM left <> LastToFinishM right = LastToFinishM $ do
+      withAsync left $ \a ->
+        withAsync right $ \b ->
+          MonadSTM.atomically $ runLastToFinishM $
+               LastToFinishM (waitSTM a)
+            <> LastToFinishM (waitSTM b)
+
+instance Semigroup (LastToFinishM (STM s) a) where
+    LastToFinishM left <> LastToFinishM right = LastToFinishM $ do
+      a <-  Left  <$> left
+        <|> Right <$> right
+      case a of
+        Left  {} -> right
+        Right {} -> left
+
+instance Monoid a => Monoid (LastToFinishM (STM s) a) where
+    mempty = LastToFinishM (pure mempty)

monoidal-synchronisation-test/monoidal-synchronisation-test.cabal

@@ -0,0 +1,50 @@
+cabal-version:      2.4
+name:               monoidal-synchronisation-test
+version:            0.1.0.0
+
+-- A short (one-line) description of the package.
+-- synopsis:
+
+-- A longer description of the package.
+-- description:
+
+-- A URL where users can report bugs.
+-- bug-reports:
+
+-- The license under which the package is released.
+license:            Apache-2.0
+license-files:
+  LICENSE
+  NOTICE
+author:             Marcin Szamotulski
+maintainer:         [email protected]
+
+copyright: 2021 Input Output (Hong Kong) Ltd.
+extra-source-files: CHANGELOG.md
+
+test-suite test
+  type:                exitcode-stdio-1.0
+  main-is:             Main.hs
+  hs-source-dirs:      test
+  other-modules:       Test.Data.Monoid.Synchronisation
+  build-depends:       base
+
+                     , QuickCheck
+                     , tasty
+                     , tasty-quickcheck
+
+                     , io-classes
+                     , io-sim
+                     , monoidal-synchronisation
+  default-language: Haskell2010
+  ghc-options:       -rtsopts
+                     -threaded
+                     -Wall
+                     -Wcompat
+                     -Wincomplete-uni-patterns
+                     -Wincomplete-record-updates
+                     -Wpartial-fields
+                     -Widentities
+                     -Wredundant-constraints
+                     -Wno-unticked-promoted-constructors
+

monoidal-synchronisation/test/Test/Data/Monoid/Synchronisation.hs → monoidal-synchronisation-test/test/Test/Data/Monoid/Synchronisation.hs

@@ -1,5 +1,7 @@
-{-# LANGUAGE GADTs               #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE QuantifiedConstraints #-}
 module Test.Data.Monoid.Synchronisation where
 
 import           Control.Monad.Class.MonadFork
@@ -24,6 +26,8 @@ lastToFinishExperiment
     :: forall m.
        ( MonadFork  m
        , MonadSTM   m
+       , forall a stm. stm ~ STM m
+                   => Semigroup (LastToFinish stm a)
        )
     => Bool -> m Bool
 lastToFinishExperiment writeInSingleTransaction = do

monoidal-synchronisation/monoidal-synchronisation.cabal

@@ -27,6 +27,8 @@ extra-source-files: CHANGELOG.md
 library
   exposed-modules:  Data.Monoid.Synchronisation
   build-depends:    base >=4.9 && <4.15
+                  , async
+                  , stm
   hs-source-dirs:   src
   default-language: Haskell2010
   ghc-options:     -rtsopts
@@ -39,29 +41,3 @@ library
                    -Widentities
                    -Wredundant-constraints
                    -Wno-unticked-promoted-constructors
-
-test-suite test
-  type:                exitcode-stdio-1.0
-  main-is:             Main.hs
-  hs-source-dirs:      test
-  other-modules:       Test.Data.Monoid.Synchronisation
-  build-depends:       base
-
-                     , QuickCheck
-                     , tasty
-                     , tasty-quickcheck
-
-                     , io-classes
-                     , io-sim
-                     , monoidal-synchronisation
-  default-language: Haskell2010
-  ghc-options:       -rtsopts
-                     -threaded
-                     -Wall
-                     -Wcompat
-                     -Wincomplete-uni-patterns
-                     -Wincomplete-record-updates
-                     -Wpartial-fields
-                     -Widentities
-                     -Wredundant-constraints
-                     -Wno-unticked-promoted-constructors

monoidal-synchronisation/src/Data/Monoid/Synchronisation.hs

@@ -1,11 +1,16 @@
 {-# LANGUAGE DeriveFunctor              #-}
 {-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DeriveTraversable          #-}
 {-# LANGUAGE DerivingStrategies         #-}
 {-# LANGUAGE DerivingVia                #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE DeriveTraversable          #-}
 {-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE NumericUnderscores         #-}
+{-# LANGUAGE QuantifiedConstraints      #-}
+{-# LANGUAGE RankNTypes                 #-}
 {-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE StandaloneKindSignatures   #-}
 
 module Data.Monoid.Synchronisation
   ( FirstToFinish (..)
@@ -23,7 +28,10 @@ import           Data.Monoid (Alt (..), Ap (..))
 import           GHC.Generics (Generic, Generic1)
 
 import           Control.Applicative (Alternative (..))
-import           Control.Monad (MonadPlus (..))
+import           Control.Monad (MonadPlus (..), forever)
+import           Control.Monad.STM
+import           Control.Concurrent (threadDelay)
+import           Control.Concurrent.Async
 
 
 -- | First-to-finish synchronisation.  Like 'Alt' it is a monoid under '<|>'.
@@ -48,12 +56,23 @@ newtype FirstToFinish m a = FirstToFinish { runFirstToFinish :: m a }
                    , MonadPlus
                    , Traversable
                    )
-  deriving Semigroup     via (Alt m a)
-  deriving Monoid        via (Alt m a)
   deriving Foldable      via (Alt m)
   deriving Contravariant via (Alt m)
 
 
+instance Semigroup (FirstToFinish IO a) where
+    FirstToFinish a <> FirstToFinish b = FirstToFinish $ either id id <$> race a b
+
+instance Monoid (FirstToFinish IO a) where
+    mempty = FirstToFinish $ forever $ threadDelay 3_600_000
+
+instance Semigroup (FirstToFinish STM a) where
+    FirstToFinish a <> FirstToFinish b = FirstToFinish . getAlt
+                                       $ Alt a <|> Alt b
+
+instance Monoid (FirstToFinish STM a) where
+    mempty = FirstToFinish . getAlt $ mempty
+
 -- | Last-to-finish synchronisation.  It is the multiplicative semigroup of
 -- the [near-semiring](https://www.wikiwand.com/en/Near-semiring) for which addition is
 -- given by 'FirstToFinish'.
@@ -83,7 +102,15 @@ newtype LastToFinish m a = LastToFinish { runLastToFinish :: m a }
                    )
   deriving Foldable via (Ap m)
 
-instance MonadPlus m => Semigroup (LastToFinish m a) where
+instance Semigroup (LastToFinish IO a) where
+    LastToFinish left <> LastToFinish right = LastToFinish $ do
+      withAsync left $ \a ->
+        withAsync right $ \b ->
+          atomically $ runLastToFinish $
+               LastToFinish (waitSTM a)
+            <> LastToFinish (waitSTM b)
+
+instance Semigroup (LastToFinish STM a) where
     LastToFinish left <> LastToFinish right = LastToFinish $ do
       a <-  Left  <$> left
         <|> Right <$> right
@@ -99,9 +126,9 @@ lastToFirst = coerce
 
 
 -- | Last-to-finish synchronisation. Like 'Ap' it is a monoid under '<*>'.
--- The advantage over 'LastToFinish' is that it has a 'Monoid' instance, but
--- 'a' must be a 'Monoid' as well.  'LastToFinishM' and 'FirstToFinish' form
--- a unitial near-ring when @m ~ STM@.
+-- The advantage over 'LastToFinish' is that it has a 'Monoid' instance for the
+-- stm monad, although 'a' must be a 'Monoid'.  'LastToFinishM' and
+-- 'FirstToFinish' form a unitial near-ring when @m ~ STM@.
 --
 -- > -- | Read all 'TMVar's and combine the result using 'Monoid' instance.
 -- > --
@@ -119,10 +146,27 @@ newtype LastToFinishM m a = LastToFinishM { runLastToFinishM :: m a }
                    , MonadPlus
                    , Traversable
                    )
-  deriving Semigroup via (Ap m a)
-  deriving Monoid    via (Ap m a)
   deriving Foldable  via (Ap m)
 
+instance Semigroup (LastToFinishM IO a) where
+    LastToFinishM left <> LastToFinishM right = LastToFinishM $ do
+      withAsync left $ \a ->
+        withAsync right $ \b ->
+          atomically $ runLastToFinishM $
+               LastToFinishM (waitSTM a)
+            <> LastToFinishM (waitSTM b)
+
+instance Semigroup (LastToFinishM STM a) where
+    LastToFinishM left <> LastToFinishM right = LastToFinishM $ do
+      a <-  Left  <$> left
+        <|> Right <$> right
+      case a of
+        Left  {} -> right
+        Right {} -> left
+
+instance Monoid a => Monoid (LastToFinishM STM a) where
+    mempty = LastToFinishM (pure mempty)
+
 firstToLastM :: FirstToFinish m a -> LastToFinishM m a
 firstToLastM = coerce
 

network-mux/network-mux.cabal

@@ -126,6 +126,7 @@ test-suite test
                        strict-stm,
                        io-sim            >=0.2 && < 0.3,
                        contra-tracer,
+                       monoidal-synchronisation,
                        network-mux,
                        Win32-network,
 

network-mux/src/Network/Mux.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE GADTSyntax                #-}
 {-# LANGUAGE KindSignatures            #-}
 {-# LANGUAGE NamedFieldPuns            #-}
+{-# LANGUAGE QuantifiedConstraints     #-}
 {-# LANGUAGE RankNTypes                #-}
 {-# LANGUAGE ScopedTypeVariables       #-}
 {-# LANGUAGE TypeFamilies              #-}
@@ -203,6 +204,8 @@ runMux :: forall m mode.
           , MonadTime  m
           , MonadTimer m
           , MonadMask m
+          , forall a stm. stm ~ STM m => Semigroup (FirstToFinish stm a)
+          , forall a stm. stm ~ STM m => Monoid    (FirstToFinish stm a)
           )
        => Tracer m MuxTrace
        -> Mux mode m
@@ -347,6 +350,8 @@ monitor :: forall mode m.
            , MonadAsync m
            , MonadMask m
            , MonadThrow (STM m)
+           , forall a stm. stm ~ STM m => Semigroup (FirstToFinish stm a)
+           , forall a stm. stm ~ STM m => Monoid    (FirstToFinish stm a)
            )
         => Tracer m MuxTrace
         -> TimeoutFn m

network-mux/src/Network/Mux/Compat.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE GADTSyntax                #-}
 {-# LANGUAGE KindSignatures            #-}
 {-# LANGUAGE NamedFieldPuns            #-}
+{-# LANGUAGE QuantifiedConstraints     #-}
 {-# LANGUAGE RankNTypes                #-}
 {-# LANGUAGE ScopedTypeVariables       #-}
 {-# LANGUAGE TypeFamilies              #-}
@@ -34,6 +35,7 @@ module Network.Mux.Compat
 
 import qualified Data.ByteString.Lazy as BL
 import           Data.Void (Void)
+import           Data.Monoid.Synchronisation
 
 import           Control.Applicative ((<|>))
 import           Control.Monad
@@ -94,6 +96,8 @@ muxStart
        , MonadTime  m
        , MonadTimer m
        , MonadMask m
+       , forall x stm. stm ~ STM m => Semigroup (FirstToFinish stm x)
+       , forall x stm. stm ~ STM m => Monoid    (FirstToFinish stm x)
        )
     => Tracer m MuxTrace
     -> MuxApplication mode m a b