70 , cmd1 "SERVER_AUTH" SS |
70 , cmd1 "SERVER_AUTH" SS |
71 , cmd1 "JOINING" SS |
71 , cmd1 "JOINING" SS |
72 , cmd1 "TEAM_ACCEPTED" SS |
72 , cmd1 "TEAM_ACCEPTED" SS |
73 , cmd1 "HH_NUM" $ Many [SS] |
73 , cmd1 "HH_NUM" $ Many [SS] |
74 , cmd1 "TEAM_COLOR" $ Many [SS] |
74 , cmd1 "TEAM_COLOR" $ Many [SS] |
75 , cmd1 "TEAM_ACCEPTED" SS |
|
76 , cmd1 "BANLIST" $ Many [SS] |
75 , cmd1 "BANLIST" $ Many [SS] |
77 , cmd1 "JOINED" $ Many [SS] |
76 , cmd1 "JOINED" $ Many [SS] |
78 , cmd1 "LOBBY:JOINED" $ Many [SS] |
77 , cmd1 "LOBBY:JOINED" $ Many [SS] |
79 , cmd2 "LOBBY:LEFT" SS LS |
78 , cmd2 "LOBBY:LEFT" SS LS |
80 , cmd2 "CLIENT_FLAGS" SS $ Many [SS] |
79 , cmd2 "CLIENT_FLAGS" SS $ Many [SS] |
94 , cmd "RUN_GAME" [] |
93 , cmd "RUN_GAME" [] |
95 , cmd "ROUND_FINISHED" [] |
94 , cmd "ROUND_FINISHED" [] |
96 ] |
95 ] |
97 |
96 |
98 unknowncmd = PTPrefix "$" [PTCommand "$" $ Command "__UNKNOWN__" [Many [SS]]] |
97 unknowncmd = PTPrefix "$" [PTCommand "$" $ Command "__UNKNOWN__" [Many [SS]]] |
|
98 |
|
99 fixName = map fixChar |
|
100 fixChar c | isLetter c = c |
|
101 | otherwise = '_' |
99 |
102 |
100 groupByFirstChar :: [ParseTree] -> [(Char, [ParseTree])] |
103 groupByFirstChar :: [ParseTree] -> [(Char, [ParseTree])] |
101 groupByFirstChar = MM.assocs . MM.fromList . map breakCmd |
104 groupByFirstChar = MM.assocs . MM.fromList . map breakCmd |
102 where |
105 where |
103 breakCmd (PTCommand (c:cs) params) = (c, PTCommand cs params) |
106 breakCmd (PTCommand (c:cs) params) = (c, PTCommand cs params) |
141 c = text "const handlers: array[0.." <> (int $ length fixedNames - 1) <> text "] of PHandler = " |
144 c = text "const handlers: array[0.." <> (int $ length fixedNames - 1) <> text "] of PHandler = " |
142 <> parens (hsep . punctuate comma $ map (text . (:) '@') handlerTypes) <> semi |
145 <> parens (hsep . punctuate comma $ map (text . (:) '@') handlerTypes) <> semi |
143 handlerTypes = map cmdParams2handlerType sortedCmdDescriptions |
146 handlerTypes = map cmdParams2handlerType sortedCmdDescriptions |
144 sortedCmdDescriptions = reverse $ sort commandsDescription |
147 sortedCmdDescriptions = reverse $ sort commandsDescription |
145 fixedNames = map fixName handlers |
148 fixedNames = map fixName handlers |
146 fixName = map fixChar |
|
147 fixChar c | isLetter c = c |
|
148 | otherwise = '_' |
|
149 bodies = vcat $ punctuate (char '\n') $ map handlerBody fixedNames |
149 bodies = vcat $ punctuate (char '\n') $ map handlerBody fixedNames |
150 handlerBody n = text "procedure handler_" <> text n <> semi |
150 handlerBody n = text "procedure handler_" <> text n <> semi |
151 $+$ text "begin" |
151 $+$ text "begin" |
152 $+$ text "end" <> semi |
152 $+$ text "end" <> semi |
153 cmds = text "type TCmdType = " <> parens (hsep $ punctuate comma $ map ((<>) (text "cmd_") . text) $ reverse fixedNames) <> semi |
153 cmds = text "type TCmdType = " <> parens (hsep $ punctuate comma $ map ((<>) (text "cmd_") . text) $ reverse fixedNames) <> semi |
154 structs = vcat (map text . Set.toList . Set.fromList $ map cmdParams2record commandsDescription) |
154 structs = vcat (map text . Set.toList . Set.fromList $ map cmdParams2record commandsDescription) |
155 realHandlers = vcat $ punctuate (char '\n') $ map rh sortedCmdDescriptions |
155 realHandlers = vcat $ punctuate (char '\n') $ map rh sortedCmdDescriptions |
156 rh cmd@(Command n _) = text "procedure handler_" <> text (fixName n) <> parens (text "var p: " <> text (cmdParams2str cmd)) <> semi |
156 |
157 $+$ text "begin" |
157 rh cmd@(Command n p) = text "procedure handler_" <> text (fixName n) <> parens (text "var p: " <> text (cmdParams2str cmd)) <> semi |
158 $+$ text "end" <> semi |
158 $+$ emptyBody $+$ if hasMany then vcat [space, text "procedure handler_" <> text (fixName n) <> text "_s" <> parens (text "var s: shortstring") <> semi |
|
159 , emptyBody] else empty |
|
160 where |
|
161 hasMany = any isMany p |
|
162 isMany (Many _) = True |
|
163 isMany _ = False |
|
164 emptyBody = text "begin" $+$ text "end" <> semi |
159 |
165 |
160 pas = renderArrays $ buildTables $ buildParseTree commandsDescription |
166 pas = renderArrays $ buildTables $ buildParseTree commandsDescription |
161 where |
167 where |
162 buildTables cmds = let (_, _, _, t1, t2, t3) = foldr walk (0, [0], -10, [], [], [[]]) cmds in (tail t1, tail t2, concat t3) |
168 buildTables cmds = let (_, _, _, t1, t2, t3) = foldr walk (0, [0], -10, [], [], [[]]) cmds in (tail t1, tail t2, concat t3) |
163 walk (PTCommand _ (Command n params)) (lc, s:sh, pc, tbl1, tbl2, (t3:tbl3)) = |
169 walk (PTCommand _ (Command n params)) (lc, s:sh, pc, tbl1, tbl2, (t3:tbl3)) = |