Creating New Types

The first part of this exercises asks us to find a way to print a binary tree containing strings. Since we don’t have a particular output format, let’s start with a naive printing function and refactor if we’re not happy with it:

showStringNaive :: BinaryTree String -> String
showStringNaive Leaf = ""
showStringNaive (Branch l a r) =
  leftStr <> "," <> a <> "," <> rightStr
  where
    leftStr = showStringNaive l
    rightStr = showStringNaive r

You’ll notice that the first thing we do is pattern match on the tree. Since a Leaf doesn’t have any value associated with it, we can just return an empty string. To create a string for a Branch, we needto include both the current value in the branch, as well as the stringified versions of the left and right subtrees.

Let’s load this up in ghci and test it out:

λ showStringNaive $ Leaf
""

λ showStringNaive $ Branch Leaf "a" Leaf
",a,"

λ showStringNaive $ Branch (Branch Leaf "a" Leaf) "b" (Branch Leaf "c" Leaf)
",a,,b,,c,"

Our elements are being printed out in order, which is what we want, but the extra commas are pretty ugly. Let’s see if we can fix that. The first thing we’ll do is to decouple traversing the tree from generating the output. Instead of doing it all in one pass, we’ll add a helper function called binaryTreeToList that will traverse the tree and return a list with all of the elements in the right order:

binaryTreeToList :: BinaryTree a -> [a]
binaryTreeToList Leaf = []
binaryTreeToList (Branch l a r) =
  binaryTreeToList l <> [a] <> binaryTreeToList r

You can see that the logic here is more or less identical to the logic we used for putting the tree together, but we’re not trying to actually merge the strings together. This has the additional benefit that we can ignore the details about what kind of tree we’re dealing with, so we could use this for trees with data other than just strings.

Next, we need to combine the list of strings into a single string with commas inbetween each element. There’s a function in from Data.List in Prelude that can do this for us. It’s called intercalate:

λ import Data.List (intercalate)

λ :t intercalate
intercalate :: [a] -> [[a]] -> [a]

λ intercalate "," ["a","b","c"]
"a,b,c"

λ intercalate "," ["a"]
"a"

λ intercalate "," ["a","b"]
"a,b"

We can use this function make our program work as we’d hoped:

showStringTree :: BinaryTree String -> String
showStringTree = intercalate "," . binaryTreeToList

Let’s run this and see how it works:

λ showStringTree $ Branch (Branch Leaf "a" Leaf) "b" (Branch Leaf "c" Leaf)
"a,b,c"

Much better! This version of our function works just as we’d have hoped. Unfortunately, we had to rely on a function that wasn’t covered in the chapter to get there. Let’s address that by writing our own version of intercalate:

intercalate :: [a] -> [[a]] -> [a]
intercalate a (x:y:ys) = x <> a <> intercalate a (y:ys)
intercalate _ (y:_) = y
intercalate _ [] = []

You’ll notice that this function uses pattern matching a bit differently than many other examples you’ve seen. Normally, when we’re pattern matching on a list, we’re only pulling out a single element:

(x:xs)

In intercalate we’re pattern matching on the first two elements of a list. We only want to add a new element between pairs of elements- never before or after a single element. Pattern matching on the first two elements allows us to easily ensure that our list has two elements. In the second pattern, we only have a single element list. In that case, we want to return it as is. Similarly, in the last pattern, we have an empty list and so we can only return an empty list. We can write this a bit more tersely by combining the last two patterns:

intercalate :: [a] -> [[a]] -> [a]
intercalate a (x:y:ys) = x <> a <> intercalate a (y:ys)
intercalate _ rest = concat rest

Let’s take one last look at all of this together:

showStringTree :: BinaryTree String -> String
showStringTree = intercalate "," . binaryTreeToList

intercalate :: [a] -> [[a]] -> [a]
intercalate a (x:y:ys) = x <> a <> intercalate a (y:ys)
intercalate _ rest = concat rest

binaryTreeToList :: BinaryTree a -> [a]
binaryTreeToList Leaf = []
binaryTreeToList (Branch l a r) = binaryTreeToList l <> [a] <> binaryTreeToList r

The next part of our exercises asks us to add an element to a tree of Ints. Just like the last part of this exercise, we have some flexibility here to determine for ourselves exactly how we want to handle inserting a value. Let’s go with a fairly simple approach. We won’t worry about keeping tree balanced. The first element that we insert will become the root of our tree. Any elements we insert that are numerically less than the root will go into the left side of the tree, and any elements greater tan the root will go into the right side of the tree. If an element already exists in the tree, we won’t insert it again. Let’s take a look at the code:

