[Haskell-cafe] Is there already an abstraction for this?

[Jeremy Shaw]

Hello,

I am trying to figure out if there is an existing abstraction I am
missing here.

I have an expression data-type:

> data Expr 
>    = Quotient Expr Expr
>    | Product Expr Expr
>    | Sum Expr Expr
>    | Difference Expr Expr
>    | Lit Double
>    | Var Char
>      deriving (Eq, Ord, Data, Typeable, Read, Show)
>

And I want to write a function that will take an expression and
automatically apply the identity laws to simplify the expression.

The basic identity laws are:

 a + 0 = a
 a * 1 = a

I can implement these with some 'sugar' as:

> identity (Sum (Lit 0) a)        = a
> identity (Sum a (Lit 0))        = a
> identity (Difference a (Lit 0)) = a
> identity (Product a (Lit 1))    = a
> identity (Product (Lit 1) a)    = a
> identity (Quotient a (Lit 1))   = a
> identity a                      = a

This works fine when the identity only needs to be applied to the root
of the expression tree:

*Main> ppExpr $ identity (expr "1 + 0")
1

But for more complicated trees it does not fully apply the identity laws:

*Main> ppExpr $ identity (expr "0 + (0 + 0) + (0 + 0)")
((0 + 0) + (0 + 0))

What we need to do is first apply the identity function to the
children, and then apply them to the parent of the updated children. A
first attempt would be to extend the identity function like this:

> identity (Sum a b)              = identity (Sum (identity a) (identity b))

However, that will not terminate because that same case will keep
matching over and over. Another approach is to have two mutually
recursive functions like:

> identity' (Sum (Lit 0) a)        = identityRec a
> identity' (Sum a (Lit 0))        = identityRec a
> identity' a = a

> identityRec (Sum a b) = identity' (Sum (identity' a) (identity' b))

This prevents non-termination, but you have to be careful about
calling identity' vs identityRec or you will either re-introduce
non-termination, or you may not fully apply the identity laws.

Another option to create a helper function like:

> -- |Deep map of an expression.
> eMap :: (Expr -> Expr) -> Expr -> Expr
> eMap f (Sum a b) = f (Sum (eMap f a) (eMap f b))
> eMap f (Difference a b) = f (Difference (eMap f a) (eMap f b))
> eMap f (Product a b) = f (Product (eMap f a) (eMap f b))
> eMap f (Quotient a b) = f (Quotient (eMap f a) (eMap f b))
> eMap f (Var v) = f (Var v)
> eMap f (Lit i) = f (Lit i)

Now we can easily apply the identity law recursively like:

> deepIdentity :: Expr -> Expr
> deepIdentity = eMap identity

*Main> ppExpr (deepIdentity (expr "0 + (0 + 0) + (0 + 0)"))
0

Sweet!

But, having to write eMap out by hand like that somehow feels wrong --
as if I am missing some additional abstraction. In some respects eMap
is like a Functor, but not quite. I expect there is a way to implement
eMap using Data.Generics, which is perhaps better, but I still feel
like that is missing something?

Anyway, I just thought I would ask in case someone recognized this
pattern and could point me in the right direction. I have attached a
working example program you can play with.

I would also be interested in alternative approaches besides the ones
I outlined.

thanks!
j.
-------------- next part --------------
>{-# LANGUAGE DeriveDataTypeable #-}
>
> import Control.Applicative (Applicative((<*>), pure), (*>), (<*))
> import Control.Monad (ap)
> import Data.Generics (Typeable, Data)
> import Data.List (isSuffixOf)
> import           Text.ParserCombinators.Parsec  ((<|>))
> import qualified Text.ParserCombinators.Parsec as P
> import qualified Text.ParserCombinators.Parsec.Expr as P
> import           Text.PrettyPrint.HughesPJ ((<+>))
> import qualified Text.PrettyPrint.HughesPJ as H
> import Prelude hiding (sum, product)
>
> data Expr 
>    = Quotient Expr Expr
>    | Product Expr Expr
>    | Sum Expr Expr
>    | Difference Expr Expr
>    | Lit Double
>    | Var Char
>      deriving (Eq, Ord, Data, Typeable, Read, Show)
>
> instance Applicative (P.GenParser token state) where
>     pure = return
>     (<*>) = ap
>
> parseExpr :: P.GenParser Char st Expr
> parseExpr = P.buildExpressionParser optable (lit <|> var <|> parenExpr)
>     where
>       parenExpr = 
>           (P.char '(' >> P.skipMany P.space) *> parseExpr <* (P.char ')' >> P.skipMany P.space)
>       optable = 
>           [ [ P.Infix (P.char '/' >> P.skipMany P.space >> return Quotient)  P.AssocLeft  ]
>           , [ P.Infix (P.char '*' >> P.skipMany P.space >> return Product)    P.AssocRight ]
>           , [ P.Infix (P.char '+' >> P.skipMany P.space >> return Sum)        P.AssocRight ]
>           , [ P.Infix (P.char '-' >> P.skipMany P.space >> return Difference) P.AssocLeft  ]
>           ]
>       lit = 
>           do d <- P.try (P.many1 $ P.oneOf ('-' : '.' : ['0'..'9']))
>              P.skipMany P.space
>              return (Lit (read d))
>       var =
>           do sign <- (P.char '-' >> return (\x -> (Product (Lit (-1)) x))) <|> (return id)
>              v <- (P.upper <|> P.lower)
>              P.skipMany P.space
>              return (sign (Var v))
>
> expr :: String -> Expr
> expr str = either (error .show) id (P.parse parseExpr str str)
>
> ppExpr :: Expr -> H.Doc
> ppExpr (Lit i)          = H.text (let f s = if isSuffixOf ".0" s then init(init s) else s in f $ show i)
> ppExpr (Var v)          = H.char v
> ppExpr (Quotient x y)   = H.parens (ppExpr x <+> H.char '/' <+> ppExpr y)
> ppExpr (Product x y)    = H.parens (ppExpr x <+> H.char '*' <+> ppExpr y)
> ppExpr (Sum x y)        = H.parens (ppExpr x <+> H.char '+' <+> ppExpr y)
> ppExpr (Difference x y) = H.parens (ppExpr x <+> H.char '-' <+> ppExpr y)

> -- |Deep map of an expression.
> eMap :: (Expr -> Expr) -> Expr -> Expr
> eMap f (Sum a b) = f (Sum (eMap f a) (eMap f b))
> eMap f (Difference a b) = f (Difference (eMap f a) (eMap f b))
> eMap f (Product a b) = f (Product (eMap f a) (eMap f b))
> eMap f (Quotient a b) = f (Quotient (eMap f a) (eMap f b))
> eMap f (Var v) = f (Var v)
> eMap f (Lit i) = f (Lit i)

> identity (Sum (Lit 0) a)        = a
> identity (Sum a (Lit 0))        = a
> identity (Difference a (Lit 0)) = a
> identity (Product a (Lit 1))    = a
> identity (Product (Lit 1) a)    = a
> identity (Quotient a (Lit 1))   = a
> identity a                      = a

> deepIdentity :: Expr -> Expr
> deepIdentity = eMap identity

> test :: IO ()
> test =
>     do print (ppExpr (deepIdentity (expr "1 + 2")))
>        print (ppExpr (deepIdentity (expr "0 + (0 + 0) + (0 + 0)")))