Remove Signature type family

marlowe-chain-sync/src/Language/Marlowe/Runtime/ChainSync/Api.hs

@@ -86,8 +86,7 @@ data WithGenesis a = Genesis | At a
   deriving stock (Show, Eq, Ord, Functor, Generic)
   deriving anyclass (Binary, ToJSON)
 
-instance (HasSignature a, Signature a ~ Text) => HasSignature (WithGenesis a) where
-  type Signature (WithGenesis a) = Text
+instance HasSignature a => HasSignature (WithGenesis a) where
   signature _ = T.intercalate " " ["WithGenesis", signature $ Proxy @a]
 
 -- | A point in the chain, identified by a slot number, block header hash, and
@@ -104,7 +103,6 @@ data BlockHeader = BlockHeader
   deriving anyclass (Binary, ToJSON)
 
 instance HasSignature BlockHeader where
-  type Signature BlockHeader = Text
   signature _ = "BlockHeader"
 
 isAfter :: SlotNo -> BlockHeader -> Bool
@@ -583,7 +581,6 @@ data Move err result where
   AdvanceToTip :: Move Void ()
 
 instance HasSignature Move where
-  type Signature Move = Text
   signature _ = "Move"
 
 moveSchema :: SchemaVersion
@@ -896,7 +893,6 @@ data ChainSyncQuery delimiter err result where
   GetUTxOs :: GetUTxOsQuery -> ChainSyncQuery Void () UTxOs
 
 instance HasSignature ChainSyncQuery where
-  type Signature ChainSyncQuery = Text
   signature _ = "ChainSyncQuery"
 
 instance Query.QueryToJSON ChainSyncQuery where
@@ -1068,7 +1064,6 @@ data ChainSyncCommand status err result where
   SubmitTx :: ScriptDataSupportedInEra era -> Tx era -> ChainSyncCommand Void String ()
 
 instance HasSignature ChainSyncCommand where
-  type Signature ChainSyncCommand = Text
   signature _ = "ChainSyncCommand"
 
 instance CommandToJSON ChainSyncCommand where

marlowe-protocols/src/Network/Protocol/ChainSeek/Types.hs

@@ -79,11 +79,7 @@ instance
   ( HasSignature query
   , HasSignature point
   , HasSignature tip
-  , Signature query ~ Text
-  , Signature point ~ Text
-  , Signature tip ~ Text
   ) => HasSignature (ChainSeek query point tip) where
