{-# LANGUAGE UndecidableInstances, QuantifiedConstraints #-}
module Control.Eff.Concurrent.Protocol
( HasPdu(..)
, deserializePdu
, Embeds
, Pdu(..)
, Synchronicity(..)
, ProtocolReply
, Tangible
, TangiblePdu
, Endpoint(..)
, fromEndpoint
, proxyAsEndpoint
, asEndpoint
, HasPduPrism(..)
, toEmbeddedEndpoint
, fromEmbeddedEndpoint
)
where
import Control.Eff.Concurrent.Misc
import Control.DeepSeq
import Control.Eff.Concurrent.Process
import Control.Lens
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 Typeable protocol => HasPdu (protocol :: Type) where
type family EmbeddedPduList protocol :: [Type]
type instance EmbeddedPduList protocol = '[]
data family Pdu protocol (reply :: Synchronicity)
deserializePdu :: (Typeable (Pdu protocol reply)) => Dynamic -> Maybe (Pdu protocol reply)
deserializePdu = fromDynamic
type Embeds outer inner =
( HasPduPrism outer inner
, CheckEmbeds outer inner
, HasPdu outer
)
type family CheckEmbeds outer inner :: Constraint where
CheckEmbeds outer outer = ()
CheckEmbeds outer inner =
IsProtocolOneOf
inner
(EmbeddedPduList outer)
(EmbeddedPduList outer)
~ 'IsEmbeddedProtocol
data IsEmbeddedProtocol k = IsEmbeddedProtocol | IsNotAnEmbeddedProtocol k [k]
type family IsProtocolOneOf (x :: k) (xs :: [k]) (orig :: [k]) :: IsEmbeddedProtocol k where
IsProtocolOneOf x '[] orig = 'IsNotAnEmbeddedProtocol x orig
IsProtocolOneOf x (x ': xs) orig = 'IsEmbeddedProtocol
IsProtocolOneOf x (y ': xs) orig = IsProtocolOneOf x xs orig
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
)
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"
instance (HasPdu a1, HasPdu a2) => HasPdu (a1, a2) where
type instance EmbeddedPduList (a1, a2) = '[a1, a2]
data instance Pdu (a1, a2) r where
ToPduLeft :: Pdu a1 r -> Pdu (a1, a2) r
ToPduRight :: Pdu a2 r -> Pdu (a1, a2) r
instance (HasPdu a1, HasPdu a2, HasPdu a3) => HasPdu (a1, a2, a3) where
type instance EmbeddedPduList (a1, a2, a3) = '[a1, a2, a3]
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
instance (HasPdu a1, HasPdu a2, HasPdu a3, HasPdu a4) => HasPdu (a1, a2, a3, a4) where
type instance EmbeddedPduList (a1, a2, a3, a4) = '[a1, a2, a3, a4]
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
instance (HasPdu a1, HasPdu a2, HasPdu a3, HasPdu a4, HasPdu a5) => HasPdu (a1, a2, a3, a4, a5) where
type instance EmbeddedPduList (a1, a2, a3, a4, a5) = '[a1, a2, a3, a4, a5]
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
proxyAsEndpoint :: proxy protocol -> ProcessId -> Endpoint protocol
proxyAsEndpoint = const Endpoint
asEndpoint :: forall protocol . ProcessId -> Endpoint protocol
asEndpoint = Endpoint
class
(Typeable protocol, Typeable embeddedProtocol)
=> HasPduPrism protocol embeddedProtocol where
embeddedPdu
:: forall (result :: Synchronicity)
. Prism' (Pdu protocol result) (Pdu embeddedProtocol result)
embeddedPdu = prism' embedPdu fromPdu
embedPdu
:: forall (result :: Synchronicity)
. Pdu embeddedProtocol result -> Pdu protocol result
embedPdu = review embeddedPdu
fromPdu
:: forall (result :: Synchronicity)
. Pdu protocol result -> Maybe (Pdu embeddedProtocol result)
fromPdu = preview embeddedPdu
toEmbeddedEndpoint :: forall inner outer . Embeds outer inner => Endpoint outer -> Endpoint inner
toEmbeddedEndpoint (Endpoint e) = Endpoint e
fromEmbeddedEndpoint :: forall outer inner . HasPduPrism outer inner => Endpoint inner -> Endpoint outer
fromEmbeddedEndpoint (Endpoint e) = Endpoint e
instance (Typeable a) => HasPduPrism a a where
embeddedPdu = prism' id Just
embedPdu = id
fromPdu = Just
instance (Typeable a1, Typeable a2) => HasPduPrism (a1, a2) a1 where
embedPdu = ToPduLeft
fromPdu (ToPduLeft l) = Just l
fromPdu _ = Nothing
instance (Typeable a1, Typeable a2) => HasPduPrism (a1, a2) a2 where
embeddedPdu =
prism' ToPduRight $ \case
ToPduRight r -> Just r
ToPduLeft _ -> Nothing
instance (Typeable a1, Typeable a2, Typeable a3) => HasPduPrism (a1, a2, a3) a1 where
embedPdu = ToPdu1
fromPdu (ToPdu1 l) = Just l
fromPdu _ = Nothing
instance (Typeable a1, Typeable a2, Typeable a3) => HasPduPrism (a1, a2, a3) a2 where
embedPdu = ToPdu2
fromPdu (ToPdu2 l) = Just l
fromPdu _ = Nothing
instance (Typeable a1, Typeable a2, Typeable a3) => HasPduPrism (a1, a2, a3) a3 where
embedPdu = ToPdu3
fromPdu (ToPdu3 l) = Just l
fromPdu _ = 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 (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 (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 (HasPdu a1, HasPdu a2, HasPdu a3, HasPdu a4) => HasPduPrism (a1, a2, a3, a4) a1 where
embedPdu = ToPdu1Of4
fromPdu (ToPdu1Of4 l) = Just l
fromPdu _ = Nothing
instance (HasPdu a1, HasPdu a2, HasPdu a3, HasPdu a4) => HasPduPrism (a1, a2, a3, a4) a2 where
embedPdu = ToPdu2Of4
fromPdu (ToPdu2Of4 l) = Just l
fromPdu _ = Nothing
instance (HasPdu a1, HasPdu a2, HasPdu a3, HasPdu a4) => HasPduPrism (a1, a2, a3, a4) a3 where
embedPdu = ToPdu3Of4
fromPdu (ToPdu3Of4 l) = Just l
fromPdu _ = Nothing
instance (HasPdu a1, HasPdu a2, HasPdu a3, HasPdu a4) => HasPduPrism (a1, a2, a3, a4) a4 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 (HasPdu a1, HasPdu a2, HasPdu a3, HasPdu a4, HasPdu a5) => HasPduPrism (a1, a2, a3, a4, a5) a1 where
embedPdu = ToPdu1Of5
fromPdu (ToPdu1Of5 l) = Just l
fromPdu _ = Nothing
instance (HasPdu a1, HasPdu a2, HasPdu a3, HasPdu a4, HasPdu a5) => HasPduPrism (a1, a2, a3, a4, a5) a2 where
embedPdu = ToPdu2Of5
fromPdu (ToPdu2Of5 l) = Just l
fromPdu _ = Nothing
instance (HasPdu a1, HasPdu a2, HasPdu a3, HasPdu a4, HasPdu a5) => HasPduPrism (a1, a2, a3, a4, a5) a3 where
embedPdu = ToPdu3Of5
fromPdu (ToPdu3Of5 l) = Just l
fromPdu _ = Nothing
instance (HasPdu a1, HasPdu a2, HasPdu a3, HasPdu a4, HasPdu a5) => HasPduPrism (a1, a2, a3, a4, a5) a4 where
embedPdu = ToPdu4Of5
fromPdu (ToPdu4Of5 l) = Just l
fromPdu _ = Nothing
instance (HasPdu a1, HasPdu a2, HasPdu a3, HasPdu a4, HasPdu a5) => HasPduPrism (a1, a2, a3, a4, a5) a5 where
embedPdu = ToPdu5Of5
fromPdu (ToPdu5Of5 l) = Just l
fromPdu _ = Nothing
makeLenses ''Endpoint