|
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
|
|
10927
|
7 |
import Data.Char
|
|
10898
|
8 |
|
|
|
9 |
data HWProtocol = Command String [CmdParam]
|
|
|
10 |
data CmdParam = Skip
|
|
|
11 |
| SS
|
|
|
12 |
| LS
|
|
|
13 |
| IntP
|
|
|
14 |
| Many [CmdParam]
|
|
|
15 |
data ClientStates = NotConnected
|
|
|
16 |
| JustConnected
|
|
|
17 |
| ServerAuth
|
|
|
18 |
| Lobby
|
|
|
19 |
|
|
10906
|
20 |
data ParseTree = PTPrefix String [ParseTree]
|
|
10927
|
21 |
| PTCommand String HWProtocol
|
|
10902
|
22 |
|
|
10898
|
23 |
cmd = Command
|
|
|
24 |
cmd1 s p = Command s [p]
|
|
|
25 |
cmd2 s p1 p2 = Command s [p1, p2]
|
|
|
26 |
|
|
10927
|
27 |
breakCmd (PTCommand (c:cs) params) = (c, PTCommand cs params)
|
|
10902
|
28 |
|
|
10898
|
29 |
commands = [
|
|
|
30 |
cmd "CONNECTED" [Skip, IntP]
|
|
|
31 |
, cmd1 "NICK" SS
|
|
|
32 |
, cmd1 "PROTO" IntP
|
|
|
33 |
, cmd1 "ASKPASSWORD" SS
|
|
|
34 |
, cmd1 "SERVER_AUTH" SS
|
|
10904
|
35 |
, cmd1 "JOINING" SS
|
|
|
36 |
, cmd1 "BANLIST" $ Many [SS]
|
|
|
37 |
, cmd1 "JOINED" $ Many [SS]
|
|
10898
|
38 |
, cmd1 "LOBBY:JOINED" $ Many [SS]
|
|
10904
|
39 |
, cmd2 "LOBBY:LEFT" SS LS
|
|
|
40 |
, cmd2 "CLIENT_FLAGS" SS $ Many [SS]
|
|
|
41 |
, cmd2 "LEFT" SS $ Many [SS]
|
|
10902
|
42 |
, cmd1 "SERVER_MESSAGE" LS
|
|
10904
|
43 |
, cmd1 "EM" $ Many [LS]
|
|
|
44 |
, cmd1 "PING" $ Many [SS]
|
|
|
45 |
, cmd2 "CHAT" SS LS
|
|
|
46 |
, cmd2 "SERVER_VARS" SS LS
|
|
|
47 |
, cmd2 "BYE" SS LS
|
|
10908
|
48 |
, cmd1 "INFO" $ Many [SS]
|
|
10904
|
49 |
, cmd "KICKED" []
|
|
10898
|
50 |
]
|
|
|
51 |
|
|
10927
|
52 |
groupByFirstChar :: [ParseTree] -> [(Char, [ParseTree])]
|
|
10904
|
53 |
groupByFirstChar = MM.assocs . MM.fromList . map breakCmd
|
|
10902
|
54 |
|
|
10927
|
55 |
makePT cmd@(Command n p) = PTCommand n cmd
|
|
|
56 |
|
|
|
57 |
buildParseTree cmds = [PTPrefix "!" $ bpt $ map makePT cmds]
|
|
10925
|
58 |
bpt cmds = if isJust emptyNamed then cmdLeaf $ fromJust emptyNamed else subtree
|
|
10904
|
59 |
where
|
|
10927
|
60 |
emptyNamed = find (\(_, (PTCommand n _:_)) -> null n) assocs
|
|
10904
|
61 |
assocs = groupByFirstChar cmds
|
|
10906
|
62 |
subtree = map buildsub assocs
|
|
10925
|
63 |
buildsub (c, cmds) = let st = bpt cmds in if null $ drop 1 st then maybeMerge c st else PTPrefix [c] st
|
|
10927
|
64 |
maybeMerge c cmd@[PTCommand {}] = PTPrefix [c] cmd
|
|
10906
|
65 |
maybeMerge c cmd@[PTPrefix s ss] = PTPrefix (c:s) ss
|
|
10927
|
66 |
cmdLeaf (c, (hwc:_)) = [PTPrefix [c] [hwc]]
|
|
10906
|
67 |
|
|
|
68 |
dumpTree = vcat . map dt
|
|
|
69 |
where
|
|
|
70 |
dt (PTPrefix s st) = text s $$ (nest 1 $ vcat $ map dt st)
|
|
|
71 |
dt _ = empty
|
|
10904
|
72 |
|
|
10908
|
73 |
pas2 = buildSwitch $ buildParseTree commands
|
|
10906
|
74 |
where
|
|
|
75 |
buildSwitch cmds = text "case getNextChar of" $$ (nest 4 . vcat $ map buildCase cmds) $$ elsePart
|
|
10927
|
76 |
buildCase (PTCommand {}) = text "#10: <call cmd handler>;"
|
|
10906
|
77 |
buildCase (PTPrefix (s:ss) cmds) = quotes (char s) <> text ": " <> consumePrefix ss (buildSwitch cmds)
|
|
|
78 |
consumePrefix "" = id
|
|
|
79 |
consumePrefix str = (text "consume" <> (parens . quotes $ text str) <> semi $$)
|
|
|
80 |
zeroChar = text "#0: state:= pstDisconnected;"
|
|
|
81 |
elsePart = text "else <unknown cmd> end;"
|
|
10904
|
82 |
|
|
10927
|
83 |
renderArrays (letters, commands, handlers) = l $+$ s $+$ c
|
|
10908
|
84 |
where
|
|
10925
|
85 |
maybeQuotes s = if null $ tail s then quotes $ text s else text s
|
|
|
86 |
l = text "const letters: array[0.." <> (int $ length letters - 1) <> text "] of char = "
|
|
|
87 |
<> parens (hsep . punctuate comma $ map maybeQuotes letters) <> semi
|
|
|
88 |
s = text "const commands: array[0.." <> (int $ length commands - 1) <> text "] of integer = "
|
|
|
89 |
<> parens (hsep . punctuate comma $ map text commands) <> semi
|
|
10927
|
90 |
c = text "const handlers: array[0.." <> (int $ length handlers - 1) <> text "] of integer = "
|
|
|
91 |
<> parens (hsep . punctuate comma $ map (text . mangle . fixName) handlers) <> semi
|
|
|
92 |
mangle = (++) "handler_"
|
|
|
93 |
fixName = map fixChar
|
|
|
94 |
fixChar c | isLetter c = c
|
|
|
95 |
| otherwise = '_'
|
|
10908
|
96 |
|
|
10927
|
97 |
pas = renderArrays $ buildTables $ buildParseTree commands
|
|
10925
|
98 |
where
|
|
10927
|
99 |
buildTables cmds = let (_, _, _, t1, t2, t3) = foldr walk (0, [0], -10, [], [], [[]]) cmds in (tail t1, tail t2, concat t3)
|
|
|
100 |
walk (PTCommand _ (Command n params)) (lc, s:sh, pc, tbl1, tbl2, (t3:tbl3)) =
|
|
|
101 |
(lc, 2:sh, pc - 1, "#10":"0":tbl1, "0":show pc:tbl2, (n:t3):tbl3)
|
|
10925
|
102 |
walk (PTPrefix prefix cmds) l = lvldown $ foldr fpf (foldr walk (lvlup l) cmds) prefix
|
|
10927
|
103 |
lvlup (lc, sh, pc, tbl1, tbl2, tbl3) = (lc, 0:sh, pc, tbl1, tbl2, []:tbl3)
|
|
|
104 |
lvldown (lc, s1:s2:sh, pc, tbl1, t:tbl2, t31:t32:tbl3) = (lc, s1+s2:sh, pc, tbl1, (if null t32 then "0" else show s1):tbl2, (t31 ++ t32):tbl3)
|
|
|
105 |
fpf c (lc, s:sh, pc, tbl1, tbl2, tbl3) = (lc + 1, s+1:sh, pc, [c]:tbl1, "0":tbl2, tbl3)
|
|
10925
|
106 |
|
|
|
107 |
main = putStrLn $ renderStyle style{lineLength = 80} pas
|