118 bpt cmds = if not . null $ fst emptyNamed then cmdLeaf emptyNamed else subtree |
118 bpt cmds = if not . null $ fst emptyNamed then cmdLeaf emptyNamed else subtree |
119 where |
119 where |
120 emptyNamed = partition (\(_, (PTCommand n _:_)) -> null n) assocs |
120 emptyNamed = partition (\(_, (PTCommand n _:_)) -> null n) assocs |
121 assocs = groupByFirstChar cmds |
121 assocs = groupByFirstChar cmds |
122 subtree = map buildsub assocs |
122 subtree = map buildsub assocs |
|
123 buildsub :: (Char, [ParseTree]) -> ParseTree |
123 buildsub (c, cmds) = let st = bpt cmds in if null $ drop 1 st then maybeMerge c st else PTPrefix [c] st |
124 buildsub (c, cmds) = let st = bpt cmds in if null $ drop 1 st then maybeMerge c st else PTPrefix [c] st |
124 maybeMerge c cmd@[PTCommand {}] = PTPrefix [c] cmd |
125 maybeMerge c cmd@[PTCommand {}] = PTPrefix [c] cmd |
125 maybeMerge c cmd@[PTPrefix s ss] = PTPrefix (c:s) ss |
126 maybeMerge c cmd@[PTPrefix s ss] = PTPrefix (c:s) ss |
126 cmdLeaf ([(c, (hwc:assocs1))], assocs2) = (PTPrefix [c] [hwc]) : (bpt assocs1 ++ map buildsub assocs2) |
127 maybeMerge c [] = PTPrefix [c] [] |
|
128 cmdLeaf ([(c, hwc:assocs1)], assocs2) |
|
129 | null assocs1 = PTPrefix [c] [hwc] : map buildsub assocs2 |
|
130 | otherwise = [buildsub (c, assocs1)] ++ [PTPrefix [] [hwc]] ++ map buildsub assocs2 |
127 |
131 |
128 dumpTree = vcat . map dt |
132 dumpTree = vcat . map dt |
129 where |
133 where |
130 dt (PTPrefix s st) = text s $$ (nest 1 $ vcat $ map dt st) |
134 dt (PTPrefix s st) = text s $$ (nest 1 $ vcat $ map dt st) |
131 dt _ = empty |
135 dt _ = empty |