31 , cmd1 "NICK" SS |
31 , cmd1 "NICK" SS |
32 , cmd1 "PROTO" IntP |
32 , cmd1 "PROTO" IntP |
33 , cmd1 "ASKPASSWORD" SS |
33 , cmd1 "ASKPASSWORD" SS |
34 , cmd1 "SERVER_AUTH" SS |
34 , cmd1 "SERVER_AUTH" SS |
35 , cmd1 "JOINING" SS |
35 , cmd1 "JOINING" SS |
|
36 , cmd1 "TEAM_ACCEPTED" SS |
|
37 , cmd1 "HH_NUM" $ Many [SS] |
|
38 , cmd1 "TEAM_COLOR" $ Many [SS] |
|
39 , cmd1 "TEAM_ACCEPTED" SS |
36 , cmd1 "BANLIST" $ Many [SS] |
40 , cmd1 "BANLIST" $ Many [SS] |
37 , cmd1 "JOINED" $ Many [SS] |
41 , cmd1 "JOINED" $ Many [SS] |
38 , cmd1 "LOBBY:JOINED" $ Many [SS] |
42 , cmd1 "LOBBY:JOINED" $ Many [SS] |
39 , cmd2 "LOBBY:LEFT" SS LS |
43 , cmd2 "LOBBY:LEFT" SS LS |
40 , cmd2 "CLIENT_FLAGS" SS $ Many [SS] |
44 , cmd2 "CLIENT_FLAGS" SS $ Many [SS] |
41 , cmd2 "LEFT" SS $ Many [SS] |
45 , cmd2 "LEFT" SS $ Many [SS] |
42 , cmd1 "SERVER_MESSAGE" LS |
46 , cmd1 "SERVER_MESSAGE" LS |
|
47 , cmd1 "ERROR" LS |
|
48 , cmd1 "NOTICE" LS |
|
49 , cmd1 "WARNING" LS |
|
50 , cmd1 "JOINING" SS |
43 , cmd1 "EM" $ Many [LS] |
51 , cmd1 "EM" $ Many [LS] |
44 , cmd1 "PING" $ Many [SS] |
52 , cmd1 "PING" $ Many [SS] |
45 , cmd2 "CHAT" SS LS |
53 , cmd2 "CHAT" SS LS |
46 , cmd2 "SERVER_VARS" SS LS |
54 , cmd2 "SERVER_VARS" SS LS |
47 , cmd2 "BYE" SS LS |
55 , cmd2 "BYE" SS LS |
48 , cmd1 "INFO" $ Many [SS] |
56 , cmd1 "INFO" $ Many [SS] |
|
57 , cmd1 "ROOMS" $ Many [SS] |
49 , cmd "KICKED" [] |
58 , cmd "KICKED" [] |
|
59 , cmd "RUN_GAME" [] |
|
60 , cmd "ROUND_FINISHED" [] |
50 ] |
61 ] |
|
62 |
|
63 unknowncmd = PTPrefix "$" [PTCommand "$" $ Command "__UNKNOWN__" [Many [SS]]] |
51 |
64 |
52 groupByFirstChar :: [ParseTree] -> [(Char, [ParseTree])] |
65 groupByFirstChar :: [ParseTree] -> [(Char, [ParseTree])] |
53 groupByFirstChar = MM.assocs . MM.fromList . map breakCmd |
66 groupByFirstChar = MM.assocs . MM.fromList . map breakCmd |
54 |
67 |
55 makePT cmd@(Command n p) = PTCommand n cmd |
68 makePT cmd@(Command n p) = PTCommand n cmd |
56 |
69 |
57 buildParseTree cmds = [PTPrefix "!" $ bpt $ map makePT cmds] |
70 buildParseTree cmds = [PTPrefix "!" $ (bpt $ map makePT cmds) ++ [unknowncmd]] |
58 bpt cmds = if isJust emptyNamed then cmdLeaf $ fromJust emptyNamed else subtree |
71 bpt cmds = if isJust emptyNamed then cmdLeaf $ fromJust emptyNamed else subtree |
59 where |
72 where |
60 emptyNamed = find (\(_, (PTCommand n _:_)) -> null n) assocs |
73 emptyNamed = find (\(_, (PTCommand n _:_)) -> null n) assocs |
61 assocs = groupByFirstChar cmds |
74 assocs = groupByFirstChar cmds |
62 subtree = map buildsub assocs |
75 subtree = map buildsub assocs |
78 consumePrefix "" = id |
91 consumePrefix "" = id |
79 consumePrefix str = (text "consume" <> (parens . quotes $ text str) <> semi $$) |
92 consumePrefix str = (text "consume" <> (parens . quotes $ text str) <> semi $$) |
80 zeroChar = text "#0: state:= pstDisconnected;" |
93 zeroChar = text "#0: state:= pstDisconnected;" |
81 elsePart = text "else <unknown cmd> end;" |
94 elsePart = text "else <unknown cmd> end;" |
82 |
95 |
83 renderArrays (letters, commands, handlers) = l $+$ s $+$ c |
96 renderArrays (letters, commands, handlers) = vcat $ punctuate (char '\n') [cmds, l, s, bodies, c] |
84 where |
97 where |
85 maybeQuotes s = if null $ tail s then quotes $ text s else text s |
98 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 = " |
99 l = text "const letters: array[0.." <> (int $ length letters - 1) <> text "] of char = " |
87 <> parens (hsep . punctuate comma $ map maybeQuotes letters) <> semi |
100 <> parens (hsep . punctuate comma $ map maybeQuotes letters) <> semi |
88 s = text "const commands: array[0.." <> (int $ length commands - 1) <> text "] of integer = " |
101 s = text "const commands: array[0.." <> (int $ length commands - 1) <> text "] of integer = " |
89 <> parens (hsep . punctuate comma $ map text commands) <> semi |
102 <> parens (hsep . punctuate comma $ map text commands) <> semi |
90 c = text "const handlers: array[0.." <> (int $ length handlers - 1) <> text "] of integer = " |
103 c = text "const handlers: array[0.." <> (int $ length fixedNames - 1) <> text "] of PHandler = " |
91 <> parens (hsep . punctuate comma $ map (text . mangle . fixName) handlers) <> semi |
104 <> parens (hsep . punctuate comma $ map (text . (++) "@handler_") $ reverse fixedNames) <> semi |
92 mangle = (++) "handler_" |
105 fixedNames = map fixName handlers |
93 fixName = map fixChar |
106 fixName = map fixChar |
94 fixChar c | isLetter c = c |
107 fixChar c | isLetter c = c |
95 | otherwise = '_' |
108 | otherwise = '_' |
|
109 bodies = vcat $ punctuate (char '\n') $ map handlerBody fixedNames |
|
110 handlerBody n = text "procedure handler_" <> text n <> semi |
|
111 $+$ text "begin" |
|
112 $+$ nest 4 ( |
|
113 text "state.cmd:= cmd_" <> text n <> semi |
|
114 ) |
|
115 $+$ text "end" <> semi |
|
116 cmds = text "type TCmdType = " <> parens (hsep $ punctuate comma $ map ((<>) (text "cmd_") . text) fixedNames) <> semi |
96 |
117 |
97 pas = renderArrays $ buildTables $ buildParseTree commands |
118 pas = renderArrays $ buildTables $ buildParseTree commands |
98 where |
119 where |
99 buildTables cmds = let (_, _, _, t1, t2, t3) = foldr walk (0, [0], -10, [], [], [[]]) cmds in (tail t1, tail t2, concat t3) |
120 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)) = |
121 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) |
122 (lc, 2:sh, pc - 1, "#10":"#0":tbl1, "0":show pc:tbl2, (n:t3):tbl3) |
102 walk (PTPrefix prefix cmds) l = lvldown $ foldr fpf (foldr walk (lvlup l) cmds) prefix |
123 walk (PTPrefix prefix cmds) l = lvldown $ foldr fpf (foldr walk (lvlup l) cmds) prefix |
103 lvlup (lc, sh, pc, tbl1, tbl2, tbl3) = (lc, 0:sh, pc, tbl1, tbl2, []:tbl3) |
124 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) |
125 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) |
126 fpf c (lc, s:sh, pc, tbl1, tbl2, tbl3) = (lc + 1, s+1:sh, pc, [c]:tbl1, "0":tbl2, tbl3) |
106 |
127 |