IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

rename to runProtocol, remove ProtocolCmd constructor export

Browse Source
This commit is contained in:
Evgeny Poberezkin 2020-07-12 19:13:45 +01:00
parent f97a7885a0
commit 3d7992835f
2 changed files with 9 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
definitions/src/Control/Protocol.hs
View File

@ -1,6 +1,5 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
@ -11,10 +10,10 @@
module Control.Protocol module Control.Protocol
( Protocol, ( Protocol,
ProtocolCmd (..), ProtocolCmd,
Command, Command,
(->:), (->:),
interpret, runProtocol,
) )
where where
@ -43,22 +42,19 @@ infix 6 ->:
Protocol cmd ps s (Inj ps (Inj ps s from fs') to ts') a Protocol cmd ps s (Inj ps (Inj ps s from fs') to ts') a
(->:) f t c = xfree $ ProtocolCmd f t c (->:) f t c = xfree $ ProtocolCmd f t c
interpret :: runProtocol ::
forall m cmd ps s s' a. forall m cmd ps s s' a.
Monad m => Monad m =>
(forall from to b. (Sing (P from) -> Sing (P to) -> cmd from to b -> m b)) -> (forall from to b. (Sing (P from) -> Sing (P to) -> cmd from to b -> m b)) ->
Protocol cmd ps s s' a -> Protocol cmd ps s s' a ->
m a m a
interpret runCommand = loop runProtocol runCmd = loop
where where
loop :: forall s1 s2 b. Protocol cmd ps s1 s2 b -> m b loop :: forall s1 s2 b. Protocol cmd ps s1 s2 b -> m b
loop = \case loop (Pure x) = return x
Pure x -> return x loop (Bind c f) = run c >>= loop . f
Bind c f -> do
x <- run c
loop (f x)
run :: forall s1 s2 b. ProtocolCmd cmd ps s1 s2 b -> m b run :: forall s1 s2 b. ProtocolCmd cmd ps s1 s2 b -> m b
run (ProtocolCmd from to cmd) = runCommand from to cmd run (ProtocolCmd from to cmd) = runCmd from to cmd
type family P (partyCmd :: (party, s, s)) where type family P (partyCmd :: (party, s, s)) where
P '(p, _, _) = p P '(p, _, _) = p

4
definitions/src/Simplex/Messaging/PrintScenario.hs
View File

@ -10,7 +10,7 @@
module Simplex.Messaging.PrintScenario where module Simplex.Messaging.PrintScenario where
import Control.Monad.Writer import Control.Monad.Writer
import Control.Protocol (interpret) import Control.Protocol (runProtocol)
import Data.Singletons import Data.Singletons
import Simplex.Messaging.Protocol import Simplex.Messaging.Protocol
import Simplex.Messaging.Types import Simplex.Messaging.Types
@ -28,7 +28,7 @@ printScenario scn = ps 1 "" $ execWriter $ logScenario scn
prefix s = " - " <> s prefix s = " - " <> s
logScenario :: MonadWriter [(String, String)] m => SimplexProtocol s s' a -> m a logScenario :: MonadWriter [(String, String)] m => SimplexProtocol s s' a -> m a
logScenario = interpret $ \from to cmd -> do logScenario = runProtocol $ \from to cmd -> do
tell [(party from, commandStr cmd <> " " <> party to)] tell [(party from, commandStr cmd <> " " <> party to)]
mockCommand cmd mockCommand cmd