addElementToIntTree :: BinaryTree Int -> Int -> BinaryTree Int
addElementToIntTree tree n =
  case tree of
    Leaf -> Branch Leaf n Leaf
    Branch l a r
      | n > a -> Branch l a (addElementToIntTree r n)
      | n < a -> Branch (addElementToIntTree l n) a r
      | otherwise -> Branch l a r

You’ll see that the code in this example maps pretty closely to our description of the algorithm. We start by pattern matching on the tree. If it’s empty (Leaf) we create a new root node that contains our value, with empty left and right subtrees (Branch Leaf n Leaf). If we’ve got a branch, we compare it’s value with our current value. If the value we’re insert is bigger, we recursively insert our value into the right subtree. If it’s smaller, we recursively insert our value into the left subtree. Otherwise, the values must be the same and so we don’t need to do anything.

You’ll notice that we’re using a wildcard otherwise guard in this example instead of explicitly testing for equality. If we’d written the code with an explicit equality test, it would have functioned the same way, but you might get warnings about an incomplete pattern. Although we know that n must always be greater than, less than, or equal to a, the compiler doesn’t know that and assumes we might have missed a pattern.

Testing this solution isn’t entirely straightforward. In the last part of this exercise we built a program that would let us display trees full of strings, but now we’re working with trees full of numbers. Let’s write couple helper function to make it easier for us to view the results of inserting a new value:

showTree :: BinaryTree Int -> BinaryTree String
showTree Leaf = Leaf
showTree (Branch l a r) = Branch (showTree l) (show a) (showTree r)

This showTree function will let us convert a tree containing numbers into a BinaryTree String that we can use with the showStringTree function that we wrote earlier. Let’s test it out:

λ showStringTree . showTree $ Branch (Branch Leaf 1 Leaf) 2 (Branch Leaf 3 Leaf)
"1,2,3"

It looks like showStringTree is working with a small example list. Let’s try using addElementToIntTree to add some numbers to a larger tree, then see if we get the right output:

λ showStringTree . showTree $ addElementToIntTree (addElementToIntTree (addElementToIntTree Leaf 2) 3) 1
"1,2,3"

It works! It’s also a lot of typing! Let’s write another helpfer function- this time we’ll write one that lets us convert a list of numbers into a tree:

intTreeFromList :: [Int] -> BinaryTree Int
intTreeFromList = foldl addElementToIntTree Leaf

This function uses foldl to add all of the elements from a list into the tree, starting with an empty tree. As you can imagine, we could easily modify this function to insert elements into an existing tree as well. We’re using foldl here since our binary tree operations do not support infinite trees.

Let’s give this a shot to see if it works:

λ showStringTree . showTree $ intTreeFromList [3,2,1]
"1,2,3"

λ showStringTree . showTree $ intTreeFromList [3,2,1]
"1,2,3"

λ showStringTree . showTree $ intTreeFromList [3,2,1]
"1,2,3"

Our function works, and we can see that the order we insert elements doesn’t matter, since showStringTree will always print the elements in order. It is worth keeping in mind that, since we are not rebalancing our tree on insertion, adding elements that are already in order (or exactly in reverse) results in an extremely unbalanced tree. This isn’t a problem per-se, just a trade-off we made to keep the solution simple. As you get more experience with Haskell you can continue to work on this exercise and try to build a version of your insertion function that will rebalance itself.

The last question in this exercise asks us to write a function to find whether a particular value exists in a tree of numbers. This function ends up being very similar to our earlier insertion function:

doesIntExist :: BinaryTree Int -> Int -> Bool
doesIntExist Leaf _ = False
doesIntExist (Branch l a r) n
  | n > a = doesIntExist r n
  | n < a = doesIntExist l n
  | otherwise = True

This algorithm relies on the tree being “well-formed”. That is to say, the tree should follow the same structure that we used for addElementToIntTree. Smaller elements to the left, larger elements to the right. If the current element that we’re looking at is an empyt Leaf then we can be sure that the element doesn’t exist in the tree. If we’re looking at a Branch whose element matches what we’re looking for, then we’ve found it. Otherwise, we can look at the left or right subtree depending on whether the element we’re searching for is smaller or larger than the element at the root of the current tree.

Supporting safe division can be done with a relatively minor refactor of our existing eval code. Let’s start by copying our eval function and renaming it, then we can incrementally refactor it to support the behavior we want.

