FingerTree Implementation

FingerTree.hs

data FingerTree a = Empty
                  | Single a
                  | Deep (Digit a) (FingerTree (Node a)) (Digit a)
                    deriving Show

data Digit a = One a | Two a a | Three a a a | Four a a a a deriving Show
data Node a  = Node2 a a | Node3 a a a deriving Show

digitToList :: Digit a -> [a]
digitToList (One y1)           = [y1]
digitToList (Two y1 y2)        = [y1, y2]
digitToList (Three y1 y2 y3)   = [y1, y2, y3]
digitToList (Four y1 y2 y3 y4) = [y1, y2, y3, y4]

nodeToList :: Node a -> [a]
nodeToList (Node2 x1 x2)    = [x1, x2]
nodeToList (Node3 x1 x2 x3) = [x1, x2, x3]

class ToString a where
    toString :: a -> String

instance ToString Char where
    toString x = [x]

instance ToString a => ToString (Digit a) where
    toString (One y1)           = toString y1
    toString (Two y1 y2)        = toString y1 ++ toString y2
    toString (Three y1 y2 y3)   = toString y1 ++ toString y2 ++ toString y3
    toString (Four y1 y2 y3 y4) = toString y1 ++ toString y2 ++ toString y3 ++ toString y4

instance ToString a => ToString (Node a) where
    toString (Node2 x1 x2) = toString x1 ++ toString x2
    toString (Node3 x1 x2 x3) = toString x1 ++ toString x2 ++ toString x3

instance ToString a => ToString (FingerTree a) where
    toString (Empty) = []
    toString (Single x) = toString x
    toString (Deep left middle right) = toString left ++ toString middle ++ toString right


class DisplayTree a where
    displayTree :: Int -> a -> String

instance DisplayTree Char where
    displayTree depth x = replicate depth ' ' ++ [x]

instance DisplayTree Int where
    displayTree depth x = replicate depth ' ' ++ show x

instance DisplayTree a => DisplayTree (Digit a) where
    displayTree depth digit = unlines $ map (displayTree (depth + 1)) $ digitToList digit

instance DisplayTree a => DisplayTree (Node a) where
    displayTree depth node = unlines $ map (displayTree (depth + 1)) $ nodeToList node

instance DisplayTree a => DisplayTree (FingerTree a) where
    displayTree depth (Empty) =  replicate depth ' ' ++ "*"
    displayTree depth (Single x) = displayTree depth x
    displayTree depth (Deep left middle right) = unlines [ displayTree (depth + 1) left
                                                         , displayTree (depth + 1) middle
                                                         , displayTree (depth + 1) right
                                                         ]

spider :: FingerTree Char
spider = Deep (Two 't' 'h')
              (Deep (Two (Node2 'i' 's')
                         (Node2 'i' 's'))
                    Empty
                    (Two (Node3 'n' 'o' 't')
                         (Node2 'a' 't')))
              (Three 'r' 'e' 'e')

-- FingerTree != 2-3 Tree
-- FingerTree contains 2-3 Tree

pushBack :: FingerTree a -> a -> FingerTree a
pushBack (Empty) x = Single x
pushBack (Single x1) x2 = Deep (One x1) Empty (One x2)
pushBack (Deep left middle (One x1))           x2 = Deep left middle (Two x1 x2)
pushBack (Deep left middle (Two x1 x2))        x3 = Deep left middle (Three x1 x2 x3)
pushBack (Deep left middle (Three x1 x2 x3))   x4 = Deep left middle (Four x1 x2 x3 x4)
pushBack (Deep left middle (Four x1 x2 x3 x4)) x5 = Deep left (pushBack middle (Node3 x1 x2 x3)) (Two x4 x5)

pushFront :: FingerTree a -> a -> FingerTree a
pushFront (Empty) x = Single x
pushFront (Single x1) x2 = Deep (One x2) Empty (One x1)
pushFront (Deep (One x1)           middle right) x2 = Deep (Two x2 x1       ) middle right
pushFront (Deep (Two x1 x2)        middle right) x3 = Deep (Three x3 x1 x2  ) middle right
pushFront (Deep (Three x1 x2 x3)   middle right) x4 = Deep (Four x4 x1 x2 x3) middle right
pushFront (Deep (Four x1 x2 x3 x4) middle right) x5 = Deep (Two x5 x1) (pushFront middle (Node3 x2 x3 x4)) right

packNodes :: [a] -> [Node a]
packNodes [] = []
packNodes [x] = undefined
packNodes [x1, x2] = [Node2 x1 x2]
packNodes [x1, x2, x3] = [Node3 x1 x2 x3]
packNodes [x1, x2, x3, x4] = [Node2 x1 x2, Node2 x3 x4]
packNodes (x1:x2:x3:xs) = Node3 x1 x2 x3 : packNodes xs

distributeNodes :: [Node a] -> ([Node a], [Node a])
distributeNodes nodes = splitAt (length nodes `div` 2) nodes

concatFT :: FingerTree a -> FingerTree a -> FingerTree a
concatFT (Empty) ft = ft
concatFT ft (Empty) = ft
concatFT (Single x) ft = pushFront ft x
concatFT ft (Single x) = pushBack ft x
concatFT (Deep left1 middle1 right1) (Deep left2 middle2 right2) =
    Deep left1 (concatFT middle1' middle2') right2
    where (leftNodes, rightNodes) = distributeNodes $ packNodes (digitToList right1 ++ digitToList left2)
          middle1' = foldl pushBack middle1 leftNodes
          middle2' = foldr (flip pushFront) middle2 rightNodes

I saw your live stream yesterday and think that this is really great. Also, I am not a genius in Haskell but I think you have a typo on l. 97:
It should be packNodes [x1, x2, x3, x4] = [Node2 x1 x2, Node2 x3 x4] instead of [Node2 x1 x2, Node2 x1 x2] because you would lose data otherwise. (In this case it would make much more sense to use [x1, x2, _, _])

@herrhotzenplotz thank you! Fixed