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.
{-# 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)")))