46 f Skip = "_" |
44 f Skip = "_" |
47 f SS = "S" |
45 f SS = "S" |
48 f LS = "L" |
46 f LS = "L" |
49 f IntP = "i" |
47 f IntP = "i" |
50 f (Many p) = 'M' : concatMap f p |
48 f (Many p) = 'M' : concatMap f p |
51 |
49 |
52 cmdParams2record cmd@(Command _ p) = renderStyle style{lineLength = 80} $ |
50 cmdParams2record cmd@(Command _ p) = renderStyle style{lineLength = 80} $ |
53 text "type " <> text (cmdParams2str cmd) |
51 text "type " <> text (cmdParams2str cmd) |
54 <> text " = record" $+$ nest 4 ( |
52 <> text " = record" $+$ nest 4 ( |
55 vcat (map (uncurry f) $ zip [1..] $ filter isRendered p) |
53 vcat (map (uncurry f) $ zip [1..] $ filter isRendered p) |
56 $+$ text "end;") |
54 $+$ text "end;") |
80 , cmd1 "LOBBY:JOINED" $ Many [SS] |
78 , cmd1 "LOBBY:JOINED" $ Many [SS] |
81 , cmd2 "LOBBY:LEFT" SS LS |
79 , cmd2 "LOBBY:LEFT" SS LS |
82 , cmd2 "CLIENT_FLAGS" SS $ Many [SS] |
80 , cmd2 "CLIENT_FLAGS" SS $ Many [SS] |
83 , cmd2 "LEFT" SS $ Many [SS] |
81 , cmd2 "LEFT" SS $ Many [SS] |
84 , cmd1 "SERVER_MESSAGE" LS |
82 , cmd1 "SERVER_MESSAGE" LS |
85 , cmd1 "ERROR" LS -- not rendered? wth |
83 , cmd1 "ERROR" LS |
86 , cmd1 "NOTICE" LS |
84 , cmd1 "NOTICE" LS |
87 , cmd1 "WARNING" LS |
85 , cmd1 "WARNING" LS |
88 , cmd1 "JOINING" SS |
|
89 , cmd1 "EM" $ Many [LS] |
86 , cmd1 "EM" $ Many [LS] |
90 , cmd1 "PING" $ Many [SS] |
87 , cmd1 "PING" $ Many [SS] |
91 , cmd2 "CHAT" SS LS |
88 , cmd2 "CHAT" SS LS |
92 , cmd2 "SERVER_VARS" SS LS |
89 , cmd2 "SERVER_VARS" SS LS |
93 , cmd2 "BYE" SS LS |
90 , cmd2 "BYE" SS LS |
100 |
97 |
101 unknowncmd = PTPrefix "$" [PTCommand "$" $ Command "__UNKNOWN__" [Many [SS]]] |
98 unknowncmd = PTPrefix "$" [PTCommand "$" $ Command "__UNKNOWN__" [Many [SS]]] |
102 |
99 |
103 groupByFirstChar :: [ParseTree] -> [(Char, [ParseTree])] |
100 groupByFirstChar :: [ParseTree] -> [(Char, [ParseTree])] |
104 groupByFirstChar = MM.assocs . MM.fromList . map breakCmd |
101 groupByFirstChar = MM.assocs . MM.fromList . map breakCmd |
|
102 where |
|
103 breakCmd (PTCommand (c:cs) params) = (c, PTCommand cs params) |
105 |
104 |
106 makePT cmd@(Command n p) = PTCommand n cmd |
105 makePT cmd@(Command n p) = PTCommand n cmd |
107 |
106 |
108 buildParseTree cmds = [PTPrefix "!" $ (bpt $ map makePT cmds) ++ [unknowncmd]] |
107 buildParseTree cmds = [PTPrefix "!" $ (bpt $ map makePT cmds) ++ [unknowncmd]] |
109 bpt cmds = if isJust emptyNamed then cmdLeaf $ fromJust emptyNamed else subtree |
108 bpt cmds = if not . null $ fst emptyNamed then cmdLeaf emptyNamed else subtree |
110 where |
109 where |
111 emptyNamed = find (\(_, (PTCommand n _:_)) -> null n) assocs |
110 emptyNamed = partition (\(_, (PTCommand n _:_)) -> null n) assocs |
112 assocs = groupByFirstChar cmds |
111 assocs = groupByFirstChar cmds |
113 subtree = map buildsub assocs |
112 subtree = map buildsub assocs |
114 buildsub (c, cmds) = let st = bpt cmds in if null $ drop 1 st then maybeMerge c st else PTPrefix [c] st |
113 buildsub (c, cmds) = let st = bpt cmds in if null $ drop 1 st then maybeMerge c st else PTPrefix [c] st |
115 maybeMerge c cmd@[PTCommand {}] = PTPrefix [c] cmd |
114 maybeMerge c cmd@[PTCommand {}] = PTPrefix [c] cmd |
116 maybeMerge c cmd@[PTPrefix s ss] = PTPrefix (c:s) ss |
115 maybeMerge c cmd@[PTPrefix s ss] = PTPrefix (c:s) ss |
117 cmdLeaf (c, (hwc:_)) = [PTPrefix [c] [hwc]] |
116 cmdLeaf ([(c, (hwc:_))], assocs2) = (PTPrefix [c] [hwc]) : map buildsub assocs2 |
118 |
117 |
119 dumpTree = vcat . map dt |
118 dumpTree = vcat . map dt |
120 where |
119 where |
121 dt (PTPrefix s st) = text s $$ (nest 1 $ vcat $ map dt st) |
120 dt (PTPrefix s st) = text s $$ (nest 1 $ vcat $ map dt st) |
122 dt _ = empty |
121 dt _ = empty |
161 walk (PTPrefix prefix cmds) l = lvldown $ foldr fpf (foldr walk (lvlup l) cmds) prefix |
160 walk (PTPrefix prefix cmds) l = lvldown $ foldr fpf (foldr walk (lvlup l) cmds) prefix |
162 lvlup (lc, sh, pc, tbl1, tbl2, tbl3) = (lc, 0:sh, pc, tbl1, tbl2, []:tbl3) |
161 lvlup (lc, sh, pc, tbl1, tbl2, tbl3) = (lc, 0:sh, pc, tbl1, tbl2, []:tbl3) |
163 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) |
162 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) |
164 fpf c (lc, s:sh, pc, tbl1, tbl2, tbl3) = (lc + 1, s+1:sh, pc, [c]:tbl1, "0":tbl2, tbl3) |
163 fpf c (lc, s:sh, pc, tbl1, tbl2, tbl3) = (lc + 1, s+1:sh, pc, [c]:tbl1, "0":tbl2, tbl3) |
165 |
164 |
166 main = putStrLn $ renderStyle style{lineLength = 80} pas |
165 main = |
|
166 putStrLn $ renderStyle style{lineLength = 80} $ pas |
|
167 --putStrLn $ renderStyle style{lineLength = 80} $ dumpTree $ buildParseTree commandsDescription |