Squashing multiplication identity in an expression

Question

I'm learning Haskell, and one exercise was to implement squashing of identity-multiplications, e.g.:

\$5 + (2*1) => 5 + 2\$

Here is my implementation:

squashMulId :: (Ring a, Eq a) => RingExpr a -> RingExpr a
squashMulId (Mul x y)
    | x == (Lit (mulId))    = squashMulId y
    | y == (Lit (mulId))    = squashMulId x
    | otherwise             = if sqX == x && sqY == y then (Mul sqX sqY) else squashMulId (Mul sqX sqY)
                              where sqX = squashMulId x
                                    sqY = squashMulId y
squashMulId (AddInv x)      = (AddInv (squashMulId x))
squashMulId (Add x y)       = (Add (squashMulId x) (squashMulId y))
squashMulId x               = x

squashMulIdInt :: RingExpr Integer -> RingExpr Integer
squashMulIdInt = squashMulId

tests_squash = test [
                      "right" ~: (Add (Lit 5) (Lit 2)) ~=? squashMulIdInt (Add (Lit 5) (Mul (Lit 2) (Lit 1)) )
                     ,"left" ~: (Add (Lit 5) (Lit 2)) ~=? squashMulIdInt (Add (Lit 5) (Mul (Lit 1) (Lit 2)) )
                     ,"recursive" ~: (Add (Lit 5) (Lit 2)) ~=? squashMulIdInt (Add (Lit 5) (Mul (Lit 1) (Mul (Lit 2) (Mul (Lit 1) (Lit 1)))))
                    ]

How can I improve on this implementation? Is it idiomatic? Can it be written in a more succinct way?

The following code/definitions were given:

{-# OPTIONS_GHC -Wall #-}
module SQMULID where

import Data.Char
import Data.List
import Data.Maybe
import Test.HUnit
import Test.QuickCheck
import Test.QuickCheck.Gen


class Ring a where
  addId  :: a            -- additive identity
  addInv :: a -> a       -- additive inverse
  mulId  :: a            -- multiplicative identity

  add :: a -> a -> a     -- addition
  mul :: a -> a -> a     -- multiplication

-- | A datatype for storing and manipulating ring expressions.
data RingExpr a = Lit a
                | AddId
                | AddInv (RingExpr a)
                | MulId
                | Add (RingExpr a) (RingExpr a)
                | Mul (RingExpr a) (RingExpr a)
  deriving (Show, Eq)

instance Ring (RingExpr a) where
  addId  = AddId
  addInv = AddInv
  mulId  = MulId

  add = Add
  mul = Mul

-- The canonical instance for integers:
instance Ring Integer where
  addId  = 0
  addInv = negate
  mulId  = 1

  add = (+)
  mul = (*)

Answer 1

You are doing both too much work and not enough.

• You are doing too much work because you don't need to repeatedly squash units in case the first pass has returned a modified expression.

• You are not doing enough work because you are not squashing the units coming from MulId rather than Lit mulId

Here is a solution which one could argue is more idiomatic as well as dealing with the two shortcomings I pointed out earlier:

We start by implementing the recursion pattern first; it is a quite common thing to do in Haskell as it helps make it easier to understand from first sight how a function works (what does this function do? Oh! It goes by recursion on the structure! Let's see what the different cases are...).

To do that, you define a function fold taking one argument per constructor of the datatype and having a given return type (here b). The arguments are functions taking the same arguments as the constructors they correspond to except that the recursive occurences of RingExpr a have been replaced by the return type b (i.e. we assume we already know the result for the recursive subcomputations!)

fold :: (a -> b)      -> -- Lit    :: a -> RingExpr a
        b             -> -- AddId  :: RingExpr a
        (b -> b)      -> -- AddInv :: RingExpr a -> RingExpr a
        b             -> -- MulId  :: RingExpr a
        (b -> b -> b) -> -- Add    :: RingExpr a -> RingExpr a -> RingExpr a
        (b -> b -> b) -> -- Mul    :: RingExpr a -> RingExpr a -> RingExpr a
        RingExpr a -> b
fold litb addIdb addInvb mulIdb addb mulb = go
  where go (Lit a)    = litb a
        go AddId      = addIdb
        go (AddInv e) = addInvb $ go e
        go MulId      = mulIdb
        go (Add e f)  = go e `addb` go f
        go (Mul e f)  = go e `mulb` go f

The function you are looking to define is now a simple instance of the recursion pattern we just described: for the cases which are not Mul, we simply use the corresponding constructor but in the case of Mul we do the squashing:

squashMulId :: (Ring a, Eq a) => RingExpr a -> RingExpr a
squashMulId = fold Lit AddId AddInv MulId Add squashing
  where
    squashing a b
      | a == Lit mulId || a == MulId = b
      | b == Lit mulId || b == MulId = a
      | otherwise                    = Mul a b