6 import Data.List |
6 import Data.List |
7 import Data.Char |
7 import Data.Char |
8 import qualified Data.Set as Set |
8 import qualified Data.Set as Set |
9 |
9 |
10 data HWProtocol = Command String [CmdParam] |
10 data HWProtocol = Command String [CmdParam] |
|
11 deriving Show |
11 |
12 |
12 instance Ord HWProtocol where |
13 instance Ord HWProtocol where |
13 (Command a _) `compare` (Command b _) = a `compare` b |
14 (Command a _) `compare` (Command b _) = a `compare` b |
14 instance Eq HWProtocol where |
15 instance Eq HWProtocol where |
15 (Command a _) == (Command b _) = a == b |
16 (Command a _) == (Command b _) = a == b |
17 data CmdParam = Skip |
18 data CmdParam = Skip |
18 | SS |
19 | SS |
19 | LS |
20 | LS |
20 | IntP |
21 | IntP |
21 | Many [CmdParam] |
22 | Many [CmdParam] |
22 data ClientStates = NotConnected |
23 deriving Show |
23 | JustConnected |
|
24 | ServerAuth |
|
25 | Lobby |
|
26 |
24 |
27 data ParseTree = PTPrefix String [ParseTree] |
25 data ParseTree = PTPrefix String [ParseTree] |
28 | PTCommand String HWProtocol |
26 | PTCommand String HWProtocol |
|
27 deriving Show |
29 |
28 |
30 cmd = Command |
29 cmd = Command |
31 cmd1 s p = Command s [p] |
30 cmd1 s p = Command s [p] |
32 cmd2 s p1 p2 = Command s [p1, p2] |
31 cmd2 s p1 p2 = Command s [p1, p2] |
33 |
32 |
88 , cmd1 "PING" $ Many [SS] |
87 , cmd1 "PING" $ Many [SS] |
89 , cmd2 "CHAT" SS LS |
88 , cmd2 "CHAT" SS LS |
90 , cmd2 "SERVER_VARS" SS LS |
89 , cmd2 "SERVER_VARS" SS LS |
91 , cmd2 "BYE" SS LS |
90 , cmd2 "BYE" SS LS |
92 , cmd1 "INFO" $ Many [SS] |
91 , cmd1 "INFO" $ Many [SS] |
|
92 , cmd1 "ROOM" $ Many [SS] |
93 , cmd1 "ROOMS" $ Many [SS] |
93 , cmd1 "ROOMS" $ Many [SS] |
94 , cmd "KICKED" [] |
94 , cmd "KICKED" [] |
95 , cmd "RUN_GAME" [] |
95 , cmd "RUN_GAME" [] |
96 , cmd "ROUND_FINISHED" [] |
96 , cmd "ROUND_FINISHED" [] |
97 ] |
97 ] |
121 assocs = groupByFirstChar cmds |
121 assocs = groupByFirstChar cmds |
122 subtree = map buildsub assocs |
122 subtree = map buildsub assocs |
123 buildsub (c, cmds) = let st = bpt cmds in if null $ drop 1 st then maybeMerge c st else PTPrefix [c] st |
123 buildsub (c, cmds) = let st = bpt cmds in if null $ drop 1 st then maybeMerge c st else PTPrefix [c] st |
124 maybeMerge c cmd@[PTCommand {}] = PTPrefix [c] cmd |
124 maybeMerge c cmd@[PTCommand {}] = PTPrefix [c] cmd |
125 maybeMerge c cmd@[PTPrefix s ss] = PTPrefix (c:s) ss |
125 maybeMerge c cmd@[PTPrefix s ss] = PTPrefix (c:s) ss |
126 cmdLeaf ([(c, (hwc:_))], assocs2) = (PTPrefix [c] [hwc]) : map buildsub assocs2 |
126 cmdLeaf ([(c, (hwc:assocs1))], assocs2) = (PTPrefix [c] [hwc]) : (bpt assocs1 ++ map buildsub assocs2) |
127 |
127 |
128 dumpTree = vcat . map dt |
128 dumpTree = vcat . map dt |
129 where |
129 where |
130 dt (PTPrefix s st) = text s $$ (nest 1 $ vcat $ map dt st) |
130 dt (PTPrefix s st) = text s $$ (nest 1 $ vcat $ map dt st) |
131 dt _ = empty |
131 dt _ = empty |
132 |
|
133 pas2 = buildSwitch $ buildParseTree commandsDescription |
|
134 where |
|
135 buildSwitch cmds = text "case getNextChar of" $$ (nest 4 . vcat $ map buildCase cmds) $$ elsePart |
|
136 buildCase (PTCommand {}) = text "#10: <call cmd handler>;" |
|
137 buildCase (PTPrefix (s:ss) cmds) = quotes (char s) <> text ": " <> consumePrefix ss (buildSwitch cmds) |
|
138 consumePrefix "" = id |
|
139 consumePrefix str = (text "consume" <> (parens . quotes $ text str) <> semi $$) |
|
140 zeroChar = text "#0: state:= pstDisconnected;" |
|
141 elsePart = text "else <unknown cmd> end;" |
|
142 |
132 |
143 renderArrays (letters, commands, handlers) = vcat $ punctuate (char '\n') [grr, cmds, l, s, c, bodies, structs, realHandlers, realHandlersArray] |
133 renderArrays (letters, commands, handlers) = vcat $ punctuate (char '\n') [grr, cmds, l, s, c, bodies, structs, realHandlers, realHandlersArray] |
144 where |
134 where |
145 maybeQuotes "$" = text "#0" |
135 maybeQuotes "$" = text "#0" |
146 maybeQuotes s = if null $ tail s then quotes $ text s else text s |
136 maybeQuotes s = if null $ tail s then quotes $ text s else text s |