safeEval :: Expr -> Int
safeEval expr =
  case expr of
    Lit num -> num
    Add arg1 arg2 -> eval' (+) arg1 arg2
    Sub arg1 arg2 -> eval' (-) arg1 arg2
    Mul arg1 arg2 -> eval' (*) arg1 arg2
    Div arg1 arg2 -> eval' div arg1 arg2
    where
      eval' :: (Int -> Int -> Int) -> Expr -> Expr -> Int
      eval' operator arg1 arg2 =
        operator (safeEval arg1) (safeEval arg2)

We now have a safeEval function, but it’s not all that safe. Let’s let the types help us refactor this code into something that works the way we’d like. We’ll start by changing the type of safeEval to return Either String Int:

safeEval :: Expr -> Either String Int

If we compile the program with just this change you’ll see that we’re getting errors now. That makes sense, we’ve changed the stated type of the function, but we haven’t actually changed any of the values that we’re turning. Let’s see what happens if sprinkle a little optimism on our solution and update each of our case branches to return a Right value:

safeEval :: Expr -> Either String Int
safeEval expr =
  case expr of
    Lit num -> Right num
    Add arg1 arg2 -> Right $ eval' (+) arg1 arg2
    Sub arg1 arg2 -> Right $ eval' (-) arg1 arg2
    Mul arg1 arg2 -> Right $ eval' (*) arg1 arg2
    Div arg1 arg2 -> Right $ eval' div arg1 arg2
    where
      eval' :: (Int -> Int -> Int) -> Expr -> Expr -> Int
      eval' operator arg1 arg2 =
        operator (safeEval arg1) (safeEval arg2)

We’re getting closer, but we’ve still got a compile error. eval' is making a recursive call to safeEval for each of our two arguments, but it’s still expecting to get back Int instead of the Either String Int that we’re returning now. Let’s update this function so that we properly handle errors in the sub-expressions:

safeEval :: Expr -> Either String Int
safeEval expr =
  case expr of
    Lit num   -> Right num
    Add arg1 arg2 -> Right $ eval' (+) arg1 arg2
    Sub arg1 arg2 -> Right $ eval' (-) arg1 arg2
    Mul arg1 arg2 -> Right $ eval' (*) arg1 arg2
    Div arg1 arg2 -> Right $ eval' div arg1 arg2
    where
      eval' :: (Int -> Int -> Int) -> Expr -> Expr -> Either String Int
      eval' operator arg1 arg2 =
        case safeEval arg1 of
          Left err -> Left err
          Right a ->
            case safeEval arg2 of
              Left err -> Left err
              Right b -> Right $ operator a b

As you can see in ths example, we’ve had to updated eval' to return an Either String Int just like safeEval. Since we don’t have a sensible default value to use when we one of the expressions fails, the only option is to return the error. Unfortunately, now we’ve got a problem with our original set of changes. Let’s make another refactor to remove the Right constructor wrapping our calls to safeEval since we’re going to be returning an Either value directly now:

safeEval :: Expr -> Either String Int
safeEval expr =
  case expr of
    Lit num   -> Right num
    Add arg1 arg2 -> eval' (+) arg1 arg2
    Sub arg1 arg2 -> eval' (-) arg1 arg2
    Mul arg1 arg2 -> eval' (*) arg1 arg2
    Div arg1 arg2 -> eval' div arg1 arg2
    where
      eval' :: (Int -> Int -> Int) -> Expr -> Expr -> Either String Int
      eval' operator arg1 arg2 =
        case safeEval arg1 of
          Left err -> Left err
          Right a ->
            case safeEval arg2 of
              Left err -> Left err
              Right b -> Right $ operator a b

With this set of changes, we finally have a compiling version of our function. Unfortunately, it’s still not actually doing any error handling:

λ safeEval $ Lit 10 `Div` Lit 0
Right *** Exception: divide by zero

It looks like we’re not quite done refactoring afterall. In this version of our code, we’re passing an operator to eval', but the actual operator still can’t deal with failure. If we want to safely handle division by zero, we’ll need to update eval' so that the operator it accepts returns an Either String Int. We’ll also need to update all of the operators we pass in. In most cases, we’ll be able to always return a Right value, but for division we’ll need to check the denominator. Let’s take a look at the final version:

