# HG changeset patch
# User unc0rr
# Date 1430340738 -10800
# Node ID 13fde38281fcdbe14181336f7f67fddb94997e36
# Parent  ce265b038220240c760df1ca45649e414df49026
Rendering some code

diff -r ce265b038220 -r 13fde38281fc tools/protocolParser.hs
--- a/tools/protocolParser.hs	Tue Apr 28 23:26:12 2015 +0300
+++ b/tools/protocolParser.hs	Wed Apr 29 23:52:18 2015 +0300
@@ -16,7 +16,7 @@
                   | ServerAuth
                   | Lobby
 
-data ParseTree = PTChar Char [ParseTree]
+data ParseTree = PTPrefix String [ParseTree]
                | PTCommand HWProtocol
 
 cmd = Command
@@ -55,12 +55,25 @@
     where
         emptyNamed = find (\(_, (Command n _:_)) -> null n) assocs
         assocs = groupByFirstChar cmds
-        subtree = map (\(c, cmds) -> PTChar c $ buildParseTree cmds) assocs
-        cmdLeaf (c, (hwc:_)) = [PTChar c [PTCommand hwc]]
+        subtree = map buildsub assocs
+        buildsub (c, cmds) = let st = buildParseTree cmds in if null $ drop 1 st then maybeMerge c st else PTPrefix [c] st
+        maybeMerge c cmd@[PTCommand _] = PTPrefix [c] cmd
+        maybeMerge c cmd@[PTPrefix s ss] = PTPrefix (c:s) ss
+        cmdLeaf (c, (hwc:_)) = [PTPrefix [c] [PTCommand hwc]]
+
+dumpTree = vcat . map dt
+    where
+    dt (PTPrefix s st) = text s $$ (nest 1 $ vcat $ map dt st)
+    dt _ = empty
 
-dumpTree (PTChar c st) = char c $$ (nest 2 $ vcat $ map dumpTree st)
-dumpTree _ = empty
+pas = buildSwitch $ buildParseTree commands
+    where
+        buildSwitch cmds = text "case getNextChar of" $$ (nest 4 . vcat $ map buildCase cmds) $$ elsePart
+        buildCase (PTCommand _ ) = text "#10: <call cmd handler>;"
+        buildCase (PTPrefix (s:ss) cmds) = quotes (char s) <> text ": " <> consumePrefix ss (buildSwitch cmds)
+        consumePrefix "" = id
+        consumePrefix str = (text "consume" <> (parens . quotes $ text str) <> semi $$)
+        zeroChar = text "#0: state:= pstDisconnected;"
+        elsePart = text "else <unknown cmd> end;"
 
-pas = vcat . map dumpTree $ buildParseTree commands
-    
 main = putStrLn $ render pas