module Control.Eff.Concurrent.Protocol
( IsPdu(..)
, Pdu(..)
, Synchronicity(..)
, ProtocolReply
, Tangible
, TangiblePdu
, Endpoint(..)
, fromEndpoint
, proxyAsEndpoint
, asEndpoint
, EmbedProtocol(..)
, toEmbeddedEndpoint
, fromEmbeddedEndpoint
, prettyTypeableShows
, prettyTypeableShowsPrec
)
where
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
class (NFData (Pdu protocol reply), Show (Pdu protocol reply), Typeable protocol, Typeable reply) => IsPdu (protocol :: Type) (reply :: Synchronicity) where
deserializePdu :: Dynamic -> Maybe (Pdu protocol reply)
default deserializePdu :: (Typeable (Pdu protocol reply)) => Dynamic -> Maybe (Pdu protocol reply)
deserializePdu = fromDynamic
data family Pdu protocol reply
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)
)
data Synchronicity =
Synchronous Type
| Asynchronous
deriving Typeable
type family ProtocolReply (s :: Synchronicity) where
ProtocolReply ('Synchronous t) = t
ProtocolReply 'Asynchronous = ()
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)
(prettyTypeableShows (SomeTypeRep (typeRep @protocol)) . showsPrec 10 c)
prettyTypeableShows :: SomeTypeRep -> ShowS
prettyTypeableShows = prettyTypeableShowsPrec 0
prettyTypeableShowsPrec :: Int -> SomeTypeRep -> ShowS
prettyTypeableShowsPrec d (SomeTypeRep tr) sIn =
let (con, conArgs) = splitApps tr
in case conArgs of
[] -> showString (tyConName con) sIn
_ ->
showParen
(d >= 10)
(showString (tyConName con) . showChar ':' .
foldr1 (\f acc -> showChar '-' . f . acc)
(prettyTypeableShowsPrec 10 <$> conArgs))
sIn
type instance ToPretty (Endpoint a) = ToPretty a <+> PutStr "endpoint"
makeLenses ''Endpoint
proxyAsEndpoint :: proxy protocol -> ProcessId -> Endpoint protocol
proxyAsEndpoint = const Endpoint
asEndpoint :: forall protocol . ProcessId -> Endpoint protocol
asEndpoint = Endpoint
class EmbedProtocol protocol embeddedProtocol where
embeddedPdu :: Prism' (Pdu protocol result) (Pdu embeddedProtocol result)
embeddedPdu = prism' embedPdu fromPdu
embedPdu :: Pdu embeddedProtocol r -> Pdu protocol r
embedPdu = review embeddedPdu
fromPdu :: Pdu protocol r -> Maybe (Pdu embeddedProtocol r)
fromPdu = preview embeddedPdu
toEmbeddedEndpoint :: forall inner outer . EmbedProtocol outer inner => Endpoint outer -> Endpoint inner
toEmbeddedEndpoint = coerce
fromEmbeddedEndpoint :: forall outer inner. EmbedProtocol outer inner => Endpoint inner -> Endpoint outer
fromEmbeddedEndpoint = coerce
instance EmbedProtocol a a where
embeddedPdu = prism' id Just
embedPdu = id
fromPdu = Just
instance (IsPdu a1 r, IsPdu a2 r) => IsPdu (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 (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 EmbedProtocol (a1, a2) a1 where
embedPdu = ToPduLeft
fromPdu (ToPduLeft l) = Just l
fromPdu _ = Nothing
instance EmbedProtocol (a1, a2) a2 where
embeddedPdu =
prism' ToPduRight $ \case
ToPduRight r -> Just r
ToPduLeft _ -> Nothing
instance (IsPdu a1 r, IsPdu a2 r, IsPdu a3 r) => IsPdu (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 (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 EmbedProtocol (a1, a2, a3) a1 where
embedPdu = ToPdu1
fromPdu (ToPdu1 l) = Just l
fromPdu _ = Nothing
instance EmbedProtocol (a1, a2, a3) a2 where
embedPdu = ToPdu2
fromPdu (ToPdu2 l) = Just l
fromPdu _ = Nothing
instance EmbedProtocol (a1, a2, a3) a3 where
embedPdu = ToPdu3
fromPdu (ToPdu3 l) = Just l
fromPdu _ = Nothing
instance (IsPdu a1 r, IsPdu a2 r, IsPdu a3 r, IsPdu a4 r) => IsPdu (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 (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 EmbedProtocol (a1, a2, a3, a4) a1 where
embedPdu = ToPdu1Of4
fromPdu (ToPdu1Of4 l) = Just l
fromPdu _ = Nothing
instance EmbedProtocol (a1, a2, a3, a4) a2 where
embedPdu = ToPdu2Of4
fromPdu (ToPdu2Of4 l) = Just l
fromPdu _ = Nothing
instance EmbedProtocol (a1, a2, a3, a4) a3 where
embedPdu = ToPdu3Of4
fromPdu (ToPdu3Of4 l) = Just l
fromPdu _ = Nothing
instance EmbedProtocol (a1, a2, a3, a4) a4 where
embedPdu = ToPdu4Of4
fromPdu (ToPdu4Of4 l) = Just l
fromPdu _ = Nothing
instance (IsPdu a1 r, IsPdu a2 r, IsPdu a3 r, IsPdu a4 r, IsPdu a5 r) => IsPdu (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
instance (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 EmbedProtocol (a1, a2, a3, a4, a5) a1 where
embedPdu = ToPdu1Of5
fromPdu (ToPdu1Of5 l) = Just l
fromPdu _ = Nothing
instance EmbedProtocol (a1, a2, a3, a4, a5) a2 where
embedPdu = ToPdu2Of5
fromPdu (ToPdu2Of5 l) = Just l
fromPdu _ = Nothing
instance EmbedProtocol (a1, a2, a3, a4, a5) a3 where
embedPdu = ToPdu3Of5
fromPdu (ToPdu3Of5 l) = Just l
fromPdu _ = Nothing
instance EmbedProtocol (a1, a2, a3, a4, a5) a4 where
embedPdu = ToPdu4Of5
fromPdu (ToPdu4Of5 l) = Just l
fromPdu _ = Nothing
instance EmbedProtocol (a1, a2, a3, a4, a5) a5 where
embedPdu = ToPdu5Of5
fromPdu (ToPdu5Of5 l) = Just l
fromPdu _ = Nothing