|
10898
|
1 |
module Main where
|
|
|
2 |
|
|
|
3 |
import Text.PrettyPrint.HughesPJ
|
|
10904
|
4 |
import qualified Data.MultiMap as MM
|
|
|
5 |
import Data.Maybe
|
|
|
6 |
import Data.List
|
|
10898
|
7 |
|
|
|
8 |
data HWProtocol = Command String [CmdParam]
|
|
|
9 |
data CmdParam = Skip
|
|
|
10 |
| SS
|
|
|
11 |
| LS
|
|
|
12 |
| IntP
|
|
|
13 |
| Many [CmdParam]
|
|
|
14 |
data ClientStates = NotConnected
|
|
|
15 |
| JustConnected
|
|
|
16 |
| ServerAuth
|
|
|
17 |
| Lobby
|
|
|
18 |
|
|
10902
|
19 |
data ParseTree = PTChar Char [ParseTree]
|
|
|
20 |
| PTCommand HWProtocol
|
|
|
21 |
|
|
10898
|
22 |
cmd = Command
|
|
|
23 |
cmd1 s p = Command s [p]
|
|
|
24 |
cmd2 s p1 p2 = Command s [p1, p2]
|
|
|
25 |
|
|
10902
|
26 |
breakCmd (Command (c:cs) params) = (c, Command cs params)
|
|
|
27 |
|
|
10898
|
28 |
commands = [
|
|
|
29 |
cmd "CONNECTED" [Skip, IntP]
|
|
|
30 |
, cmd1 "NICK" SS
|
|
|
31 |
, cmd1 "PROTO" IntP
|
|
|
32 |
, cmd1 "ASKPASSWORD" SS
|
|
|
33 |
, cmd1 "SERVER_AUTH" SS
|
|
10904
|
34 |
, cmd1 "JOINING" SS
|
|
|
35 |
, cmd1 "BANLIST" $ Many [SS]
|
|
|
36 |
, cmd1 "JOINED" $ Many [SS]
|
|
10898
|
37 |
, cmd1 "LOBBY:JOINED" $ Many [SS]
|
|
10904
|
38 |
, cmd2 "LOBBY:LEFT" SS LS
|
|
|
39 |
, cmd2 "CLIENT_FLAGS" SS $ Many [SS]
|
|
|
40 |
, cmd2 "LEFT" SS $ Many [SS]
|
|
10902
|
41 |
, cmd1 "SERVER_MESSAGE" LS
|
|
10904
|
42 |
, cmd1 "EM" $ Many [LS]
|
|
|
43 |
, cmd1 "PING" $ Many [SS]
|
|
|
44 |
, cmd2 "CHAT" SS LS
|
|
|
45 |
, cmd2 "SERVER_VARS" SS LS
|
|
|
46 |
, cmd2 "BYE" SS LS
|
|
|
47 |
, cmd "INFO" [SS, SS, SS, SS]
|
|
|
48 |
, cmd "KICKED" []
|
|
10898
|
49 |
]
|
|
|
50 |
|
|
10904
|
51 |
groupByFirstChar :: [HWProtocol] -> [(Char, [HWProtocol])]
|
|
|
52 |
groupByFirstChar = MM.assocs . MM.fromList . map breakCmd
|
|
10902
|
53 |
|
|
10904
|
54 |
buildParseTree cmds = if isJust emptyNamed then cmdLeaf $ fromJust emptyNamed else subtree
|
|
|
55 |
where
|
|
|
56 |
emptyNamed = find (\(_, (Command n _:_)) -> null n) assocs
|
|
|
57 |
assocs = groupByFirstChar cmds
|
|
|
58 |
subtree = map (\(c, cmds) -> PTChar c $ buildParseTree cmds) assocs
|
|
|
59 |
cmdLeaf (c, (hwc:_)) = [PTChar c [PTCommand hwc]]
|
|
|
60 |
|
|
|
61 |
dumpTree (PTChar c st) = char c $$ (nest 2 $ vcat $ map dumpTree st)
|
|
|
62 |
dumpTree _ = empty
|
|
|
63 |
|
|
|
64 |
pas = vcat . map dumpTree $ buildParseTree commands
|
|
10900
|
65 |
|
|
|
66 |
main = putStrLn $ render pas
|