module Control.Eff.Concurrent.Protocol
( Pdu(..)
, Synchronicity(..)
, ProtocolReply
, Tangible
, TangiblePdu
, Endpoint(..)
, fromEndpoint
, proxyAsEndpoint
, asEndpoint
, EmbedProtocol(..)
, prettyTypeableShows
, prettyTypeableShowsPrec
)
where
import Control.DeepSeq
import Control.Eff.Concurrent.Process
import Control.Lens
import Data.Kind
import Type.Reflection
import Data.Type.Pretty
data family Pdu (protocol :: Type) (reply :: Synchronicity)
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
instance EmbedProtocol a a where
embeddedPdu = prism' id Just
embedPdu = id
fromPdu = Just
data instance Pdu (a1, a2) x where
ToPduLeft :: Pdu a1 r -> Pdu (a1, a2) r
ToPduRight :: Pdu a2 r -> Pdu (a1, a2) r
deriving Typeable
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
data instance Pdu (a1, a2, a3) x 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
deriving Typeable
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
data instance Pdu (a1, a2, a3, a4) x 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
deriving Typeable
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
data instance Pdu (a1, a2, a3, a4, a5) x 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
deriving Typeable
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