safeEval :: Expr -> Either String Int
safeEval expr =
  case expr of
    Lit num   -> Right num
    Add arg1 arg2 -> eval' (opHelper (+)) arg1 arg2
    Sub arg1 arg2 -> eval' (opHelper (-)) arg1 arg2
    Mul arg1 arg2 -> eval' (opHelper (*)) arg1 arg2
    Div arg1 arg2 -> eval' safeDiv arg1 arg2
    where
      safeDiv :: Int -> Int -> Either String Int
      safeDiv a b
        | b == 0 = Left "Error: division by zero"
        | otherwise = Right $ a `div` b

      opHelper ::
        (Int -> Int -> Int) ->
        Int ->
        Int ->
        Either String Int
      opHelper op a b = Right $ a `op` b

      eval' ::
        (Int -> Int -> Either String Int) ->
        Expr ->
        Expr ->
        Either String Int
      eval' operator arg1 arg2 =
        case safeEval arg1 of
          Left err -> Left err
          Right a ->
            case safeEval arg2 of
              Left err -> Left err
              Right b -> operator a b

In this final version, we’ve added two new functions. opHelper let’s us wrap the operations like multiplication and addition that won’t fail, and safeDiv which safely returns a Left value when the denominator is zero. Finally, we’re dropped the explicit Right constructor in eval' since operator will now return an Either value. Let’s take a look to see this in action:

λ safeEval $ (Lit 1 `Div` Lit 0) `Add` (Lit 1 `Mul` Lit 2)
Left "Error: division by zero"

λ safeEval $ (Lit 1 `Div` Lit 1) `Add` (Lit 1 `Mul` Lit 2)
Right 3

This exercise is tricky because it requires that we think carefully about how we carry information along when we traverse a data structure. We’re forced to think about how we can know when to add parentheses to an expression.

When faced with a tricky problem like this, it sometimes helps to defer solving the tricky part and, instead, to focus on solving the easier parts of the problem. In our case, we can start by avoiding dealing with parentheses and instead write a version of the program that doesn’t know about order of operations and prints the expression out naively. Let’s take a look at this naive pretty printer along side our eval function

eval :: Expr -> Int
eval expr =
  case expr of
    Lit num -> num
    Add arg1 arg2 -> eval' (+) arg1 arg2
    Sub arg1 arg2 -> eval' (-) arg1 arg2
    Mul arg1 arg2 -> eval' (*) arg1 arg2
    Div arg1 arg2 -> eval' div arg1 arg2
    where
      eval' :: (Int -> Int -> Int) -> Expr -> Expr -> Int
      eval' operator arg1 arg2 =
        operator (eval arg1) (eval arg2)

prettyPrintNoParens :: Expr -> String
prettyPrintNoParens expr =
  prettyPrint' expr <> " = " <> show result
  where
    result = eval expr
    prettyPrint' e =
      case e of
        Lit n -> show n
        Sub a b -> prettyOperation " - " a b
        Add a b -> prettyOperation " + " a b
        Mul a b -> prettyOperation " × " a b
        Div a b -> prettyOperation " ÷ " a b

    prettyOperation :: String -> Expr -> Expr -> String
    prettyOperation op a b =
      prettyPrint' a <> op <> prettyPrint' b

You’ll notice that there’s a lot of similarity in our two functions. Both have a case expression that’s matching the particular operation that we’re dealing with, and both pass in the relevant operator while calling out to a helper function that recursively deals with each sub-expression. The biggest changes are that we’ve moved the entire case expression into a helper function, and we’re dealing with strings and using the (<>) operator, instead of dealing with numbers and using function application.

Before we move on, let’s run this version of our pretty printer with our input so we can see it in action:

λ putStrLn $ prettyPrintNoParens $ Lit 5 `Add` Lit 10
5 + 10 = 15

λ putStrLn $ prettyPrintNoParens $ Lit 5 `Add` (Lit 10 `Div` Lit 2)
5 + 10 ÷ 2 = 10

λ putStrLn $ prettyPrintNoParens $ Lit 14 `Mul` (Lit 5 `Add` (Lit 10 `Div` Lit 2))
14 × 5 + 10 ÷ 2 = 140

Everything’s looking right so far. Let’s see if we can add parentheses. We can make a very small change to our program to add parentheses naively. Each time we print an operation using prettyOperation we can add parentheses to the output. This is a small change that gets us most of the way toward the answer:

