24 cmd1 s p = Command s [p] |
25 cmd1 s p = Command s [p] |
25 cmd2 s p1 p2 = Command s [p1, p2] |
26 cmd2 s p1 p2 = Command s [p1, p2] |
26 |
27 |
27 breakCmd (PTCommand (c:cs) params) = (c, PTCommand cs params) |
28 breakCmd (PTCommand (c:cs) params) = (c, PTCommand cs params) |
28 |
29 |
29 commands = [ |
30 cmdParams2str (Command _ p) = "TCmdParam" ++ concatMap f p |
|
31 where |
|
32 f Skip = "" |
|
33 f SS = "S" |
|
34 f LS = "L" |
|
35 f IntP = "i" |
|
36 f (Many p) = "" |
|
37 |
|
38 cmdParams2record cmd@(Command _ p) = renderStyle style{lineLength = 80} $ |
|
39 text "type " <> text (cmdParams2str cmd) |
|
40 <> text " = record" $+$ nest 4 ( |
|
41 vcat (map (uncurry f) $ zip [1..] $ filter isRendered p) |
|
42 $+$ text "end;") |
|
43 where |
|
44 isRendered Skip = False |
|
45 isRendered (Many _) = False |
|
46 isRendered _ = True |
|
47 f n Skip = empty |
|
48 f n SS = text "str" <> int n <> text ": shortstring;" |
|
49 f n LS = text "str" <> int n <> text ": longstring;" |
|
50 f n IntP = text "param" <> int n <> text ": LongInt;" |
|
51 f _ (Many _) = empty |
|
52 |
|
53 commandsDescription = [ |
30 cmd "CONNECTED" [Skip, IntP] |
54 cmd "CONNECTED" [Skip, IntP] |
31 , cmd1 "NICK" SS |
55 , cmd1 "NICK" SS |
32 , cmd1 "PROTO" IntP |
56 , cmd1 "PROTO" IntP |
33 , cmd1 "ASKPASSWORD" SS |
57 , cmd1 "ASKPASSWORD" SS |
34 , cmd1 "SERVER_AUTH" SS |
58 , cmd1 "SERVER_AUTH" SS |
81 dumpTree = vcat . map dt |
105 dumpTree = vcat . map dt |
82 where |
106 where |
83 dt (PTPrefix s st) = text s $$ (nest 1 $ vcat $ map dt st) |
107 dt (PTPrefix s st) = text s $$ (nest 1 $ vcat $ map dt st) |
84 dt _ = empty |
108 dt _ = empty |
85 |
109 |
86 pas2 = buildSwitch $ buildParseTree commands |
110 pas2 = buildSwitch $ buildParseTree commandsDescription |
87 where |
111 where |
88 buildSwitch cmds = text "case getNextChar of" $$ (nest 4 . vcat $ map buildCase cmds) $$ elsePart |
112 buildSwitch cmds = text "case getNextChar of" $$ (nest 4 . vcat $ map buildCase cmds) $$ elsePart |
89 buildCase (PTCommand {}) = text "#10: <call cmd handler>;" |
113 buildCase (PTCommand {}) = text "#10: <call cmd handler>;" |
90 buildCase (PTPrefix (s:ss) cmds) = quotes (char s) <> text ": " <> consumePrefix ss (buildSwitch cmds) |
114 buildCase (PTPrefix (s:ss) cmds) = quotes (char s) <> text ": " <> consumePrefix ss (buildSwitch cmds) |
91 consumePrefix "" = id |
115 consumePrefix "" = id |
92 consumePrefix str = (text "consume" <> (parens . quotes $ text str) <> semi $$) |
116 consumePrefix str = (text "consume" <> (parens . quotes $ text str) <> semi $$) |
93 zeroChar = text "#0: state:= pstDisconnected;" |
117 zeroChar = text "#0: state:= pstDisconnected;" |
94 elsePart = text "else <unknown cmd> end;" |
118 elsePart = text "else <unknown cmd> end;" |
95 |
119 |
96 renderArrays (letters, commands, handlers) = vcat $ punctuate (char '\n') [cmds, l, s, bodies, c] |
120 renderArrays (letters, commands, handlers) = vcat $ punctuate (char '\n') [cmds, l, s, bodies, c, structs] |
97 where |
121 where |
98 maybeQuotes s = if null $ tail s then quotes $ text s else text s |
122 maybeQuotes s = if null $ tail s then quotes $ text s else text s |
99 l = text "const letters: array[0.." <> (int $ length letters - 1) <> text "] of char = " |
123 l = text "const letters: array[0.." <> (int $ length letters - 1) <> text "] of char = " |
100 <> parens (hsep . punctuate comma $ map maybeQuotes letters) <> semi |
124 <> parens (hsep . punctuate comma $ map maybeQuotes letters) <> semi |
101 s = text "const commands: array[0.." <> (int $ length commands - 1) <> text "] of integer = " |
125 s = text "const commands: array[0.." <> (int $ length commands - 1) <> text "] of integer = " |
109 bodies = vcat $ punctuate (char '\n') $ map handlerBody fixedNames |
133 bodies = vcat $ punctuate (char '\n') $ map handlerBody fixedNames |
110 handlerBody n = text "procedure handler_" <> text n <> semi |
134 handlerBody n = text "procedure handler_" <> text n <> semi |
111 $+$ text "begin" |
135 $+$ text "begin" |
112 $+$ text "end" <> semi |
136 $+$ text "end" <> semi |
113 cmds = text "type TCmdType = " <> parens (hsep $ punctuate comma $ map ((<>) (text "cmd_") . text) $ reverse fixedNames) <> semi |
137 cmds = text "type TCmdType = " <> parens (hsep $ punctuate comma $ map ((<>) (text "cmd_") . text) $ reverse fixedNames) <> semi |
|
138 structs = vcat (map text . Set.toList . Set.fromList $ map cmdParams2record commandsDescription) |
114 |
139 |
115 pas = renderArrays $ buildTables $ buildParseTree commands |
140 pas = renderArrays $ buildTables $ buildParseTree commandsDescription |
116 where |
141 where |
117 buildTables cmds = let (_, _, _, t1, t2, t3) = foldr walk (0, [0], -10, [], [], [[]]) cmds in (tail t1, tail t2, concat t3) |
142 buildTables cmds = let (_, _, _, t1, t2, t3) = foldr walk (0, [0], -10, [], [], [[]]) cmds in (tail t1, tail t2, concat t3) |
118 walk (PTCommand _ (Command n params)) (lc, s:sh, pc, tbl1, tbl2, (t3:tbl3)) = |
143 walk (PTCommand _ (Command n params)) (lc, s:sh, pc, tbl1, tbl2, (t3:tbl3)) = |
119 (lc, 1:sh, pc - 1, "#10":tbl1, show pc:tbl2, (n:t3):tbl3) |
144 (lc, 1:sh, pc - 1, "#10":tbl1, show pc:tbl2, (n:t3):tbl3) |
120 walk (PTPrefix prefix cmds) l = lvldown $ foldr fpf (foldr walk (lvlup l) cmds) prefix |
145 walk (PTPrefix prefix cmds) l = lvldown $ foldr fpf (foldr walk (lvlup l) cmds) prefix |