128 breakCmd (PTCommand (c:cs) params) = (c, PTCommand cs params) |
128 breakCmd (PTCommand (c:cs) params) = (c, PTCommand cs params) |
129 |
129 |
130 makePT cmd@(Command n p) = PTCommand n cmd |
130 makePT cmd@(Command n p) = PTCommand n cmd |
131 |
131 |
132 buildParseTree cmds = [PTPrefix "!" $ (bpt $ map makePT cmds) ++ [unknowncmd]] |
132 buildParseTree cmds = [PTPrefix "!" $ (bpt $ map makePT cmds) ++ [unknowncmd]] |
133 bpt cmds = if not . null $ fst emptyNamed then cmdLeaf emptyNamed else subtree |
133 |
134 where |
134 bpt :: [ParseTree] -> [ParseTree] |
135 emptyNamed = partition (\(_, (PTCommand n _:_)) -> null n) assocs |
135 bpt cmds = cmdLeaf emptyNamed |
136 assocs = groupByFirstChar cmds |
136 where |
137 subtree = map buildsub assocs |
137 emptyNamed = partition (\(_, (PTCommand n _:_)) -> null n) $ groupByFirstChar cmds |
138 buildsub :: (Char, [ParseTree]) -> ParseTree |
138 buildsub :: (Char, [ParseTree]) -> [ParseTree] -> ParseTree |
139 buildsub (c, cmds) = let st = bpt cmds in if null $ drop 1 st then maybeMerge c st else PTPrefix [c] st |
139 buildsub (c, cmds) pc = let st = (bpt cmds) ++ pc in if null $ drop 1 st then maybeMerge c st else PTPrefix [c] st |
|
140 buildsub' = flip buildsub [] |
|
141 cmdLeaf ([], assocs) = map buildsub' assocs |
|
142 cmdLeaf ([(c, hwc:assocs1)], assocs2) |
|
143 | null assocs1 = PTPrefix [c] [hwc] : map buildsub' assocs2 |
|
144 | otherwise = (buildsub (c, assocs1) [hwc]) : map buildsub' assocs2 |
|
145 |
140 maybeMerge c cmd@[PTCommand {}] = PTPrefix [c] cmd |
146 maybeMerge c cmd@[PTCommand {}] = PTPrefix [c] cmd |
141 maybeMerge c cmd@[PTPrefix s ss] = PTPrefix (c:s) ss |
147 maybeMerge c cmd@[PTPrefix s ss] = PTPrefix (c:s) ss |
142 maybeMerge c [] = PTPrefix [c] [] |
148 maybeMerge c [] = PTPrefix [c] [] |
143 cmdLeaf ([(c, hwc:assocs1)], assocs2) |
149 |
144 | null assocs1 = PTPrefix [c] [hwc] : map buildsub assocs2 |
|
145 | otherwise = [buildsub (c, assocs1)] ++ [PTPrefix [] [hwc]] ++ map buildsub assocs2 |
|
146 |
|
147 dumpTree = vcat . map dt |
150 dumpTree = vcat . map dt |
148 where |
151 where |
149 dt (PTPrefix s st) = text s $$ (nest 1 $ vcat $ map dt st) |
152 dt (PTPrefix s st) = text s $$ (nest (length s) $ vcat $ map dt st) |
150 dt _ = empty |
153 dt _ = char '$' |
151 |
154 |
152 renderArrays (letters, commands, handlers) = vcat $ punctuate (char '\n') [l, s]--[grr, cmds, l, s, c, bodies, structs, realHandlers, realHandlersArray] |
155 renderArrays (letters, commands, handlers) = vcat $ punctuate (char '\n') [grr, cmds, l, s, c, bodies, structs, realHandlers, realHandlersArray] |
153 where |
156 where |
154 maybeQuotes "$" = text "#0" |
157 maybeQuotes "$" = text "#0" |
155 maybeQuotes "~" = text "#10" |
158 maybeQuotes "~" = text "#10" |
156 maybeQuotes s = if null $ tail s then quotes $ text s else text s |
159 maybeQuotes s = if null $ tail s then quotes $ text s else text s |
157 l = text "const letters: array[0.." <> (int $ length letters - 1) <> text "] of char = " |
160 l = text "const letters: array[0.." <> (int $ length letters - 1) <> text "] of char = " |
192 walk (PTPrefix prefix cmds) l = lvldown $ foldr fpf (foldr walk (lvlup l) cmds) prefix |
195 walk (PTPrefix prefix cmds) l = lvldown $ foldr fpf (foldr walk (lvlup l) cmds) prefix |
193 lvlup (lc, sh, pc, tbl1, tbl2, tbl3) = (lc, 0:sh, pc, tbl1, tbl2, []:tbl3) |
196 lvlup (lc, sh, pc, tbl1, tbl2, tbl3) = (lc, 0:sh, pc, tbl1, tbl2, []:tbl3) |
194 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) |
197 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) |
195 fpf c (lc, s:sh, pc, tbl1, tbl2, tbl3) = (lc + 1, s+1:sh, pc, [c]:tbl1, "0":tbl2, tbl3) |
198 fpf c (lc, s:sh, pc, tbl1, tbl2, tbl3) = (lc + 1, s+1:sh, pc, [c]:tbl1, "0":tbl2, tbl3) |
196 |
199 |
197 main = |
200 main = do |
198 putStrLn $ renderStyle style{lineLength = 80} $ pas |
201 putStrLn $ renderStyle style{mode = ZigZagMode, lineLength = 80} $ pas |
199 --putStrLn $ renderStyle style{lineLength = 80} $ dumpTree $ buildParseTree commandsDescription |
202 --putStrLn $ renderStyle style{lineLength = 80} $ dumpTree $ buildParseTree commandsDescription |