Skip to content

Commit bbff607

Browse files
tdammerstdammers
committed
Move test protocol out of library, and remove some dev code
1 parent 84bc56a commit bbff607

File tree

9 files changed

+169
-29
lines changed

9 files changed

+169
-29
lines changed

‎typed-protocols-doc/demo/DemoProtocol.hs‎

Lines changed: 154 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,154 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE DerivingVia #-}
3+
{-# LANGUAGE EmptyCase #-}
4+
{-# LANGUAGE FlexibleContexts #-}
5+
{-# LANGUAGE FlexibleInstances #-}
6+
{-# LANGUAGE GADTs #-}
7+
{-# LANGUAGE MultiParamTypeClasses #-}
8+
{-# LANGUAGE StandaloneDeriving #-}
9+
{-# LANGUAGE TypeApplications #-}
10+
{-# LANGUAGE TypeFamilies #-}
11+
{-# LANGUAGE UndecidableInstances #-}
12+
{-# LANGUAGE ScopedTypeVariables #-}
13+
{-# LANGUAGE TemplateHaskell #-}
14+
15+
module DemoProtocol
16+
where
17+
18+
import Network.TypedProtocol.Core
19+
import Data.SerDoc.Info
20+
import Control.Monad.Identity
21+
import Control.Monad.Except
22+
import Data.Proxy
23+
import Data.Word
24+
import Data.Typeable
25+
import Data.SerDoc.Class
26+
import Data.SerDoc.TH
27+
import Data.Text (Text)
28+
29+
data PongInfo =
30+
PongInfo
31+
{ pongTimestamp :: Word64
32+
, pongPeerID :: Word64
33+
, pongMessage :: Text
34+
}
35+
deriving (Show, Eq)
36+
37+
data DemoProtocol a where
38+
-- | Idle state: server waits for ping.
39+
IdleState :: DemoProtocol a
40+
41+
-- | Awaiting pong state: server has received ping, client waits for pong.
42+
AwaitingPongState :: DemoProtocol a
43+
44+
-- | End state: either side has terminated the session
45+
EndState :: DemoProtocol a
46+
47+
instance Protocol (DemoProtocol a) where
48+
data Message (DemoProtocol a) st st' where
49+
PingMessage :: Message (DemoProtocol a) IdleState AwaitingPongState
50+
PongMessage :: Message (DemoProtocol a) AwaitingPongState IdleState
51+
ComplexPongMessage :: Message (DemoProtocol a) AwaitingPongState IdleState
52+
EndMessage :: Message (DemoProtocol a) st EndState
53+
54+
data ServerHasAgency st where
55+
TokIdle :: ServerHasAgency IdleState
56+
57+
data ClientHasAgency st where
58+
TokAwaitingPongState :: ClientHasAgency AwaitingPongState
59+
60+
data NobodyHasAgency st where
61+
TokEnd :: NobodyHasAgency EndState
62+
63+
64+
exclusionLemma_ClientAndServerHaveAgency tok1 tok2 =
65+
case tok1 of
66+
TokAwaitingPongState -> case tok2 of {}
67+
68+
exclusionLemma_NobodyAndClientHaveAgency tok1 tok2 =
69+
case tok1 of
70+
TokEnd -> case tok2 of {}
71+
72+
exclusionLemma_NobodyAndServerHaveAgency tok1 tok2 =
73+
case tok1 of
74+
TokEnd -> case tok2 of {}
75+
76+
data DemoCodec a
77+
78+
instance Codec (DemoCodec a) where
79+
type MonadEncode (DemoCodec a) = Identity
80+
type MonadDecode (DemoCodec a) = Except String
81+
82+
data PongEnum = NormalPong | ComplexPong
83+
deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)
84+
85+
data PingEnum = PingRequest | EndPing
86+
deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable)
87+
88+
deriving via (ViaEnum PongEnum)
89+
instance (Codec codec, HasInfo codec (DefEnumEncoding codec)) => HasInfo codec PongEnum
90+
91+
deriving via (ViaEnum PingEnum)
92+
instance (Codec codec, HasInfo codec (DefEnumEncoding codec)) => HasInfo codec PingEnum
93+
94+
instance HasInfo (DemoCodec b) () where
95+
info _ _ = basicField "()" (FixedSize 0)
96+
97+
instance HasInfo (DemoCodec b) Text where
98+
info codec _ =
99+
compoundField "Text"
100+
[ ("length", info codec (Proxy @Word32))
101+
, ("data", basicField "UTF8 dat" (FixedSize 0))
102+
]
103+
104+
instance HasInfo (DemoCodec b) a => HasInfo (DemoCodec b) [a] where
105+
info codec (_ :: Proxy [a]) =
106+
compoundField "List"
107+
[ ( "length", info codec (Proxy @Word32))
108+
, ( "values"
109+
, listField (VarSize "length") (info codec (Proxy @a))
110+
)
111+
]
112+
113+
114+
instance HasInfo (DemoCodec b) a => HasInfo (DemoCodec b) (Maybe a) where
115+
info codec (_ :: Proxy (Maybe a)) =
116+
compoundField "Maybe"
117+
[ ("isJust", info codec (Proxy @Word32))
118+
, ( "value"
119+
, sumField "isJust"
120+
[ ("Nothing", info codec (Proxy @()))
121+
, ("Just", info codec (Proxy @a))
122+
]
123+
)
124+
]
125+
126+
instance HasInfo (DemoCodec b) (Message (DemoProtocol a) IdleState AwaitingPongState) where
127+
info codec _ = infoOf "PingRequest" $ info codec (Proxy @PingEnum)
128+
129+
instance HasInfo (DemoCodec b) (Message (DemoProtocol a) st EndState) where
130+
info codec _ = infoOf "EndPing" $ info codec (Proxy @PingEnum)
131+
132+
instance HasInfo (DemoCodec a) Word16 where
133+
info _ _ = basicField "Word16" (FixedSize 2)
134+
135+
instance HasInfo (DemoCodec a) Word32 where
136+
info _ _ = basicField "Word32" (FixedSize 4)
137+
138+
instance HasInfo (DemoCodec a) Word64 where
139+
info _ _ = basicField "Word64" (FixedSize 8)
140+
141+
$(deriveSerDoc ''DemoCodec [] ''PongInfo)
142+
143+
instance HasInfo (DemoCodec b) (Message (DemoProtocol a) AwaitingPongState IdleState) where
144+
info codec _ =
145+
compoundField "Pong"
146+
[ ("pongType", info codec (Proxy @PongEnum))
147+
, ("pongData"
148+
, choiceField
149+
(IndexField "pongType")
150+
[ info codec (Proxy @())
151+
, info codec (Proxy @PongInfo)
152+
]
153+
)
154+
]

‎typed-protocols-doc/demo/Main.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -11,10 +11,10 @@ module Main
1111
where
1212

1313
import Network.TypedProtocol.Documentation
14-
import Network.TypedProtocol.Documentation.TestProtocol
14+
import DemoProtocol
1515
import Data.SerDoc.Class
1616

1717
main :: IO ()
1818
main = defaultMain
19-
[ $(describeProtocol ''TestProtocol [''()] ''TestCodec [''()])
19+
[ $(describeProtocol ''DemoProtocol [''()] ''DemoCodec [''()])
2020
]

‎typed-protocols-doc/src/Network/TypedProtocol/Documentation.hs‎

Lines changed: 0 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -6,15 +6,10 @@ module Network.TypedProtocol.Documentation
66
, protocolToDotFile
77

88
, defaultMain
9-
, testMain
109
)
1110
where
1211

1312
import Network.TypedProtocol.Documentation.Types as M
1413
import Network.TypedProtocol.Documentation.TH as M
1514
import Network.TypedProtocol.Documentation.GraphViz
1615
import Network.TypedProtocol.Documentation.DefaultMain
17-
import Network.TypedProtocol.Documentation.Example
18-
19-
testMain :: IO ()
20-
testMain = defaultMain [ testProtocolDescription ]

‎typed-protocols-doc/src/Network/TypedProtocol/Documentation/Example.hs‎

Lines changed: 0 additions & 13 deletions
This file was deleted.

‎typed-protocols-doc/test/Network/TypedProtocol/Tests/ControlProtocol.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -18,7 +18,7 @@
1818
module Network.TypedProtocol.Tests.ControlProtocol where
1919

2020
import Network.TypedProtocol.Documentation
21-
import Network.TypedProtocol.Documentation.TestProtocol (TestCodec)
21+
import Network.TypedProtocol.Tests.TestProtocol (TestCodec)
2222

2323
import Data.ByteString ( ByteString )
2424
import Data.Kind

‎typed-protocols-doc/test/Network/TypedProtocol/Tests/Documentation.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,7 @@ import Data.SerDoc.Class
1111
import Data.Maybe
1212

1313
import Network.TypedProtocol.Documentation
14-
import Network.TypedProtocol.Documentation.TestProtocol
14+
import Network.TypedProtocol.Tests.TestProtocol
1515
import Network.TypedProtocol.Tests.ControlProtocol
1616

1717
{-# ANN module "HLINT: ignore Use camelCase" #-}

typed-protocols-doc/src/Network/TypedProtocol/Documentation/TestProtocol.hs renamed to typed-protocols-doc/test/Network/TypedProtocol/Tests/TestProtocol.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,7 @@
1212
{-# LANGUAGE ScopedTypeVariables #-}
1313
{-# LANGUAGE TemplateHaskell #-}
1414

15-
module Network.TypedProtocol.Documentation.TestProtocol
15+
module Network.TypedProtocol.Tests.TestProtocol
1616
where
1717

1818
import Network.TypedProtocol.Core

typed-protocols-doc/src/Network/TypedProtocol/Documentation/TestProtocolTH.hs renamed to typed-protocols-doc/test/Network/TypedProtocol/Tests/TestProtocolTH.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -11,13 +11,13 @@
1111
{-# LANGUAGE TypeFamilies #-}
1212
{-# LANGUAGE UndecidableInstances #-}
1313

14-
module Network.TypedProtocol.Documentation.TestProtocolTH
14+
module Network.TypedProtocol.Tests.TestProtocolTH
1515
where
1616

1717
import Network.TypedProtocol.Documentation.Html
1818
import Network.TypedProtocol.Documentation.Types
1919
import Network.TypedProtocol.Documentation.TH
20-
import Network.TypedProtocol.Documentation.TestProtocol
20+
import Network.TypedProtocol.Tests.TestProtocol
2121

2222
import Data.SerDoc.Class
2323
import Data.Text (Text)

‎typed-protocols-doc/typed-protocols-doc.cabal‎

Lines changed: 8 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -29,12 +29,9 @@ library
2929
exposed-modules: Network.TypedProtocol.Documentation
3030
, Network.TypedProtocol.Documentation.Types
3131
, Network.TypedProtocol.Documentation.TH
32-
, Network.TypedProtocol.Documentation.TestProtocol
33-
, Network.TypedProtocol.Documentation.TestProtocolTH
3432
, Network.TypedProtocol.Documentation.Html
3533
, Network.TypedProtocol.Documentation.Text
3634
, Network.TypedProtocol.Documentation.GraphViz
37-
, Network.TypedProtocol.Documentation.Example
3835
, Network.TypedProtocol.Documentation.DefaultMain
3936
-- other-modules:
4037
-- other-extensions:
@@ -68,11 +65,14 @@ executable typed-protocols-doc-demo
6865
type: exitcode-stdio-1.0
6966
hs-source-dirs: demo
7067
main-is: Main.hs
71-
-- other-modules:
68+
other-modules: DemoProtocol
7269
-- other-extensions:
7370
build-depends: base >=4.14.0.0 && <5
71+
, typed-protocols
7472
, typed-protocols-doc
7573
, serdoc-core
74+
, mtl
75+
, text
7676

7777

7878
test-suite typed-protocols-doc-test
@@ -83,12 +83,16 @@ test-suite typed-protocols-doc-test
8383
main-is: Main.hs
8484
other-modules: Network.TypedProtocol.Tests.Documentation
8585
, Network.TypedProtocol.Tests.ControlProtocol
86+
, Network.TypedProtocol.Tests.TestProtocol
87+
, Network.TypedProtocol.Tests.TestProtocolTH
8688
-- other-extensions:
8789
build-depends: base >=4.14.0.0 && <5
90+
, blaze-html >=0.9.1.2 && <0.10
8891
, tasty >=1.5 && <1.6
8992
, tasty-quickcheck >=0.10.3 && <0.11
9093
, typed-protocols
9194
, typed-protocols-doc
9295
, serdoc-core
9396
, text >=1.1 && <2.2
9497
, bytestring >=0.11 && <0.13
98+
, mtl

0 commit comments

Comments
 (0)