1 module PatRewrite where

2

3 import qualified Maybe

4

5 type Literal = String -- good enough for now

6

7 type Varname = String

8

9 data ConcretePat = CAnd ConcretePat ConcretePat

10 | CDiscard

11 | CBinding Varname

12 | CTuple [ConcretePat]

13 | CLiteral Literal

14 deriving Show

15

16 data Value = VLiteral Literal

17 | VTuple [Value]

18 deriving Show

19

20 -- Pattern matcher:

21 -- v -> sk -> fk -> result

22 -- Value -> (Bindings -> a) -> (() -> a) -> a

23 -- Value -> ([(Varname, Value)] -> a) -> (() -> a) -> a

24

25 -- data MatchTree = MDiscard Outcome

26 -- | MBinding Varname Outcome

27 -- | MTuple Integer Outcome

28 -- | MLiteral Literal Outcome

29 -- | MOr [MatchTree]

30

31 names (CAnd l r) = names l ++ names r

32 names (CDiscard) = []

33 names (CBinding n) = [n]

34 names (CTuple ps) = concatMap names ps

35 names (CLiteral l) = []

36

37 match (CAnd l r) v sk fk = match l v (\lbs -> match r v (\rbs -> sk (lbs ++ rbs)) fk) fk

38 match (CDiscard) v sk fk = sk []

39 match (CBinding n) v sk fk = sk [(n, v)]

40 match (CTuple ps) v sk fk = matchTuple ps v sk fk

41 match (CLiteral l) v sk fk = matchLiteral l v sk fk

42

43 matchLiteral pl (VLiteral vl) sk fk = if vl == pl then sk [] else fk ()

44 matchLiteral p (VTuple _) sk fk = fk ()

45

46 matchTuple ps (VLiteral _) sk fk = fk ()

47 matchTuple ps (VTuple vs) sk fk = matchTuple' ps vs sk fk

48

49 matchTuple' [] [] sk fk = sk []

50 matchTuple' (p:ps) (v:vs) sk fk = match p v (\bs -> matchTuple' ps vs (\bss -> sk (bs ++ bss)) fk) fk

51 matchTuple' _ _ sk fk = fk ()

52

53 -- We want a compiled matcher to be of type

54 -- Value -> Maybe ([Value], ClosureBody, ClosureEnv)

55

56 -- (a, (b1,b2)#(c,_))

57 t1 = CTuple [CBinding "a",

58 CAnd (CTuple [CBinding "b1", CBinding "b2"])

59 (CTuple [CBinding "c", CDiscard])]

60

61 v1 = VTuple [VLiteral "x",

62 VTuple [VLiteral "y", VLiteral "z"]]

63

64 -- a#(_,_)

65 t2 = CAnd (CBinding "a") (CTuple [CDiscard, CDiscard])