Put tree drawing logic in a separate module with a class type

Mainate.cabal

@@ -20,9 +20,11 @@ extra-source-files:  CHANGELOG.md
 library
   exposed-modules:   Graph
                    , Stream
+                   , Tree
   -- other-modules:
   -- other-extensions:
   build-depends:       base >=4.9 && <4.13
                      , containers
   hs-source-dirs:      src
+  ghc-options:         -Wall
   default-language:    Haskell2010

src/Stream.hs

@@ -1,21 +1,31 @@
 module Stream (
       Stream(..)
+    , append
+    , empty
     , fromList
     , infinite
     , merge
-    , showStream
   ) where
 
-import Data.List (intercalate)
+import Tree (Tree(..), Structure(..))
 
 data Stream a = Stream [(a, Stream a)] deriving Show
 
+instance Functor Stream where
+  fmap f (Stream pairs) =
+    Stream $ (\(a, stream) -> (f a, fmap f stream)) <$> pairs
+
+instance Tree Stream where
+  getStructure (Stream pairs) =
+    Node $ (\(s, stream) -> (s, getStructure stream)) <$> pairs
+
 empty :: Stream a
 empty = fromList []
 
 append :: Stream a -> Stream a -> Stream a
 append (Stream []) b = b
-append (Stream pairs) b = Stream $ (\(a, stream) -> (a, stream `append` b)) <$> pairs
+append (Stream pairs) b =
+  Stream $ (\(a, stream) -> (a, stream `append` b)) <$> pairs
 
 fromList :: [a] -> Stream a
 fromList [] = Stream []
@@ -35,27 +45,3 @@ merge (Stream aPairs) (Stream bPairs) = Stream $ foldl mergeOrAdd aPairs bPairs
       case openAt ((== b) . fst) [] accumulator of
         (up, []) -> (up, [(b, bStream)])
         (up, (x, xStream):down) -> (up, (x, merge xStream bStream):down)
-
-showStream :: Show a => Stream a -> String
-showStream = intercalate "\n" . getLines
-
-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
-    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 ' ') ++)

src/Tree.hs

@@ -0,0 +1,34 @@
+module Tree (
+      Tree(..)
+    , Structure(..)
+  ) where
+
+data Structure = Node [(String, Structure)]
+
+class Functor a => Tree a where
+  getStructure :: a String -> Structure
+
+  draw :: Show b => a b -> String
+  draw = unlines . getLines . getStructure . fmap show
+
+getLines :: Structure -> [String]
+getLines (Node []) = ["╼"]
+getLines (Node [(s, structure)]) = showBlock '─' (s, structure)
+getLines (Node ((s, structure):pairs)) = concat $
+  showBlock '┬' (s, structure) : showBlocks pairs
+
+showBlocks :: [(String, Structure)] -> [[String]]
+showBlocks [] = []
+showBlocks [(s, structure)] = [showBlock '╰' (s, structure)]
+showBlocks ((s, structure):pairs) =
+  showBlock '├' (s, structure) : showBlocks pairs
+
+showBlock :: Char -> (String, Structure) -> [String]
+showBlock connectingChar (s, structure) =
+  case getLines structure of
+    [] -> []
+    firstLine:otherLines -> (prefix ++ firstLine) : (pad <$> otherLines)
+  where
+    connect = ((if connectingChar `elem` "├┬" then '│' else ' '):)
+    prefix = connectingChar : " " ++ s ++ " "
+    pad = connect . (take (length prefix - 1) (repeat ' ') ++)