prettyPrintSimple :: Expr -> String
prettyPrintSimple expr =
  prettyPrint' expr <> " = " <> show result
  where
    result = eval expr
    prettyPrint' e =
      case e of
        Lit n -> show n
        Sub a b -> prettyOperation " - " a b
        Add a b -> prettyOperation " + " a b
        Mul a b -> prettyOperation " × " a b
        Div a b -> prettyOperation " ÷ " a b

    prettyOperation op a b =
      "(" <> prettyPrint' a <> op <> prettyPrint' b <> ")"

Let’s run this version and see how it compares to our earlier version with no parentheses:

λ putStrLn $ prettyPrintSimple $ Lit 5 `Add` Lit 10
(5 + 10) = 15

λ putStrLn $ prettyPrintSimple $ Lit 5 `Add` (Lit 10 `Div` Lit 2)
(5 + (10 ÷ 2)) = 10

λ putStrLn $ prettyPrintSimple $ Lit 14 `Mul` (Lit 5 `Add` (Lit 10 `Div` Lit 2))
(14 × (5 + (10 ÷ 2))) = 140

This is pretty close to our goal, but we’re still generating an extra set of parentheses. We need to print the outermost part of the expression without the parentheses, then add them for more nested expressions. Naively, we can write two versions of prettyPrint' that have our different behaviors:

prettyPrintNoExtraParens :: Expr -> String
prettyPrintNoExtraParens expr =
  prettyPrint' expr <> " = " <> show result
  where
    result = eval expr
    prettyPrint' e =
      case e of
        Lit n -> show n
        Sub a b -> prettyOperation " - " a b
        Add a b -> prettyOperation " + " a b
        Mul a b -> prettyOperation " × " a b
        Div a b -> prettyOperation " ÷ " a b

    prettyWithParens e =
      case e of
        Lit n -> show n
        Sub a b -> "(" <> prettyOperation " - " a b <> ")"
        Add a b -> "(" <> prettyOperation " + " a b <> ")"
        Mul a b -> "(" <> prettyOperation " × " a b <> ")"
        Div a b -> "(" <> prettyOperation " ÷ " a b <> ")"

    prettyOperation op a b =
      prettyWithParens a <> op <>  prettyWithParens b

If we run through our examples, you’ll see that this works exactly as expected:

λ putStrLn $ prettyPrintNoExtraParens $ Lit 5 `Add` Lit 10
5 + 10 = 15

λ putStrLn $ prettyPrintNoExtraParens $ Lit 5 `Add` (Lit 10 `Div` Lit 2)
5 + (10 ÷ 2) = 10

λ putStrLn $ prettyPrintNoExtraParens $ Lit 14 `Mul` (Lit 5 `Add` (Lit 10 `Div` Lit 2))
14 × (5 + (10 ÷ 2)) = 140

Our code works! It’s a little bit unsatisfying though. If we want to add more operations, or change the way an operation is printed, we’d need to change it twice. That’s twice as much work even if everything goes right, and twice as many opportunities for a mistake. Let’s look at a refactored example and see how we can do better:

prettyPrint :: Expr -> String
prettyPrint expr =
  prettyPrint' expr <> " = " <> show result
  where
    result = eval expr
    prettyPrint' = prettyPrintWrapped id
    prettyWithParens = prettyPrintWrapped $ \pretty -> "(" <> pretty <> ")"
    prettyPrintWrapped wrapper e =
      case e of
        Lit n -> show n
        Sub a b -> wrapper $ prettyOperation " - " a b
        Add a b -> wrapper $ prettyOperation " + " a b
        Mul a b -> wrapper $ prettyOperation " × " a b
        Div a b -> wrapper $ prettyOperation " ÷ " a b
    prettyOperation op a b =
      prettyWithParens a <> op <>  prettyWithParens b

In this version of our code, we’ve factored out the decision about whether or not to add parentheses so that it’s separate from the code that displays each expression. In our initial call from prettyPrint' we pass in id, which leaves the rendered expression unmodified. Later, when we call the code from prettyWithParens we pass in a function that will wrap the expression in parentheses. Let’s give this a shot and see if it works:

λ putStrLn $ prettyPrint $ Lit 5 `Add` Lit 10
5 + 10 = 15

λ putStrLn $ prettyPrint $ Lit 5 `Add` (Lit 10 `Div` Lit 2)
5 + (10 ÷ 2) = 10

λ putStrLn $ prettyPrint $ Lit 14 `Mul` (Lit 5 `Add` (Lit 10 `Div` Lit 2))
14 × (5 + (10 ÷ 2)) = 140

Success! Like our earlier version, this function avoids adding an extra set of parentheses to the outside of our expresion. This time, it does it without the need to define the pretty printing function twice.