From 5d1907094da3bf5d42a687091f6d6a90aba2e7c6 Mon Sep 17 00:00:00 2001
From: Tissevert <tissevert+devel@marvid.fr>
Date: Mon, 6 May 2019 08:17:49 +0200
Subject: [PATCH] Put tree drawing logic in a separate module with a class type

---
 Mainate.cabal |  2 ++
 src/Stream.hs | 40 +++++++++++++---------------------------
 src/Tree.hs   | 34 ++++++++++++++++++++++++++++++++++
 3 files changed, 49 insertions(+), 27 deletions(-)
 create mode 100644 src/Tree.hs

diff --git a/Mainate.cabal b/Mainate.cabal
index e42a709..5550508 100644
--- a/Mainate.cabal
+++ b/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
diff --git a/src/Stream.hs b/src/Stream.hs
index 1de142d..608f124 100644
--- a/src/Stream.hs
+++ b/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 ' ') ++)
diff --git a/src/Tree.hs b/src/Tree.hs
new file mode 100644
index 0000000..43c3d05
--- /dev/null
+++ b/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 ' ') ++)