133 consumePrefix "" = id |
138 consumePrefix "" = id |
134 consumePrefix str = (text "consume" <> (parens . quotes $ text str) <> semi $$) |
139 consumePrefix str = (text "consume" <> (parens . quotes $ text str) <> semi $$) |
135 zeroChar = text "#0: state:= pstDisconnected;" |
140 zeroChar = text "#0: state:= pstDisconnected;" |
136 elsePart = text "else <unknown cmd> end;" |
141 elsePart = text "else <unknown cmd> end;" |
137 |
142 |
138 renderArrays (letters, commands, handlers) = vcat $ punctuate (char '\n') [cmds, l, s, {-bodies, -}c, structs, realHandlers, realHandlersArray] |
143 renderArrays (letters, commands, handlers) = vcat $ punctuate (char '\n') [grr, cmds, l, s, c, bodies, structs, realHandlers, realHandlersArray] |
139 where |
144 where |
140 maybeQuotes "$" = text "#0" |
145 maybeQuotes "$" = text "#0" |
141 maybeQuotes s = if null $ tail s then quotes $ text s else text s |
146 maybeQuotes s = if null $ tail s then quotes $ text s else text s |
142 l = text "const letters: array[0.." <> (int $ length letters - 1) <> text "] of char = " |
147 l = text "const letters: array[0.." <> (int $ length letters - 1) <> text "] of char = " |
143 <> parens (hsep . punctuate comma $ map maybeQuotes letters) <> semi |
148 <> parens (hsep . punctuate comma $ map maybeQuotes letters) <> semi |
144 s = text "const commands: array[0.." <> (int $ length commands - 1) <> text "] of integer = " |
149 s = text "const commands: array[0.." <> (int $ length commands - 1) <> text "] of integer = " |
145 <> parens (hsep . punctuate comma $ map text commands) <> semi |
150 <> parens (hsep . punctuate comma $ map text commands) <> semi |
146 c = text "const handlers: array[0.." <> (int $ length fixedNames - 1) <> text "] of PHandler = " |
151 c = text "const handlers: array[0.." <> (int $ length fixedNames - 1) <> text "] of PHandler = " |
147 <> parens (hsep . punctuate comma $ map (text . (:) '@') handlerTypes) <> semi |
152 <> parens (hsep . punctuate comma $ map (text . (:) '@') handlerTypes) <> semi |
148 handlerTypes = map cmdParams2handlerType sortedCmdDescriptions |
153 grr = text "const net2cmd: array[0.." <> (int $ length fixedNames - 1) <> text "] of TCmdType = " |
149 sortedCmdDescriptions = reverse $ sort commandsDescription |
154 <> parens (hsep . punctuate comma $ map (text . (++) "cmd_") $ reverse fixedNames) <> semi |
|
155 handlerTypes = map cmdParams2handlerType $ reverse sortedCmdDescriptions |
|
156 sortedCmdDescriptions = sort commandsDescription |
150 fixedNames = map fixName handlers |
157 fixedNames = map fixName handlers |
151 bodies = vcat $ punctuate (char '\n') $ map handlerBody fixedNames |
158 bodies = vcat $ punctuate (char '\n') $ map handlerBody $ nub $ sort handlerTypes |
152 handlerBody n = text "procedure handler_" <> text n <> semi |
159 handlerBody n = text "procedure " <> text n <> semi |
153 $+$ text "begin" |
160 $+$ text "begin" |
154 $+$ text "end" <> semi |
161 $+$ text "end" <> semi |
155 cmds = text "type TCmdType = " <> parens (hsep $ punctuate comma $ map ((<>) (text "cmd_") . text) $ reverse fixedNames) <> semi |
162 cmds = text "type TCmdType = " <> parens (hsep $ punctuate comma $ concatMap (rhentry "cmd_") $ sortedCmdDescriptions) <> semi |
156 structs = vcat (map text . Set.toList . Set.fromList $ map cmdParams2record commandsDescription) |
163 structs = vcat (map text . Set.toList . Set.fromList $ map cmdParams2record commandsDescription) |
157 realHandlers = vcat $ punctuate (char '\n') $ map rh sortedCmdDescriptions |
164 realHandlers = vcat $ punctuate (char '\n') $ map rh $ sortedCmdDescriptions |
158 realHandlersArray = text "const handlers: array[TCmdType] of PHandler = " |
165 realHandlersArray = text "const handlers: array[TCmdType] of PHandler = " |
159 <> parens (hsep . punctuate comma . (:) (text "@handler__UNKNOWN_") $ map (text . (++) "@handler_" . fixName . cmdName) sortedCmdDescriptions) <> semi |
166 <> parens (hsep . punctuate comma . concatMap (rhentry "@handler_") $ sortedCmdDescriptions) <> semi |
160 |
167 |
161 rh cmd@(Command n p) = text "procedure handler_" <> text (fixName n) <> parens (text "var p: " <> text (cmdParams2str cmd)) <> semi |
168 rh cmd@(Command n p) = text "procedure handler_" <> text (fixName n) <> parens (text "var p: " <> text (cmdParams2str cmd)) <> semi |
162 $+$ emptyBody $+$ if hasMany then vcat [space, text "procedure handler_" <> text (fixName n) <> text "_s" <> parens (text "var s: shortstring") <> semi |
169 $+$ emptyBody $+$ if hasMany p then vcat [space, text "procedure handler_" <> text (fixName n) <> text "_s" <> parens (text "var s: TCmdParamS") <> semi |
163 , emptyBody] else empty |
170 , emptyBody] else empty |
164 where |
171 where |
165 hasMany = any isMany p |
|
166 isMany (Many _) = True |
|
167 isMany _ = False |
|
168 emptyBody = text "begin" $+$ text "end" <> semi |
172 emptyBody = text "begin" $+$ text "end" <> semi |
|
173 |
|
174 rhentry prefix cmd@(Command n p) = map ((<>) (text "PHandler") . parens) $ (text . (++) prefix . fixName . cmdName $ cmd) |
|
175 : if hasMany p then [text . flip (++) "_s" . (++) prefix . fixName . cmdName $ cmd] else [] |
169 |
176 |
170 pas = renderArrays $ buildTables $ buildParseTree commandsDescription |
177 pas = renderArrays $ buildTables $ buildParseTree commandsDescription |
171 where |
178 where |
172 buildTables cmds = let (_, _, _, t1, t2, t3) = foldr walk (0, [0], -10, [], [], [[]]) cmds in (tail t1, tail t2, concat t3) |
179 buildTables cmds = let (_, _, _, t1, t2, t3) = foldr walk (0, [0], -10, [], [], [[]]) cmds in (tail t1, tail t2, concat t3) |
173 walk (PTCommand _ (Command n params)) (lc, s:sh, pc, tbl1, tbl2, (t3:tbl3)) = |
180 walk (PTCommand _ (Command n params)) (lc, s:sh, pc, tbl1, tbl2, (t3:tbl3)) = |