Hot / Warm / Established distinction

The governor needs to take care about three types of protocols: ones
that run for established connections, warm and hot peers.  For this
purpose we provide a type level `ProtocolTemperature` with three
constructors: `Hot`, `Warm` and `Established`.  This patch provides
convientient functions to work with the introduced complexity.

ouroboros-network-framework/src/Ouroboros/Network/Mux.hs

@@ -1,21 +1,36 @@
+{-# LANGUAGE BangPatterns          #-}
 {-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveFunctor         #-}
 {-# LANGUAGE GADTs                 #-}
 {-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE KindSignatures        #-}
+{-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE PolyKinds             #-}
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE StandaloneDeriving    #-}
 
 module Ouroboros.Network.Mux
   ( MuxMode (..)
   , OuroborosApplication (..)
+  , MuxProtocolBundle
+  , ProtocolTemperature (..)
+  , TokProtocolTemperature (..)
+  , WithProtocolTemperature (..)
+  , withoutProtocolTemperature
+  , Bundle (..)
+  , projectBundle
+  , OuroborosBundle
+  , MuxBundle
   , MiniProtocol (..)
   , MiniProtocolNum (..)
   , MiniProtocolLimits (..)
   , RunMiniProtocol (..)
   , MuxPeer (..)
   , runMuxPeer
   , toApplication
+  , mkMuxApplicationBundle
   , ouroborosProtocols
   , RunOrStop (..)
   , ScheduledStop
@@ -55,6 +70,7 @@ import           Ouroboros.Network.Util.ShowProxy (ShowProxy)
 
 
 data RunOrStop = Run | Stop
+  deriving (Eq, Show)
 
 -- |  'ScheduleStop' should depend on `muxMode` (we only need to shedule stop
 -- for intiator side).  This is not done only because this would break tests,
@@ -66,15 +82,120 @@ neverStop :: Applicative (STM m)
           -> ScheduledStop m
 neverStop _ = pure Run
 
-
 -- |  Like 'MuxApplication' but using a 'MuxPeer' rather than a raw
 -- @Channel -> m a@ action.
 --
 newtype OuroborosApplication (mode :: MuxMode) addr bytes m a b =
         OuroborosApplication
-          (ConnectionId addr
-            -> STM m RunOrStop
-            -> [MiniProtocol mode bytes m a b])
+          (ConnectionId addr -> STM m RunOrStop -> [MiniProtocol mode bytes m a b])
+
+
+-- |  There are three kinds of applications: warm, hot and established (ones
+-- that run in for both warm and hot peers).
+--
+data ProtocolTemperature = Hot | Warm | Established
+
+
+-- | Singletons for 'AppKind'
+--
+data TokProtocolTemperature (pt :: ProtocolTemperature) where
+    TokHot         :: TokProtocolTemperature Hot
+    TokWarm        :: TokProtocolTemperature Warm
+    TokEstablished :: TokProtocolTemperature Established
+
+
+-- | We keep hot and warm application (or their context) distinct.  It's only
+-- needed for a handly 'projectBundle' map.
+--
+data WithProtocolTemperature (pt :: ProtocolTemperature) a where
+    WithHot         :: !a -> WithProtocolTemperature Hot  a
+    WithWarm        :: !a -> WithProtocolTemperature Warm a
+    WithEstablished :: !a -> WithProtocolTemperature Established a
+
+deriving instance Eq a => Eq (WithProtocolTemperature pt a)
+deriving instance Show a => Show (WithProtocolTemperature pt a)
+deriving instance (Functor (WithProtocolTemperature pt))
+
+instance Semigroup a => Semigroup (WithProtocolTemperature pt a) where
+    WithHot a <> WithHot b = WithHot (a <> b)
+    WithWarm a <> WithWarm b = WithWarm (a <> b)
+    WithEstablished a <> WithEstablished b = WithEstablished (a <> b)
+
+instance Monoid a => Monoid (WithProtocolTemperature Hot a) where
+    mempty = WithHot mempty
+
+instance Monoid a => Monoid (WithProtocolTemperature Warm a) where
+    mempty = WithWarm mempty
+
+instance Monoid a => Monoid (WithProtocolTemperature Established a) where
+    mempty = WithEstablished mempty
+
+
+withoutProtocolTemperature :: WithProtocolTemperature pt a -> a
+withoutProtocolTemperature (WithHot a)         = a
+withoutProtocolTemperature (WithWarm a)        = a
+withoutProtocolTemperature (WithEstablished a) = a
+
+
+-- | A bundle of 'HotApp', 'WarmApp' and 'EstablishedApp'.
+--
+data Bundle a =
+      Bundle {
+          -- | hot mini-protocols
+          --
+          withHot
+            :: !(WithProtocolTemperature Hot a),
+
+          -- | warm mini-protocols
+          --
+          withWarm
+            :: !(WithProtocolTemperature Warm a),
+
+          -- | established mini-protocols
+          --
+          withEstablished
+            :: !(WithProtocolTemperature Established a)
+        }
+  deriving (Eq, Show, Functor)
+
+instance Semigroup a => Semigroup (Bundle a) where
+    Bundle hot warm established <> Bundle hot' warm' established' =
+      Bundle (hot <> hot')
+             (warm <> warm')
+             (established <> established')
+
+instance Monoid a => Monoid (Bundle a) where
+    mempty = Bundle mempty mempty mempty
+
+projectBundle :: TokProtocolTemperature pt -> Bundle a -> a
+projectBundle TokHot         = withoutProtocolTemperature . withHot
+projectBundle TokWarm        = withoutProtocolTemperature . withWarm
+projectBundle TokEstablished = withoutProtocolTemperature . withEstablished
+
+
+instance Applicative Bundle where
+    pure a = Bundle (WithHot a) (WithWarm a) (WithEstablished a)
+    Bundle (WithHot hotFn)
+           (WithWarm warmFn)
+           (WithEstablished establishedFn)
+      <*> Bundle (WithHot hot)
+                 (WithWarm warm)
+                 (WithEstablished established) =
+        Bundle (WithHot $ hotFn hot)
+               (WithWarm $ warmFn warm)
+               (WithEstablished $ establishedFn established)
+
+--
+-- Useful type synonyms
+--
+
+type MuxProtocolBundle (mode :: MuxMode) addr bytes m a b
+       = ConnectionId addr
+      -> STM m RunOrStop
+      -> [MiniProtocol mode bytes m a b]
+
+type OuroborosBundle (mode :: MuxMode) addr bytes m a b =
+    Bundle (MuxProtocolBundle mode addr bytes m a b)
 
 data MiniProtocol (mode :: MuxMode) bytes m a b =
      MiniProtocol {
@@ -83,6 +204,10 @@ data MiniProtocol (mode :: MuxMode) bytes m a b =
        miniProtocolRun    :: !(RunMiniProtocol mode bytes m a b)
      }
 
+type MuxBundle (mode :: MuxMode) bytes m a b =
+    Bundle [MiniProtocol mode bytes m a b]
+
+
 data RunMiniProtocol (mode :: MuxMode) bytes m a b where
      InitiatorProtocolOnly
        :: MuxPeer bytes m a
@@ -144,6 +269,46 @@ toApplication connectionId scheduleStop (OuroborosApplication ptcls) =
       }
     | ptcl <- ptcls connectionId scheduleStop ]
 
+
+mkMuxApplicationBundle
+    :: forall mode addr bytes m a b.
+       ConnectionId addr
+    -> Bundle (ScheduledStop m)
+    -> OuroborosBundle mode addr bytes m a b
+    -> MuxBundle       mode      bytes m a b
+mkMuxApplicationBundle connectionId
+                       (Bundle
+                         hotScheduleStop
+                         warmScheduleStop
+                         establishedScheduleStop)
+                       (Bundle
+                           hotApp
+                           warmApp
+                           establishedApp) =
+    Bundle {
+        withHot =
+          mkApplication hotScheduleStop hotApp,
+
+        withWarm =
+          mkApplication warmScheduleStop warmApp,
+
+        withEstablished =
+          mkApplication establishedScheduleStop establishedApp
+    }
+  where
+    mkApplication :: WithProtocolTemperature pt (ScheduledStop m)
+                  -> WithProtocolTemperature pt (MuxProtocolBundle mode addr bytes m a b)
+                  -> WithProtocolTemperature pt [MiniProtocol mode bytes m a b]
+    mkApplication (WithHot scheduleStop) (WithHot app) =
+      WithHot $ app connectionId scheduleStop
+
+    mkApplication (WithWarm scheduleStop) (WithWarm app) =
+      WithWarm $ app connectionId scheduleStop
+
+    mkApplication (WithEstablished scheduleStop) (WithEstablished app) =
+      WithEstablished $ app connectionId scheduleStop
+
+
 toMuxRunMiniProtocol :: forall mode m a b.
                         (MonadCatch m, MonadAsync m)
                      => RunMiniProtocol mode LBS.ByteString m a b