author | unc0rr |
Fri, 20 Nov 2015 23:56:13 +0300 | |
branch | qmlfrontend |
changeset 11423 | 091149424aa4 |
parent 11422 | 4815e406a760 |
child 11424 | 8a5cc31483c6 |
permissions | -rw-r--r-- |
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 |
11047 | 8 |
import qualified Data.Set as Set |
10898 | 9 |
|
10 |
data HWProtocol = Command String [CmdParam] |
|
11422 | 11 |
deriving Show |
11048 | 12 |
|
13 |
instance Ord HWProtocol where |
|
14 |
(Command a _) `compare` (Command b _) = a `compare` b |
|
15 |
instance Eq HWProtocol where |
|
16 |
(Command a _) == (Command b _) = a == b |
|
17 |
||
10898 | 18 |
data CmdParam = Skip |
19 |
| SS |
|
20 |
| LS |
|
21 |
| IntP |
|
22 |
| Many [CmdParam] |
|
11422 | 23 |
deriving Show |
10898 | 24 |
|
10906 | 25 |
data ParseTree = PTPrefix String [ParseTree] |
10927 | 26 |
| PTCommand String HWProtocol |
11422 | 27 |
deriving Show |
10902 | 28 |
|
10898 | 29 |
cmd = Command |
30 |
cmd1 s p = Command s [p] |
|
31 |
cmd2 s p1 p2 = Command s [p1, p2] |
|
32 |
||
11076 | 33 |
cmdName (Command n _) = n |
34 |
||
11047 | 35 |
cmdParams2str (Command _ p) = "TCmdParam" ++ concatMap f p |
36 |
where |
|
37 |
f Skip = "" |
|
38 |
f SS = "S" |
|
39 |
f LS = "L" |
|
40 |
f IntP = "i" |
|
41 |
f (Many p) = "" |
|
11048 | 42 |
|
43 |
cmdParams2handlerType (Command _ p) = "handler_" ++ concatMap f p |
|
44 |
where |
|
45 |
f Skip = "_" |
|
46 |
f SS = "S" |
|
47 |
f LS = "L" |
|
48 |
f IntP = "i" |
|
49 |
f (Many p) = 'M' : concatMap f p |
|
11050 | 50 |
|
11047 | 51 |
cmdParams2record cmd@(Command _ p) = renderStyle style{lineLength = 80} $ |
52 |
text "type " <> text (cmdParams2str cmd) |
|
53 |
<> text " = record" $+$ nest 4 ( |
|
54 |
vcat (map (uncurry f) $ zip [1..] $ filter isRendered p) |
|
55 |
$+$ text "end;") |
|
56 |
where |
|
57 |
isRendered Skip = False |
|
58 |
isRendered (Many _) = False |
|
59 |
isRendered _ = True |
|
60 |
f n Skip = empty |
|
61 |
f n SS = text "str" <> int n <> text ": shortstring;" |
|
62 |
f n LS = text "str" <> int n <> text ": longstring;" |
|
63 |
f n IntP = text "param" <> int n <> text ": LongInt;" |
|
64 |
f _ (Many _) = empty |
|
65 |
||
66 |
commandsDescription = [ |
|
10898 | 67 |
cmd "CONNECTED" [Skip, IntP] |
68 |
, cmd1 "NICK" SS |
|
69 |
, cmd1 "PROTO" IntP |
|
70 |
, cmd1 "ASKPASSWORD" SS |
|
71 |
, cmd1 "SERVER_AUTH" SS |
|
10904 | 72 |
, cmd1 "JOINING" SS |
10929 | 73 |
, cmd1 "TEAM_ACCEPTED" SS |
74 |
, cmd1 "HH_NUM" $ Many [SS] |
|
75 |
, cmd1 "TEAM_COLOR" $ Many [SS] |
|
10904 | 76 |
, cmd1 "BANLIST" $ Many [SS] |
77 |
, cmd1 "JOINED" $ Many [SS] |
|
10898 | 78 |
, cmd1 "LOBBY:JOINED" $ Many [SS] |
10904 | 79 |
, cmd2 "LOBBY:LEFT" SS LS |
80 |
, cmd2 "CLIENT_FLAGS" SS $ Many [SS] |
|
81 |
, cmd2 "LEFT" SS $ Many [SS] |
|
10902 | 82 |
, cmd1 "SERVER_MESSAGE" LS |
11050 | 83 |
, cmd1 "ERROR" LS |
10929 | 84 |
, cmd1 "NOTICE" LS |
85 |
, cmd1 "WARNING" LS |
|
10904 | 86 |
, cmd1 "EM" $ Many [LS] |
87 |
, cmd1 "PING" $ Many [SS] |
|
88 |
, cmd2 "CHAT" SS LS |
|
89 |
, cmd2 "SERVER_VARS" SS LS |
|
90 |
, cmd2 "BYE" SS LS |
|
10908 | 91 |
, cmd1 "INFO" $ Many [SS] |
11422 | 92 |
, cmd1 "ROOM" $ Many [SS] |
10929 | 93 |
, cmd1 "ROOMS" $ Many [SS] |
10904 | 94 |
, cmd "KICKED" [] |
10929 | 95 |
, cmd "RUN_GAME" [] |
96 |
, cmd "ROUND_FINISHED" [] |
|
10898 | 97 |
] |
98 |
||
11418
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
99 |
hasMany = any isMany |
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
100 |
isMany (Many _) = True |
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
101 |
isMany _ = False |
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
102 |
|
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
103 |
unknown = Command "__UNKNOWN__" [Many [SS]] |
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
104 |
unknowncmd = PTPrefix "$" [PTCommand "$" $ unknown] |
10929 | 105 |
|
11075 | 106 |
fixName = map fixChar |
107 |
fixChar c | isLetter c = c |
|
108 |
| otherwise = '_' |
|
109 |
||
10927 | 110 |
groupByFirstChar :: [ParseTree] -> [(Char, [ParseTree])] |
10904 | 111 |
groupByFirstChar = MM.assocs . MM.fromList . map breakCmd |
11050 | 112 |
where |
113 |
breakCmd (PTCommand (c:cs) params) = (c, PTCommand cs params) |
|
10902 | 114 |
|
10927 | 115 |
makePT cmd@(Command n p) = PTCommand n cmd |
116 |
||
10929 | 117 |
buildParseTree cmds = [PTPrefix "!" $ (bpt $ map makePT cmds) ++ [unknowncmd]] |
11050 | 118 |
bpt cmds = if not . null $ fst emptyNamed then cmdLeaf emptyNamed else subtree |
10904 | 119 |
where |
11050 | 120 |
emptyNamed = partition (\(_, (PTCommand n _:_)) -> null n) assocs |
10904 | 121 |
assocs = groupByFirstChar cmds |
10906 | 122 |
subtree = map buildsub assocs |
10925 | 123 |
buildsub (c, cmds) = let st = bpt cmds in if null $ drop 1 st then maybeMerge c st else PTPrefix [c] st |
10927 | 124 |
maybeMerge c cmd@[PTCommand {}] = PTPrefix [c] cmd |
10906 | 125 |
maybeMerge c cmd@[PTPrefix s ss] = PTPrefix (c:s) ss |
11422 | 126 |
cmdLeaf ([(c, (hwc:assocs1))], assocs2) = (PTPrefix [c] [hwc]) : (bpt assocs1 ++ map buildsub assocs2) |
10906 | 127 |
|
128 |
dumpTree = vcat . map dt |
|
129 |
where |
|
130 |
dt (PTPrefix s st) = text s $$ (nest 1 $ vcat $ map dt st) |
|
131 |
dt _ = empty |
|
10904 | 132 |
|
11418
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
133 |
renderArrays (letters, commands, handlers) = vcat $ punctuate (char '\n') [grr, cmds, l, s, c, bodies, structs, realHandlers, realHandlersArray] |
10908 | 134 |
where |
11048 | 135 |
maybeQuotes "$" = text "#0" |
10925 | 136 |
maybeQuotes s = if null $ tail s then quotes $ text s else text s |
137 |
l = text "const letters: array[0.." <> (int $ length letters - 1) <> text "] of char = " |
|
138 |
<> parens (hsep . punctuate comma $ map maybeQuotes letters) <> semi |
|
139 |
s = text "const commands: array[0.." <> (int $ length commands - 1) <> text "] of integer = " |
|
140 |
<> parens (hsep . punctuate comma $ map text commands) <> semi |
|
10929 | 141 |
c = text "const handlers: array[0.." <> (int $ length fixedNames - 1) <> text "] of PHandler = " |
11048 | 142 |
<> parens (hsep . punctuate comma $ map (text . (:) '@') handlerTypes) <> semi |
11418
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
143 |
grr = text "const net2cmd: array[0.." <> (int $ length fixedNames - 1) <> text "] of TCmdType = " |
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
144 |
<> parens (hsep . punctuate comma $ map (text . (++) "cmd_") $ reverse fixedNames) <> semi |
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
145 |
handlerTypes = map cmdParams2handlerType $ reverse sortedCmdDescriptions |
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
146 |
sortedCmdDescriptions = sort commandsDescription |
10929 | 147 |
fixedNames = map fixName handlers |
11418
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
148 |
bodies = vcat $ punctuate (char '\n') $ map handlerBody $ nub $ sort handlerTypes |
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
149 |
handlerBody n = text "procedure " <> text n <> semi |
10929 | 150 |
$+$ text "begin" |
151 |
$+$ text "end" <> semi |
|
11418
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
152 |
cmds = text "type TCmdType = " <> parens (hsep $ punctuate comma $ concatMap (rhentry "cmd_") $ sortedCmdDescriptions) <> semi |
11047 | 153 |
structs = vcat (map text . Set.toList . Set.fromList $ map cmdParams2record commandsDescription) |
11418
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
154 |
realHandlers = vcat $ punctuate (char '\n') $ map rh $ sortedCmdDescriptions |
11076 | 155 |
realHandlersArray = text "const handlers: array[TCmdType] of PHandler = " |
11418
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
156 |
<> parens (hsep . punctuate comma . concatMap (rhentry "@handler_") $ sortedCmdDescriptions) <> semi |
11075 | 157 |
|
158 |
rh cmd@(Command n p) = text "procedure handler_" <> text (fixName n) <> parens (text "var p: " <> text (cmdParams2str cmd)) <> semi |
|
11418
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
159 |
$+$ emptyBody $+$ if hasMany p then vcat [space, text "procedure handler_" <> text (fixName n) <> text "_s" <> parens (text "var s: TCmdParamS") <> semi |
11075 | 160 |
, emptyBody] else empty |
161 |
where |
|
162 |
emptyBody = text "begin" $+$ text "end" <> semi |
|
10908 | 163 |
|
11418
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
164 |
rhentry prefix cmd@(Command n p) = map ((<>) (text "PHandler") . parens) $ (text . (++) prefix . fixName . cmdName $ cmd) |
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
165 |
: if hasMany p then [text . flip (++) "_s" . (++) prefix . fixName . cmdName $ cmd] else [] |
ffff8a0d1a76
Implement processing net commands in the main thread
unc0rr
parents:
11076
diff
changeset
|
166 |
|
11047 | 167 |
pas = renderArrays $ buildTables $ buildParseTree commandsDescription |
10925 | 168 |
where |
10927 | 169 |
buildTables cmds = let (_, _, _, t1, t2, t3) = foldr walk (0, [0], -10, [], [], [[]]) cmds in (tail t1, tail t2, concat t3) |
170 |
walk (PTCommand _ (Command n params)) (lc, s:sh, pc, tbl1, tbl2, (t3:tbl3)) = |
|
10931 | 171 |
(lc, 1:sh, pc - 1, "#10":tbl1, show pc:tbl2, (n:t3):tbl3) |
10925 | 172 |
walk (PTPrefix prefix cmds) l = lvldown $ foldr fpf (foldr walk (lvlup l) cmds) prefix |
10927 | 173 |
lvlup (lc, sh, pc, tbl1, tbl2, tbl3) = (lc, 0:sh, pc, tbl1, tbl2, []:tbl3) |
174 |
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) |
|
175 |
fpf c (lc, s:sh, pc, tbl1, tbl2, tbl3) = (lc + 1, s+1:sh, pc, [c]:tbl1, "0":tbl2, tbl3) |
|
10925 | 176 |
|
11050 | 177 |
main = |
178 |
putStrLn $ renderStyle style{lineLength = 80} $ pas |
|
179 |
--putStrLn $ renderStyle style{lineLength = 80} $ dumpTree $ buildParseTree commandsDescription |