[Haskell-cafe] Re: Pattern combinators

[Massimiliano Gubinelli]

David Menendez <dave <at> zednenem.com> writes:

> 
> On Sun, Dec 21, 2008 at 10:14 PM, Andrew Wagner 
> <wagner.andrew <at> gmail.com> wrote:
> > I'd love to see a copy of this go up on hackage for experimentation.
>>  Would
> > you care to upload your code, or send it to me so I can upload it?
> 
> I've uploaded my latest version to <http://hpaste.org/13263>. It
> explicitly makes patterns polymorphic over the answer type of the case
> statement by making Pattern a newtype and universally quantifying the
> (un)currying and matching functions.
> 
> For example,
> 
> (->>) :: Pattern a () vec -> Curry vec ans -> Case a ans
> 
> I'm not sure it makes sense to create a package just yet. At the very
> least, you should ask Morten Rhiger first. The type signatures are
> mine, but the code is mostly straight transcriptions from his paper.
> 

Hi,
 I've tried to undestand the paper, in particular the relation between
the combinators written in cps style and combinators written using a  
Maybe type (i.e pattern matching functions returning Maybe to signal 
success or failure). The code below gives an implementation of the 
basic pattern matching functions on top of two possible implementation 
of an abstract interface for building and using bindings. In particular 
using type families it seems to be possible to automatically construct a 
function inj to convert between a function in the form a->b->c->d to a 
function in the form (a,(b,c,())) -> d,  thereby removing the need of 
building such coverter via the pattern matching functions like suggested 
in the paper.

Since I'm an Haskell begineer I would appreciate very much comments or 
suggestions for improvements.

Best,
Massimiliano Gubinelli

Here the code:
-----------------------------------
{-# LANGUAGE  TypeFamilies, MultiParamTypeClasses, 
 FlexibleInstances,  RankNTypes  #-}
  
module PM where

-- inj converts a function of the form a -> b -> c -> d to the
-- uniform representation (a,(b,(c,()))) -> d 

class Fn a c where
    type Fnq a c
    inj :: Fnq a c -> a -> c

instance Fn () c where
    type Fnq () c = c
    inj f () = f 

instance Fn b c => Fn (a,b) c where
    type Fnq (a,b) c = a -> Fnq b c
    inj f (a,b) = inj (f a) b


-- pattern matching, cps style
-- a binding function has three inputs: ks kf v. v is a list of 
-- current bindings.

newtype PatA a b = PatA {
  unPatA :: forall ans. (b -> ans) -> ans -> a -> ans 
  }

applyA :: PatA a b -> (b -> c) -> c -> a -> c
applyA (PatA p) ks kf v = p ks kf v

meetA :: PatA a b -> PatA b c  -> PatA a c 
meetA (PatA a) (PatA b) =  PatA $ \ ks kf -> a (b ks kf) kf

joinA :: PatA a b -> PatA a b  -> PatA a b 
joinA (PatA a) (PatA b) = PatA $ \ ks kf v -> a ks (b ks kf v) v

anyA :: PatA a a 
anyA  = PatA $ \ ks kf -> ks

noneA :: PatA a a 
noneA = PatA $ \ ks kf v -> kf

varA :: x -> PatA a (x,a) 
varA x = PatA $ \ ks kf v -> ks (x,v)

pairA a b (x,y) = meetA (a x) (b y)
conA a x = if a == x then  anyA   else  noneA
andA a b x = meetA (a x) (b x)
orA p n x = joinA (p x) (n x)   

matchA val pat = pat val ()
caseA a fa fb x v = applyA (a x) (inj fa) (fb x v) v
otherwiseA kf = \x v -> kf


isA p x = matchA x $ caseA p (\_ -> True) $ otherwiseA False


testA1 z  =  matchA z $ caseA (conA (1,2)) ("first match") $
        caseA (pairA (conA 1) varA) 
              (\x -> "second match " ++ show x) $
        caseA (pairA varA varA)    
              (\x y -> "third match " ++ show x) $
        otherwiseA "mismatch" 




-- pattern matching, Maybe style

-- a binding function receives a list of current bindings and returns
-- a Maybe type containing the list of updated bindings in case of 
-- success

newtype PatB a b = PatB { unPatB :: a -> Maybe b }

applyB :: PatB a b -> (b -> c) -> c -> a -> c
applyB (PatB p) ks kf v = maybe kf ks (p v)

meetB :: PatB a b -> PatB c a -> PatB c b
meetB (PatB a) (PatB b) = PatB $ \v -> (b v) >>= a

joinB :: PatB a b -> PatB a b -> PatB a b
joinB (PatB a)  (PatB b) = PatB $ \v -> maybe (b v) Just (a v)

anyB :: PatB a a
anyB = PatB $ \v -> Just v

noneB :: PatB a a
noneB = PatB $ \v -> Nothing

varB :: x -> PatB a (x,a)
varB x = PatB $ \v -> Just (x,v)


pairB a b (x,y) =  meetB (a x) (b y)
conB a x = if a == x then  anyB  else noneB
orB a b x = joinB (a x) (b x)
andB a b x = meetB (a x) (b x)

matchB val pat = pat val ()

--caseB a fa fb x v = maybe (fb x v) (inj fa) ((unPatB $ a x) v) 
caseB a fa fb x v = applyB (a x) (inj fa) (fb x v) v
otherwiseB f = \x v -> f

isB p x = matchB x $ caseB p (\_ -> True) $ otherwiseB False

testB1 z = matchB z $ caseB (pairB (conB 1) (conB 2)) ("first match") $
        caseB (pairB (conB 1) varB) (\x -> "second match " ++ show x) $
        caseB (pairB varB varB)     (\x y -> "third match " ++ show x) $
        otherwiseB "mismatch"