Reimplement showTree, rename it to showStream and expose useful functions from module

src/Stream.hs

@@ -1,5 +1,9 @@
 module Stream (
-    Stream(..)
+      Stream(..)
+    , fromList
+    , infinite
+    , merge
+    , showStream
   ) where
 
 import Data.List (intercalate)
@@ -30,21 +34,26 @@ merge (Stream aPairs) (Stream bPairs) = Stream $ foldl mergeOrAdd aPairs bPairs
         (up, []) -> (up, [(b, bStream)])
         (up, (x, xStream):down) -> (up, (x, merge xStream bStream):down)
 
-showTree :: Show a => Stream a -> String
-showTree = intercalate "\n" . getLines
-  where
-    getLines (Stream []) = ["●"]
-    getLines (Stream pairs) =
-      concat $ (\(a, stream) -> showElem a $ getLines stream) <$> pairs
+showStream :: Show a => Stream a -> String
+showStream = intercalate "\n" . getLines
 
-showElem :: Show a => a -> [String] -> [String]
-showElem _ [] = []
-showElem a [l] = ["— " ++ show a ++ " —" ++ l]
-showElem a (l:ls) =
-  let prefix = "─ " ++ show a ++ " ─┬" in
-  let padding = take (length prefix - 1) $ repeat ' ' in
-  (prefix ++ l) : (pad padding ls)
+getLines :: Show a => Stream a -> [String]
+getLines (Stream []) = ["╼"]
+getLines (Stream [(a, stream)]) = showBlock '─' (a, stream)
+getLines (Stream ((a, stream):pairs)) = concat $
+  showBlock '┬' (a, stream) : showBlocks pairs
   where
-    pad _ [] = []
-    pad padding [x] = [padding ++ '╰' : x]
-    pad padding (x:xs) = (padding ++ '├' : x) : (pad padding xs)
+    showBlocks [] = []
+    showBlocks [(a, stream)] = [showBlock '╰' (a, stream)]
+    showBlocks ((a, stream):pairs) =
+      showBlock '├' (a, stream) : showBlocks pairs
+
+showBlock :: Show a => Char -> (a, Stream a) -> [String]
+showBlock connectingChar (a, stream) =
+  case getLines stream of
+    [] -> []
+    firstLine:otherLines -> (prefix ++ firstLine) : (pad <$> otherLines)
+  where
+    connect = ((if connectingChar `elem` "├┬" then '│' else ' '):)
+    prefix = connectingChar : " " ++ show a ++ " "
+    pad = connect . (take (length prefix - 1) (repeat ' ') ++)