diff -r 360e57620df3 -r 46482475af2b tools/protocolParser.hs --- a/tools/protocolParser.hs Tue Jul 21 23:46:52 2015 +0300 +++ b/tools/protocolParser.hs Wed Aug 12 17:30:14 2015 +0300 @@ -5,6 +5,7 @@ import Data.Maybe import Data.List import Data.Char +import qualified Data.Set as Set data HWProtocol = Command String [CmdParam] data CmdParam = Skip @@ -26,7 +27,30 @@ breakCmd (PTCommand (c:cs) params) = (c, PTCommand cs params) -commands = [ +cmdParams2str (Command _ p) = "TCmdParam" ++ concatMap f p + where + f Skip = "" + f SS = "S" + f LS = "L" + f IntP = "i" + f (Many p) = "" + +cmdParams2record cmd@(Command _ p) = renderStyle style{lineLength = 80} $ + text "type " <> text (cmdParams2str cmd) + <> text " = record" $+$ nest 4 ( + vcat (map (uncurry f) $ zip [1..] $ filter isRendered p) + $+$ text "end;") + where + isRendered Skip = False + isRendered (Many _) = False + isRendered _ = True + f n Skip = empty + f n SS = text "str" <> int n <> text ": shortstring;" + f n LS = text "str" <> int n <> text ": longstring;" + f n IntP = text "param" <> int n <> text ": LongInt;" + f _ (Many _) = empty + +commandsDescription = [ cmd "CONNECTED" [Skip, IntP] , cmd1 "NICK" SS , cmd1 "PROTO" IntP @@ -83,7 +107,7 @@ dt (PTPrefix s st) = text s $$ (nest 1 $ vcat $ map dt st) dt _ = empty -pas2 = buildSwitch $ buildParseTree commands +pas2 = buildSwitch $ buildParseTree commandsDescription where buildSwitch cmds = text "case getNextChar of" $$ (nest 4 . vcat $ map buildCase cmds) $$ elsePart buildCase (PTCommand {}) = text "#10: ;" @@ -93,7 +117,7 @@ zeroChar = text "#0: state:= pstDisconnected;" elsePart = text "else end;" -renderArrays (letters, commands, handlers) = vcat $ punctuate (char '\n') [cmds, l, s, bodies, c] +renderArrays (letters, commands, handlers) = vcat $ punctuate (char '\n') [cmds, l, s, bodies, c, structs] where maybeQuotes s = if null $ tail s then quotes $ text s else text s l = text "const letters: array[0.." <> (int $ length letters - 1) <> text "] of char = " @@ -111,8 +135,9 @@ $+$ text "begin" $+$ text "end" <> semi cmds = text "type TCmdType = " <> parens (hsep $ punctuate comma $ map ((<>) (text "cmd_") . text) $ reverse fixedNames) <> semi + structs = vcat (map text . Set.toList . Set.fromList $ map cmdParams2record commandsDescription) -pas = renderArrays $ buildTables $ buildParseTree commands +pas = renderArrays $ buildTables $ buildParseTree commandsDescription where buildTables cmds = let (_, _, _, t1, t2, t3) = foldr walk (0, [0], -10, [], [], [[]]) cmds in (tail t1, tail t2, concat t3) walk (PTCommand _ (Command n params)) (lc, s:sh, pc, tbl1, tbl2, (t3:tbl3)) =