-  type Signature (ChainSeek query point tip) = Text
   signature _ = T.intercalate " "
     [ "ChainSeek"
     , signature $ Proxy @query

marlowe-protocols/src/Network/Protocol/Handshake/Client.hs

@@ -14,9 +14,9 @@ module Network.Protocol.Handshake.Client
 
 import Control.Monad.Cleanup (MonadCleanup)
 import Control.Monad.Trans.Control (MonadBaseControl)
-import Data.Binary (Binary)
 import Data.ByteString.Lazy (ByteString)
 import Data.Proxy (Proxy(..))
+import Data.Text (Text)
 import Network.Protocol.ChainSeek.Codec (DeserializeError)
 import Network.Protocol.Driver (ConnectSocketDriverSelector, RunClient, ToPeer, runClientPeerOverSocketWithLogging)
 import Network.Protocol.Handshake.Codec (codecHandshake)
@@ -28,29 +28,28 @@ import Observe.Event (EventBackend)
 import Observe.Event.Backend (noopEventBackend)
 
 -- | A generic client for the handshake protocol.
-data HandshakeClient sig client m a = HandshakeClient
-  { handshake :: m sig
+data HandshakeClient client m a = HandshakeClient
+  { handshake :: m Text
   , recvMsgReject :: m a
   , recvMsgAccept :: m (client m a)
   }
   deriving Functor
 
-simpleHandshakeClient :: MonadFail m => sig -> client m a -> HandshakeClient sig client m a
+simpleHandshakeClient :: MonadFail m => Text -> client m a -> HandshakeClient client m a
 simpleHandshakeClient sig client = HandshakeClient
   { handshake = pure sig
   , recvMsgReject = fail "Handshake rejected by server"
   , recvMsgAccept = pure client
   }
 
-embedClientInHandshake :: MonadFail m => sig -> RunClient m (HandshakeClient sig server) -> RunClient m server
+embedClientInHandshake :: MonadFail m => Text -> RunClient m (HandshakeClient server) -> RunClient m server
 embedClientInHandshake sig runClient = runClient . simpleHandshakeClient sig
 
 runClientPeerOverSocketWithLoggingWithHandshake
   :: forall client protocol (st :: protocol) m r
    . ( MonadBaseControl IO m
      , MonadCleanup m
      , MonadFail m
-     , Binary (Signature protocol)
      , HasSignature protocol
      )
   => EventBackend m r (ConnectSocketDriverSelector (Handshake protocol))
@@ -72,7 +71,6 @@ runClientPeerOverSocketWithHandshake
    . ( MonadBaseControl IO m
      , MonadCleanup m
      , MonadFail m
-     , Binary (Signature protocol)
      , HasSignature protocol
      )
   => (forall x. DeserializeError -> m x)
@@ -87,8 +85,8 @@ hoistHandshakeClient
   :: Functor m
   => (forall x. (forall y. m y -> n y) -> client m x -> client n x)
   -> (forall x. m x -> n x)
-  -> HandshakeClient sig client m a
-  -> HandshakeClient sig client n a
+  -> HandshakeClient client m a
+  -> HandshakeClient client n a
 hoistHandshakeClient hoistClient f HandshakeClient{..} = HandshakeClient
   { handshake = f handshake
   , recvMsgReject = f recvMsgReject
@@ -99,12 +97,12 @@ handshakeClientPeer
   :: forall client m ps st a
    . Functor m
   => (forall x. client m x -> Peer ps 'AsClient st m x)
-  -> HandshakeClient (Signature ps) client m a
+  -> HandshakeClient client m a
   -> Peer (Handshake ps) 'AsClient ('StInit st) m a
 handshakeClientPeer clientPeer HandshakeClient{..} =
   Effect $ peerInit <$> handshake
   where
-    peerInit :: Signature ps -> Peer (Handshake ps) 'AsClient ('StInit st) m a
+    peerInit :: Text -> Peer (Handshake ps) 'AsClient ('StInit st) m a
     peerInit sig =
       Yield (ClientAgency TokInit) (MsgHandshake sig) $
       Await (ServerAgency TokHandshake) \case

marlowe-protocols/src/Network/Protocol/Handshake/Codec.hs

@@ -19,7 +19,7 @@ import Network.TypedProtocol.Codec
 
 codecHandshake
   :: forall ps m
-   . (Monad m, Binary (Signature ps))
+   . Monad m
   => Codec ps DeserializeError m LBS.ByteString
   -> Codec (Handshake ps) DeserializeError m LBS.ByteString
 codecHandshake (Codec encodeMsg decodeMsg) = Codec

marlowe-protocols/src/Network/Protocol/Handshake/Server.hs

@@ -15,10 +15,10 @@ module Network.Protocol.Handshake.Server
 import Control.Monad.Cleanup (MonadCleanup)
 import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.Bifunctor (Bifunctor(bimap))
-import Data.Binary (Binary)
 import Data.ByteString.Lazy (ByteString)
 import Data.Functor ((<&>))
 import Data.Proxy (Proxy(..))
+import Data.Text (Text)
 import Network.Protocol.ChainSeek.Codec (DeserializeError)
 import Network.Protocol.Driver
   (AcceptSocketDriverSelector, RunServer(..), ToPeer, acceptRunServerPeerOverSocketWithLogging)
@@ -31,33 +31,30 @@ import Observe.Event (EventBackend)
 import Observe.Event.Backend (noopEventBackend)
 
 -- | A generic server for the handshake protocol.
-newtype HandshakeServer sig server m a = HandshakeServer
-  { recvMsgHandshake :: sig -> m (Either a (server m a))
+newtype HandshakeServer server m a = HandshakeServer
+  { recvMsgHandshake :: Text -> m (Either a (server m a))
   }
 
-instance (Functor m, Functor (server m)) => Functor (HandshakeServer sig server m) where
+instance (Functor m, Functor (server m)) => Functor (HandshakeServer server m) where
   fmap f HandshakeServer{..} = HandshakeServer
     { recvMsgHandshake = fmap (bimap f $ fmap f) . recvMsgHandshake
     }
 
-simpleHandshakeServer :: (Eq sig, MonadFail m, Show sig) => sig -> server m a -> HandshakeServer sig server m a
+simpleHandshakeServer :: MonadFail m => Text -> server m a -> HandshakeServer server m a
 simpleHandshakeServer expected server = HandshakeServer
   { recvMsgHandshake = \sig -> if sig == expected
       then pure $ Right server
       else fail $ "Rejecting handshake, " <> show sig <> " /= " <> show expected
   }
 
-embedServerInHandshake :: (Eq sig, Show sig, MonadFail m) => sig -> RunServer m (HandshakeServer sig server) -> RunServer m server
+embedServerInHandshake :: MonadFail m => Text -> RunServer m (HandshakeServer server) -> RunServer m server
 embedServerInHandshake sig (RunServer runServer) = RunServer $ runServer . simpleHandshakeServer sig
 
 acceptRunServerPeerOverSocketWithLoggingWithHandshake
   :: forall server protocol (st :: protocol) m r
    . ( MonadBaseControl IO m
      , MonadCleanup m
      , MonadFail m
-     , Eq (Signature protocol)
-     , Show (Signature protocol)
-     , Binary (Signature protocol)
      , HasSignature protocol
      )
   => EventBackend m r (AcceptSocketDriverSelector (Handshake protocol))
@@ -79,9 +76,6 @@ acceptRunServerPeerOverSocketWithHandshake
    . ( MonadBaseControl IO m
      , MonadCleanup m
      , MonadFail m
-     , Eq (Signature protocol)
-     , Show (Signature protocol)
-     , Binary (Signature protocol)
      , HasSignature protocol
      )
   => (forall x. DeserializeError -> m x)
@@ -96,8 +90,8 @@ hoistHandshakeServer
   :: Functor m
   => (forall x. (forall y. m y -> n y) -> server m x -> server n x)
   -> (forall x. m x -> n x)
-  -> HandshakeServer sig server m a
-  -> HandshakeServer sig server n a
+  -> HandshakeServer server m a
+  -> HandshakeServer server n a
 hoistHandshakeServer hoistServer f HandshakeServer{..} = HandshakeServer
   { recvMsgHandshake = f . (fmap . fmap) (hoistServer f) . recvMsgHandshake
   }
@@ -106,7 +100,7 @@ handshakeServerPeer
   :: forall client m ps st a
    . Functor m
   => (forall x. client m x -> Peer ps 'AsServer st m x)
-  -> HandshakeServer (Signature ps) client m a
+  -> HandshakeServer client m a
   -> Peer (Handshake ps) 'AsServer ('StInit st) m a
 handshakeServerPeer serverPeer HandshakeServer{..} =
   Await (ClientAgency TokInit) \case

marlowe-protocols/src/Network/Protocol/Handshake/Types.hs

@@ -16,8 +16,10 @@
 module Network.Protocol.Handshake.Types
   where
 
-import Data.Aeson (ToJSON, Value(..), object, (.=))
+import Data.Aeson (Value(..), object, (.=))
 import Data.Proxy (Proxy)
+import Data.Text (Text)
+import qualified Data.Text as T
 import GHC.Show (showSpace)
 import Network.Protocol.Codec.Spec (ArbitraryMessage(..), MessageEq(..), ShowProtocol(..))
 import Network.Protocol.Driver (MessageToJSON(..))
@@ -32,12 +34,11 @@ data Handshake ps where
   StDone :: Handshake ps
 
 class HasSignature (ps :: k) where
-  type Signature ps :: *
-  signature :: Proxy ps -> Signature ps
+  signature :: Proxy ps -> Text
 
 instance Protocol ps => Protocol (Handshake ps) where
   data Message (Handshake ps) st st' where
-    MsgHandshake :: Signature ps -> Message (Handshake ps)
+    MsgHandshake :: Text -> Message (Handshake ps)
       ('StInit st)
       ('StHandshake st)
     MsgAccept :: Message (Handshake ps)
@@ -77,9 +78,9 @@ instance Protocol ps => Protocol (Handshake ps) where
     TokLiftNobody n_tok -> \case
       TokLiftServer s_tok -> exclusionLemma_NobodyAndServerHaveAgency n_tok s_tok
 
-instance (ArbitraryMessage ps, Arbitrary (Signature ps)) => ArbitraryMessage (Handshake ps) where
+instance ArbitraryMessage ps => ArbitraryMessage (Handshake ps) where
   arbitraryMessage = oneof
-    [ AnyMessageAndAgency (ClientAgency TokInit) . MsgHandshake <$> arbitrary
+    [ AnyMessageAndAgency (ClientAgency TokInit) . MsgHandshake . T.pack <$> arbitrary
     , pure $ AnyMessageAndAgency (ServerAgency TokHandshake) MsgReject
     , pure $ AnyMessageAndAgency (ServerAgency TokHandshake) MsgAccept
     , do
@@ -90,14 +91,14 @@ instance (ArbitraryMessage ps, Arbitrary (Signature ps)) => ArbitraryMessage (Ha
     ]
   shrinkMessage = \case
     ClientAgency TokInit -> \case
-      MsgHandshake sig -> MsgHandshake <$> shrink sig
+      MsgHandshake sig -> MsgHandshake . T.pack <$> shrink (T.unpack sig)
     ClientAgency (TokLiftClient tok) -> \case
       MsgLift msg -> MsgLift <$> shrinkMessage (ClientAgency tok) msg
     ServerAgency TokHandshake -> const []
     ServerAgency (TokLiftServer tok) -> \case
       MsgLift msg -> MsgLift <$> shrinkMessage (ServerAgency tok) msg
 
-instance (MessageEq ps, Eq (Signature ps)) => MessageEq (Handshake ps) where
+instance MessageEq ps => MessageEq (Handshake ps) where
   messageEq (AnyMessageAndAgency tok1 msg1) (AnyMessageAndAgency tok2 msg2)= case (tok1, tok2) of
     (ClientAgency TokInit, ClientAgency TokInit) -> case (msg1, msg2) of
       (MsgHandshake sig, MsgHandshake sig') -> sig == sig'
@@ -117,7 +118,7 @@ instance (MessageEq ps, Eq (Signature ps)) => MessageEq (Handshake ps) where
         messageEq (AnyMessageAndAgency (ServerAgency tok1') msg1') (AnyMessageAndAgency (ServerAgency tok2') msg2')
     (ServerAgency (TokLiftServer _), _) -> False
 
-instance (ShowProtocol ps, Show (Signature ps)) => ShowProtocol (Handshake ps) where
+instance ShowProtocol ps => ShowProtocol (Handshake ps) where
   showsPrecMessage p tok = \case
     MsgHandshake sig -> showParen (p >= 11)
       ( showString "MsgHandshake"
@@ -148,7 +149,7 @@ instance (ShowProtocol ps, Show (Signature ps)) => ShowProtocol (Handshake ps) w
       . showsPrecClientHasAgency 11 tok
       )
 
-instance (MessageToJSON ps, ToJSON (Signature ps)) => MessageToJSON (Handshake ps) where
+instance MessageToJSON ps => MessageToJSON (Handshake ps) where
   messageToJSON = \case
     ClientAgency TokInit -> \case
       MsgHandshake sig -> object [ "handshake" .= sig ]

marlowe-protocols/src/Network/Protocol/Job/Types.hs

@@ -22,7 +22,6 @@ import Data.Binary.Get (Get)
 import Data.Functor ((<&>))
 import Data.Maybe (catMaybes)
 import Data.Proxy (Proxy(..))
-import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Type.Equality (type (:~:)(Refl))
 import GHC.Show (showSpace)
@@ -96,8 +95,7 @@ data Job (cmd :: * -> * -> * -> *) where
   -- | The terminal state of the protocol.
   StDone :: Job cmd
 
-instance (HasSignature cmd, Signature cmd ~ Text) => HasSignature (Job cmd) where
-  type Signature (Job cmd) = Text
+instance HasSignature cmd => HasSignature (Job cmd) where
   signature _ = T.intercalate " " ["Job", signature $ Proxy @cmd]
 
 instance Protocol (Job cmd) where

marlowe-protocols/src/Network/Protocol/Query/Types.hs

@@ -21,7 +21,6 @@ import Data.Data (type (:~:)(Refl))
 import Data.Functor ((<&>))
 import Data.Maybe (catMaybes)
 import Data.Proxy (Proxy(..))
-import Data.Text (Text)
 import qualified Data.Text as T
 import GHC.Show (showSpace)
 import Network.Protocol.Codec.Spec (ArbitraryMessage(..), MessageEq(..), ShowProtocol(..))
@@ -72,8 +71,7 @@ data Query (query :: * -> * -> * -> *) where
   -- | The terminal state of the protocol.
   StDone :: Query query
 
-instance (HasSignature query, Signature query ~ Text) => HasSignature (Query query) where
-  type Signature (Query query) = Text
+instance HasSignature query => HasSignature (Query query) where
   signature _ = T.intercalate " " ["Query", signature $ Proxy @query]
 
 data StNextKind

marlowe-runtime/cli/Language/Marlowe/Runtime/CLI/Command.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
@@ -11,7 +10,6 @@ import Control.Concurrent.STM (STM)
 import Control.Exception (SomeException, catch, throw)
 import Control.Exception.Base (throwIO)
 import Control.Monad.Trans.Reader (runReaderT)
-import Data.Binary (Binary)
 import qualified Data.ByteString.Lazy as LB
 import Data.Foldable (asum)
 import Language.Marlowe.Protocol.Sync.Client (marloweSyncClientPeer)
@@ -128,9 +126,7 @@ runCLIWithOptions sigInt Options{..} cli = do
 
 runClientPeerOverSocket'
   :: forall protocol client (st :: protocol)
-   . ( Binary (Signature protocol)
-     , HasSignature protocol
-     )
+   . HasSignature protocol
   => String -- ^ Client failure stderr extra message
   -> AddrInfo -- ^ Socket address to connect to
   -> Codec protocol DeserializeError IO LB.ByteString -- ^ A codec for the protocol

marlowe-runtime/discovery-api/Language/Marlowe/Protocol/HeaderSync/Types.hs

@@ -6,7 +6,6 @@ module Language.Marlowe.Protocol.HeaderSync.Types
   where
 
 import Data.Aeson (Value(..), object, (.=))
-import Data.Text (Text)
 import Language.Marlowe.Runtime.ChainSync.Api (BlockHeader, ChainPoint)
 import Language.Marlowe.Runtime.Discovery.Api (ContractHeader)
 import Network.Protocol.Driver (MessageToJSON(..))
@@ -21,7 +20,6 @@ data MarloweHeaderSync where
   StDone :: MarloweHeaderSync
 
 instance HasSignature MarloweHeaderSync where
-  type Signature MarloweHeaderSync = Text
   signature _ = "MarloweSync"
 
 instance Protocol MarloweHeaderSync where

marlowe-runtime/discovery-api/Language/Marlowe/Runtime/Discovery/Api.hs

@@ -6,7 +6,6 @@ module Language.Marlowe.Runtime.Discovery.Api
 
 import Data.Aeson (ToJSON(..), Value(..), object, (.=))
 import Data.Binary (Binary, get, getWord8, put, putWord8)
-import Data.Text (Text)
 import Data.Type.Equality (type (:~:)(Refl))
 import Data.Void (Void, absurd)
 import GHC.Generics (Generic)
@@ -48,7 +47,6 @@ data DiscoveryQuery delimiter err result where
   GetContractHeadersByRoleTokenCurrency :: PolicyId -> DiscoveryQuery Void Void [ContractHeader]
 
 instance HasSignature DiscoveryQuery where
-  type Signature DiscoveryQuery = Text
   signature _ = "DiscoveryQuery"
 
 instance QueryToJSON DiscoveryQuery where