42 , cmd1 "EM" $ Many [LS] |
42 , cmd1 "EM" $ Many [LS] |
43 , cmd1 "PING" $ Many [SS] |
43 , cmd1 "PING" $ Many [SS] |
44 , cmd2 "CHAT" SS LS |
44 , cmd2 "CHAT" SS LS |
45 , cmd2 "SERVER_VARS" SS LS |
45 , cmd2 "SERVER_VARS" SS LS |
46 , cmd2 "BYE" SS LS |
46 , cmd2 "BYE" SS LS |
47 , cmd "INFO" [SS, SS, SS, SS] |
47 , cmd1 "INFO" $ Many [SS] |
48 , cmd "KICKED" [] |
48 , cmd "KICKED" [] |
49 ] |
49 ] |
50 |
50 |
51 groupByFirstChar :: [HWProtocol] -> [(Char, [HWProtocol])] |
51 groupByFirstChar :: [HWProtocol] -> [(Char, [HWProtocol])] |
52 groupByFirstChar = MM.assocs . MM.fromList . map breakCmd |
52 groupByFirstChar = MM.assocs . MM.fromList . map breakCmd |
64 dumpTree = vcat . map dt |
64 dumpTree = vcat . map dt |
65 where |
65 where |
66 dt (PTPrefix s st) = text s $$ (nest 1 $ vcat $ map dt st) |
66 dt (PTPrefix s st) = text s $$ (nest 1 $ vcat $ map dt st) |
67 dt _ = empty |
67 dt _ = empty |
68 |
68 |
69 pas = buildSwitch $ buildParseTree commands |
69 pas2 = buildSwitch $ buildParseTree commands |
70 where |
70 where |
71 buildSwitch cmds = text "case getNextChar of" $$ (nest 4 . vcat $ map buildCase cmds) $$ elsePart |
71 buildSwitch cmds = text "case getNextChar of" $$ (nest 4 . vcat $ map buildCase cmds) $$ elsePart |
72 buildCase (PTCommand _ ) = text "#10: <call cmd handler>;" |
72 buildCase (PTCommand _ ) = text "#10: <call cmd handler>;" |
73 buildCase (PTPrefix (s:ss) cmds) = quotes (char s) <> text ": " <> consumePrefix ss (buildSwitch cmds) |
73 buildCase (PTPrefix (s:ss) cmds) = quotes (char s) <> text ": " <> consumePrefix ss (buildSwitch cmds) |
74 consumePrefix "" = id |
74 consumePrefix "" = id |
75 consumePrefix str = (text "consume" <> (parens . quotes $ text str) <> semi $$) |
75 consumePrefix str = (text "consume" <> (parens . quotes $ text str) <> semi $$) |
76 zeroChar = text "#0: state:= pstDisconnected;" |
76 zeroChar = text "#0: state:= pstDisconnected;" |
77 elsePart = text "else <unknown cmd> end;" |
77 elsePart = text "else <unknown cmd> end;" |
78 |
78 |
|
79 pas = text $ show $ buildTables $ buildParseTree commands |
|
80 where |
|
81 buildTables cmds = let (_, _, t1, t2) = foldl walk (0, 0, [], []) cmds in (reverse t1, reverse t2) |
|
82 walk (lc, cc, tbl1, tbl2) (PTCommand _ ) = (lc, cc + 1, ("#10"):tbl1, (show $ -10 - cc):(tbl2)) |
|
83 walk lct (PTPrefix prefix cmds) = foldl walk (foldl fpf lct prefix) cmds |
|
84 fpf (lc, cc, tbl1, tbl2) c = (lc + 1, cc, [c]:tbl1, (show lc):tbl2) |
|
85 |
79 main = putStrLn $ render pas |
86 main = putStrLn $ render pas |