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 |
53 |
53 |
54 buildParseTree cmds = if isJust emptyNamed then cmdLeaf $ fromJust emptyNamed else subtree |
54 buildParseTree cmds = [PTPrefix "!" $ bpt cmds] |
|
55 bpt cmds = if isJust emptyNamed then cmdLeaf $ fromJust emptyNamed else subtree |
55 where |
56 where |
56 emptyNamed = find (\(_, (Command n _:_)) -> null n) assocs |
57 emptyNamed = find (\(_, (Command n _:_)) -> null n) assocs |
57 assocs = groupByFirstChar cmds |
58 assocs = groupByFirstChar cmds |
58 subtree = map buildsub assocs |
59 subtree = map buildsub assocs |
59 buildsub (c, cmds) = let st = buildParseTree cmds in if null $ drop 1 st then maybeMerge c st else PTPrefix [c] st |
60 buildsub (c, cmds) = let st = bpt cmds in if null $ drop 1 st then maybeMerge c st else PTPrefix [c] st |
60 maybeMerge c cmd@[PTCommand _] = PTPrefix [c] cmd |
61 maybeMerge c cmd@[PTCommand _] = PTPrefix [c] cmd |
61 maybeMerge c cmd@[PTPrefix s ss] = PTPrefix (c:s) ss |
62 maybeMerge c cmd@[PTPrefix s ss] = PTPrefix (c:s) ss |
62 cmdLeaf (c, (hwc:_)) = [PTPrefix [c] [PTCommand hwc]] |
63 cmdLeaf (c, (hwc:_)) = [PTPrefix [c] [PTCommand hwc]] |
63 |
64 |
64 dumpTree = vcat . map dt |
65 dumpTree = vcat . map dt |
74 consumePrefix "" = id |
75 consumePrefix "" = id |
75 consumePrefix str = (text "consume" <> (parens . quotes $ text str) <> semi $$) |
76 consumePrefix str = (text "consume" <> (parens . quotes $ text str) <> semi $$) |
76 zeroChar = text "#0: state:= pstDisconnected;" |
77 zeroChar = text "#0: state:= pstDisconnected;" |
77 elsePart = text "else <unknown cmd> end;" |
78 elsePart = text "else <unknown cmd> end;" |
78 |
79 |
79 pas = text $ show $ buildTables $ buildParseTree commands |
80 renderArrays letters commands = l $+$ s |
80 where |
81 where |
81 buildTables cmds = let (_, _, t1, t2) = foldl walk (0, 0, [], []) cmds in (reverse t1, reverse t2) |
82 maybeQuotes s = if null $ tail s then quotes $ text s else text s |
82 walk (lc, cc, tbl1, tbl2) (PTCommand _ ) = (lc, cc + 1, ("#10"):tbl1, (show $ -10 - cc):(tbl2)) |
83 l = text "const letters: array[0.." <> (int $ length letters - 1) <> text "] of char = " |
83 walk lct (PTPrefix prefix cmds) = foldl walk (foldl fpf lct prefix) cmds |
84 <> parens (hsep . punctuate comma $ map maybeQuotes letters) <> semi |
84 fpf (lc, cc, tbl1, tbl2) c = (lc + 1, cc, [c]:tbl1, (show lc):tbl2) |
85 s = text "const commands: array[0.." <> (int $ length commands - 1) <> text "] of integer = " |
|
86 <> parens (hsep . punctuate comma $ map text commands) <> semi |
85 |
87 |
86 main = putStrLn $ render pas |
88 pas = uncurry renderArrays $ buildTables $ buildParseTree commands |
|
89 where |
|
90 buildTables cmds = let (_, _, _, t1, t2) = foldr walk (0, [0], -10, [], []) cmds in (tail t1, tail t2) |
|
91 walk (PTCommand _ ) (lc, s:sh, pc, tbl1, tbl2) = (lc, 2:sh, pc - 1, "#10":"0":tbl1, "0":(show pc):tbl2) |
|
92 walk (PTPrefix prefix cmds) l = lvldown $ foldr fpf (foldr walk (lvlup l) cmds) prefix |
|
93 lvlup (lc, sh, pc, tbl1, tbl2) = (lc, 0:sh, pc, tbl1, tbl2) |
|
94 lvldown (lc, s1:s2:sh, pc, tbl1, t:tbl2) = (lc, s1+s2:sh, pc, tbl1, show s1:tbl2) |
|
95 fpf c (lc, s:sh, pc, tbl1, tbl2) = (lc + 1, s+1:sh, pc, [c]:tbl1, "0":tbl2) |
|
96 |
|
97 main = putStrLn $ renderStyle style{lineLength = 80} pas |