1structure PEGParse :> PEGParse =
2struct
3
4  datatype ('tok,'nt,'value)pegsym =
5           empty of 'value
6         | any of 'tok -> 'value
7         | tok of ('tok -> bool) * ('tok -> 'value)
8         | nt of 'nt * ('value -> 'value)
9         | seq of ('tok,'nt,'value)pegsym * ('tok,'nt,'value)pegsym * ('value -> 'value -> 'value)
10         | choice of ('tok,'nt,'value)pegsym * ('tok,'nt,'value)pegsym * ('value -> 'value) * ('value -> 'value)
11         | rpt of ('tok,'nt,'value)pegsym * ('value list -> 'value)
12         | not of ('tok,'nt,'value)pegsym * 'value
13
14  datatype ('tok,'nt,'value) grammar = PEG of { start : ('tok,'nt,'value)pegsym, rules : 'nt -> ('tok,'nt,'value)pegsym option }
15
16  datatype ('source,'tok,'nt,'value)kont =
17           ksym of ('tok,'nt,'value)pegsym * ('source,'tok,'nt,'value)kont * ('source,'tok,'nt,'value)kont
18         | appf1 of ('value -> 'value) * ('source,'tok,'nt,'value)kont
19         | appf2 of ('value -> 'value -> 'value) * ('source,'tok,'nt,'value)kont
20         | returnTo of 'source * 'value option list * ('source,'tok,'nt,'value)kont
21         | poplist of ('value list -> 'value) * ('source,'tok,'nt,'value)kont
22         | listsym of ('tok,'nt,'value)pegsym * ('value list -> 'value) * ('source,'tok,'nt,'value)kont
23         | kdone
24         | kfailed
25
26fun poplistval f acc stk =
27  case stk of
28      [] => raise Fail "Invariant failure in poplist"
29    | SOME h :: t => poplistval f (h::acc) t
30    | NONE::rest => SOME(f acc)::rest
31
32
33fun pegexec G get e inp stk k fk = let
34  fun pe e inp stk k fk =
35      case e of
36          empty v => applykont k inp (SOME v::stk)
37        | tok(P,f) =>
38          let
39          in
40            case get inp of
41                NONE => applykont fk inp stk
42              | SOME(inp',t) => if P t then applykont k inp' (SOME (f t)::stk)
43                                else applykont fk inp stk
44          end
45        | any f =>
46          let
47          in
48            case get inp of
49                NONE => applykont fk inp stk
50              | SOME(inp',t) => applykont k inp' (SOME (f t)::stk)
51          end
52        | seq(e1,e2,f) => pe e1 inp stk (ksym(e2,appf2(f,k),returnTo(inp,stk,fk))) fk
53        | choice(e1,e2,f1,f2) => pe e1 inp stk (appf1(f1,k)) (returnTo(inp,stk,ksym(e2,appf1(f2,k),fk)))
54        | not(e,v) => pe e inp stk (returnTo(inp,stk,fk)) (returnTo(inp,SOME v::stk,k))
55        | rpt(e,f) => pe e inp (NONE::stk) (listsym(e,f,k)) (poplist(f,k))
56        | nt(nm,f) => pe (G nm) inp stk (appf1(f,k)) fk
57  and applykont k0 inp stk =
58      case k0 of
59          ksym(e,k,fk) => pe e inp stk k fk
60        | appf1(f,k) =>
61          let
62          in
63            case stk of
64                SOME v::rest => applykont k inp (SOME (f v)::rest)
65              | _ => raise Fail "Invariant failure in appf1"
66          end
67        | appf2(f,k) =>
68          let
69          in
70            case stk of
71                SOME v1::SOME v2::rest => applykont k inp (SOME (f v2 v1)::rest)
72              | _ => raise Fail "Invariant failure in appf2"
73          end
74        | returnTo(inp,stk,k) => applykont k inp stk
75        | poplist(f,k) => applykont k inp (poplistval f [] stk)
76        | listsym(e,f,k) => pe e inp stk (listsym(e,f,k)) (poplist(f,k))
77        | kdone => SOME(inp,valOf (hd stk))
78        | kfailed => NONE
79in
80  pe e inp stk k fk
81end
82
83end (* struct *)
84