module Control.Eff.Concurrent.Protocol
( HasPdu(..)
, Pdu(..)
, Synchronicity(..)
, ProtocolReply
, Tangible
, TangiblePdu
, Endpoint(..)
, fromEndpoint
, proxyAsEndpoint
, asEndpoint
, EmbedProtocol(..)
, toEmbeddedEndpoint
, fromEmbeddedEndpoint
)
where
import Control.Eff.Concurrent.Misc
import Control.DeepSeq
import Control.Eff.Concurrent.Process
import Control.Lens
import Data.Coerce
import Data.Dynamic
import Data.Kind
import Data.Typeable ()
import Data.Type.Pretty
import Type.Reflection
newtype Endpoint protocol = Endpoint { _fromEndpoint :: ProcessId }
deriving (Eq,Ord,Typeable, NFData)
instance Typeable protocol => Show (Endpoint protocol) where
showsPrec d (Endpoint c) =
showParen (d>=10)
(showSTypeRep (SomeTypeRep (typeRep @protocol)) . showsPrec 10 c)
class (Tangible (Pdu protocol reply), Typeable protocol, Typeable reply) => HasPdu (protocol :: Type) (reply :: Synchronicity) where
data family Pdu protocol reply
deserializePdu :: Dynamic -> Maybe (Pdu protocol reply)
default deserializePdu :: (Typeable (Pdu protocol reply)) => Dynamic -> Maybe (Pdu protocol reply)
deserializePdu = fromDynamic
type instance ToPretty (Pdu x y) =
PrettySurrounded (PutStr "<") (PutStr ">") ("protocol" <:> ToPretty x <+> ToPretty y)
type Tangible i =
( NFData i
, Typeable i
, Show i
)
type TangiblePdu p r =
( Typeable p
, Typeable r
, Tangible (Pdu p r)
, HasPdu p r
)
data Synchronicity =
Synchronous Type
| Asynchronous
deriving Typeable
type family ProtocolReply (s :: Synchronicity) where
ProtocolReply ('Synchronous t) = t
ProtocolReply 'Asynchronous = ()
type instance ToPretty (Endpoint a) = ToPretty a <+> PutStr "endpoint"
makeLenses ''Endpoint
instance (Typeable r, HasPdu a1 r, HasPdu a2 r) => HasPdu (a1, a2) r where
data instance Pdu (a1, a2) r where
ToPduLeft :: Pdu a1 r -> Pdu (a1, a2) r
ToPduRight :: Pdu a2 r -> Pdu (a1, a2) r
deserializePdu d =
case deserializePdu d of
Just (x :: Pdu a1 r) ->
Just (embedPdu x)
Nothing ->
case deserializePdu d of
Just (x :: Pdu a2 r) ->
Just (embedPdu x)
Nothing ->
Nothing
instance (Typeable r, HasPdu a1 r, HasPdu a2 r, HasPdu a3 r) => HasPdu (a1, a2, a3) r where
data instance Pdu (a1, a2, a3) r where
ToPdu1 :: Pdu a1 r -> Pdu (a1, a2, a3) r
ToPdu2 :: Pdu a2 r -> Pdu (a1, a2, a3) r
ToPdu3 :: Pdu a3 r -> Pdu (a1, a2, a3) r
deserializePdu d =
case deserializePdu d of
Just (x :: Pdu a1 r) ->
Just (embedPdu x)
Nothing ->
case deserializePdu d of
Just (x :: Pdu a2 r) ->
Just (embedPdu x)
Nothing ->
case deserializePdu d of
Just (x :: Pdu a3 r) ->
Just (embedPdu x)
Nothing ->
Nothing
instance (Typeable r, HasPdu a1 r, HasPdu a2 r, HasPdu a3 r, HasPdu a4 r) => HasPdu (a1, a2, a3, a4) r where
data instance Pdu (a1, a2, a3, a4) r where
ToPdu1Of4 :: Pdu a1 r -> Pdu (a1, a2, a3, a4) r
ToPdu2Of4 :: Pdu a2 r -> Pdu (a1, a2, a3, a4) r
ToPdu3Of4 :: Pdu a3 r -> Pdu (a1, a2, a3, a4) r
ToPdu4Of4 :: Pdu a4 r -> Pdu (a1, a2, a3, a4) r
deserializePdu d =
case deserializePdu d of
Just (x :: Pdu a1 r) ->
Just (embedPdu x)
Nothing ->
case deserializePdu d of
Just (x :: Pdu a2 r) ->
Just (embedPdu x)
Nothing ->
case deserializePdu d of
Just (x :: Pdu a3 r) ->
Just (embedPdu x)
Nothing ->
case deserializePdu d of
Just (x :: Pdu a4 r) ->
Just (embedPdu x)
Nothing ->
Nothing
instance (Typeable r, HasPdu a1 r, HasPdu a2 r, HasPdu a3 r, HasPdu a4 r, HasPdu a5 r) => HasPdu (a1, a2, a3, a4, a5) r where
data instance Pdu (a1, a2, a3, a4, a5) r where
ToPdu1Of5 :: Pdu a1 r -> Pdu (a1, a2, a3, a4, a5) r
ToPdu2Of5 :: Pdu a2 r -> Pdu (a1, a2, a3, a4, a5) r
ToPdu3Of5 :: Pdu a3 r -> Pdu (a1, a2, a3, a4, a5) r
ToPdu4Of5 :: Pdu a4 r -> Pdu (a1, a2, a3, a4, a5) r
ToPdu5Of5 :: Pdu a5 r -> Pdu (a1, a2, a3, a4, a5) r
deserializePdu d =
case deserializePdu d of
Just (x :: Pdu a1 r) ->
Just (embedPdu x)
Nothing ->
case deserializePdu d of
Just (x :: Pdu a2 r) ->
Just (embedPdu x)
Nothing ->
case deserializePdu d of
Just (x :: Pdu a3 r) ->
Just (embedPdu x)
Nothing ->
case deserializePdu d of
Just (x :: Pdu a4 r) ->
Just (embedPdu x)
Nothing ->
case deserializePdu d of
Just (x :: Pdu a5 r) ->
Just (embedPdu x)
Nothing ->
Nothing
proxyAsEndpoint :: proxy protocol -> ProcessId -> Endpoint protocol
proxyAsEndpoint = const Endpoint
asEndpoint :: forall protocol . ProcessId -> Endpoint protocol
asEndpoint = Endpoint
class
( HasPdu protocol result
, HasPdu embeddedProtocol result
)
=> EmbedProtocol protocol embeddedProtocol (result :: Synchronicity) where
embeddedPdu :: Prism' (Pdu protocol result) (Pdu embeddedProtocol result)
embeddedPdu = prism' embedPdu fromPdu
embedPdu :: Pdu embeddedProtocol result -> Pdu protocol result
embedPdu = review embeddedPdu
fromPdu :: Pdu protocol result -> Maybe (Pdu embeddedProtocol result)
fromPdu = preview embeddedPdu
toEmbeddedEndpoint :: forall inner outer r . EmbedProtocol outer inner r => Endpoint outer -> Endpoint inner
toEmbeddedEndpoint = coerce
fromEmbeddedEndpoint :: forall outer inner r . EmbedProtocol outer inner r => Endpoint inner -> Endpoint outer
fromEmbeddedEndpoint = coerce
instance HasPdu a r => EmbedProtocol a a r where
embeddedPdu = prism' id Just
embedPdu = id
fromPdu = Just
instance (NFData (Pdu a1 r), NFData (Pdu a2 r)) => NFData (Pdu (a1, a2) r) where
rnf (ToPduLeft x) = rnf x
rnf (ToPduRight y) = rnf y
instance (Show (Pdu a1 r), Show (Pdu a2 r)) => Show (Pdu (a1, a2) r) where
showsPrec d (ToPduLeft x) = showsPrec d x
showsPrec d (ToPduRight y) = showsPrec d y
instance (Typeable r, HasPdu a1 r, HasPdu a2 r) => EmbedProtocol (a1, a2) a1 r where
embedPdu = ToPduLeft
fromPdu (ToPduLeft l) = Just l
fromPdu _ = Nothing
instance (Typeable r, HasPdu a1 r, HasPdu a2 r) => EmbedProtocol (a1, a2) a2 r where
embeddedPdu =
prism' ToPduRight $ \case
ToPduRight r -> Just r
ToPduLeft _ -> Nothing
instance (NFData (Pdu a1 r), NFData (Pdu a2 r), NFData (Pdu a3 r)) => NFData (Pdu (a1, a2, a3) r) where
rnf (ToPdu1 x) = rnf x
rnf (ToPdu2 y) = rnf y
rnf (ToPdu3 z) = rnf z
instance (Show (Pdu a1 r), Show (Pdu a2 r), Show (Pdu a3 r)) => Show (Pdu (a1, a2, a3) r) where
showsPrec d (ToPdu1 x) = showsPrec d x
showsPrec d (ToPdu2 y) = showsPrec d y
showsPrec d (ToPdu3 z) = showsPrec d z
instance (Typeable r, HasPdu a1 r, HasPdu a2 r, HasPdu a3 r) => EmbedProtocol (a1, a2, a3) a1 r where
embedPdu = ToPdu1
fromPdu (ToPdu1 l) = Just l
fromPdu _ = Nothing
instance (Typeable r, HasPdu a1 r, HasPdu a2 r, HasPdu a3 r) => EmbedProtocol (a1, a2, a3) a2 r where
embedPdu = ToPdu2
fromPdu (ToPdu2 l) = Just l
fromPdu _ = Nothing
instance (Typeable r, HasPdu a1 r, HasPdu a2 r, HasPdu a3 r) => EmbedProtocol (a1, a2, a3) a3 r where
embedPdu = ToPdu3
fromPdu (ToPdu3 l) = Just l
fromPdu _ = Nothing
instance (NFData (Pdu a1 r), NFData (Pdu a2 r), NFData (Pdu a3 r), NFData (Pdu a4 r)) => NFData (Pdu (a1, a2, a3, a4) r) where
rnf (ToPdu1Of4 x) = rnf x
rnf (ToPdu2Of4 y) = rnf y
rnf (ToPdu3Of4 z) = rnf z
rnf (ToPdu4Of4 w) = rnf w
instance (Show (Pdu a1 r), Show (Pdu a2 r), Show (Pdu a3 r), Show (Pdu a4 r)) => Show (Pdu (a1, a2, a3, a4) r) where
showsPrec d (ToPdu1Of4 x) = showsPrec d x
showsPrec d (ToPdu2Of4 y) = showsPrec d y
showsPrec d (ToPdu3Of4 z) = showsPrec d z
showsPrec d (ToPdu4Of4 w) = showsPrec d w
instance (Typeable r, HasPdu a1 r, HasPdu a2 r, HasPdu a3 r, HasPdu a4 r) => EmbedProtocol (a1, a2, a3, a4) a1 r where
embedPdu = ToPdu1Of4
fromPdu (ToPdu1Of4 l) = Just l
fromPdu _ = Nothing
instance (Typeable r, HasPdu a1 r, HasPdu a2 r, HasPdu a3 r, HasPdu a4 r) => EmbedProtocol (a1, a2, a3, a4) a2 r where
embedPdu = ToPdu2Of4
fromPdu (ToPdu2Of4 l) = Just l
fromPdu _ = Nothing
instance (Typeable r, HasPdu a1 r, HasPdu a2 r, HasPdu a3 r, HasPdu a4 r) => EmbedProtocol (a1, a2, a3, a4) a3 r where
embedPdu = ToPdu3Of4
fromPdu (ToPdu3Of4 l) = Just l
fromPdu _ = Nothing
instance (Typeable r, HasPdu a1 r, HasPdu a2 r, HasPdu a3 r, HasPdu a4 r) => EmbedProtocol (a1, a2, a3, a4) a4 r where
embedPdu = ToPdu4Of4
fromPdu (ToPdu4Of4 l) = Just l
fromPdu _ = Nothing
instance (Typeable r, NFData (Pdu a1 r), NFData (Pdu a2 r), NFData (Pdu a3 r), NFData (Pdu a4 r), NFData (Pdu a5 r)) => NFData (Pdu (a1, a2, a3, a4, a5) r) where
rnf (ToPdu1Of5 x) = rnf x
rnf (ToPdu2Of5 y) = rnf y
rnf (ToPdu3Of5 z) = rnf z
rnf (ToPdu4Of5 w) = rnf w
rnf (ToPdu5Of5 w) = rnf w
instance (Show (Pdu a1 r), Show (Pdu a2 r), Show (Pdu a3 r), Show (Pdu a4 r), Show (Pdu a5 r)) => Show (Pdu (a1, a2, a3, a4, a5) r) where
showsPrec d (ToPdu1Of5 x) = showsPrec d x
showsPrec d (ToPdu2Of5 y) = showsPrec d y
showsPrec d (ToPdu3Of5 z) = showsPrec d z
showsPrec d (ToPdu4Of5 w) = showsPrec d w
showsPrec d (ToPdu5Of5 v) = showsPrec d v
instance (Typeable r, HasPdu a1 r, HasPdu a2 r, HasPdu a3 r, HasPdu a4 r, HasPdu a5 r) => EmbedProtocol (a1, a2, a3, a4, a5) a1 r where
embedPdu = ToPdu1Of5
fromPdu (ToPdu1Of5 l) = Just l
fromPdu _ = Nothing
instance (Typeable r, HasPdu a1 r, HasPdu a2 r, HasPdu a3 r, HasPdu a4 r, HasPdu a5 r) => EmbedProtocol (a1, a2, a3, a4, a5) a2 r where
embedPdu = ToPdu2Of5
fromPdu (ToPdu2Of5 l) = Just l
fromPdu _ = Nothing
instance (Typeable r, HasPdu a1 r, HasPdu a2 r, HasPdu a3 r, HasPdu a4 r, HasPdu a5 r) => EmbedProtocol (a1, a2, a3, a4, a5) a3 r where
embedPdu = ToPdu3Of5
fromPdu (ToPdu3Of5 l) = Just l
fromPdu _ = Nothing
instance (Typeable r, HasPdu a1 r, HasPdu a2 r, HasPdu a3 r, HasPdu a4 r, HasPdu a5 r) => EmbedProtocol (a1, a2, a3, a4, a5) a4 r where
embedPdu = ToPdu4Of5
fromPdu (ToPdu4Of5 l) = Just l
fromPdu _ = Nothing
instance (Typeable r, HasPdu a1 r, HasPdu a2 r, HasPdu a3 r, HasPdu a4 r, HasPdu a5 r) => EmbedProtocol (a1, a2, a3, a4, a5) a5 r where
embedPdu = ToPdu5Of5
fromPdu (ToPdu5Of5 l) = Just l
fromPdu _ = Nothing