How can I simplify this pattern matching?

Question

Im trying to create a model of a propositional logic in Haskell, and i need a function to apply some logic rules to specific subexpressions. The function "apply" takes a list which indicate the position of the subexpression in the tree (in terms of right and left sequences), a logic rule and a logic expression and returns a new logic expression.

data LogicExp  a = P a                              | 
                     True'                      | 
                     False'                                 | 
                     Not' (LogicExp a)                  |  
                     (LogicExp a) :&  (LogicExp a)  | 
                     (LogicExp a) :|  (LogicExp a)  | 
                     (LogicExp a) :=> (LogicExp a)    |
                     (LogicExp a) :=  (LogicExp a)
    deriving Show


type LExp = LogicExp String

data Position = L | R

deMorgan :: LExp -> LExp
deMorgan (e1 :& e2) = Not' ((Not e1) :| (Not e2))
deMorgan (e1 :| e2) = Not' ((Not e1) :& (Not e2))
deMorgan x = x

apply :: [Position] -> (LExp -> LExp) -> LExp -> LExp
apply [] f e = f e
apply (L:xs) f (e1 :& e2) = (apply xs f e1) :& e2
apply (R:xs) f (e1 :& e2) = e1 :& (apply xs f e2)
apply (L:xs) f (e1 :| e2) = (apply xs f e1) :| e2
apply (R:xs) f (e1 :| e2) = e1 :| (apply xs f e2)
apply (L:xs) f (e1 :=> e2) = (apply xs f e1) :=> e2
apply (R:xs) f (e1 :=> e2) = e1 :=> (apply xs f e2)
apply (L:xs) f (e1 := e2) = (apply xs f e1) := e2
apply (R:xs) f (e1 := e2) = e1 := (apply xs f e2)
apply (x:xs) f (Not' e) = apply xs f e

The function works fine. But can I use some data constructor "wildcard" to have a more simple function like this?

apply :: [Position] -> (LExp -> LExp) -> LExp -> LExp
apply [] f e = f e
apply (L:xs) f (e1 ?? e2) = (apply xs f e1) ?? e2
apply (R:xs) f (e1 ?? e2) = e1 ?? (apply xs f e2)
apply (x:xs) f (Not' e) = apply xs f e

score 8 · Accepted Answer · edited May 23 '17 at 12:29

At the moment I can't recall any fancy tricks for doing that. One thing you might want to do, however, is factoring out the common structure in your LogicExp constructors:

data LogicExp a
    = P a
    | True'
    | False'
    | Not' (LogicExp a) 
    | Bin' BinaryOp (LogicExp a) (LogicExp a)
    deriving Show

data BinaryOp = And' | Or' | Impl' | Equiv'
    deriving Show

apply :: [Position] -> (LExp -> LExp) -> LExp -> LExp
apply [] f e = f e
apply (L:xs) f (Bin' op e1 e2) = Bin' op (apply xs f e1) e2
apply (R:xs) f (Bin' op e1 e2) = Bin' op e1 (apply xs f e2)
apply (x:xs) f (Not' e) = apply xs f e
-- ... and the P, True' and False' cases.

By doing that you lose the cute infix constructors. If you really want them back, however, there is a fancy trick: view patterns (see also this question for more examples and discussion).

score 5 · Answer 2 · answered Aug 10 '15 at 04:49

This is a classic case for using one of the Generics packages, either syb or uniplate.

Generally uniplate is faster but not as capable as syb. Fortunately in this case you can get away with using uniplate.

Steps to make use of uniplate:

use the DeriveDataTypeable pragma.
auto derive Data and Typeable
import Data.Data and a uniplate module like Data.Generics.Uniplate.Data

The transformation function you want is simply transform with the appropriate type signature:

doit :: LExp -> LExp
doit = transform deMorgan

where deMorgan is exactly as you have written it.

Complete example:

{-# LANGUAGE DeriveDataTypeable #-}
module Lib6 where

import Data.Data
import Data.Generics.Uniplate.Data
import Text.Show.Pretty (ppShow)

data LogicExp  a = P a                              |
                     True'                      |
                     False'                                 |
                     Not' (LogicExp a)                  |
                     (LogicExp a) :&  (LogicExp a)  |
                     (LogicExp a) :|  (LogicExp a)  |
                     (LogicExp a) :=> (LogicExp a)    |
                     (LogicExp a) :=  (LogicExp a)
    deriving (Show, Data, Typeable)

type LExp = LogicExp String

data Position = L | R

deMorgan :: LExp -> LExp
deMorgan (e1 :& e2) = Not' ((Not' e1) :| (Not' e2))
deMorgan (e1 :| e2) = Not' ((Not' e1) :& (Not' e2))
deMorgan x = x

doit :: LExp -> LExp
doit = transform deMorgan

example = (P "a" :& P "b") :| (P "c")

test = putStrLn $ ppShow (doit example)

Running test produces:

Not' (Not' (Not' (Not' (P "a") :| Not' (P "b"))) :& Not' (P "c"))

An intro tutorial on uniplate:

http://community.haskell.org/~ndm/darcs/uniplate/uniplate.htm

How can I simplify this pattern matching?

2 Answers2