1(* ========================================================================= *)
2(* PARSING                                                                   *)
3(* Copyright (c) 2001 Joe Hurd, distributed under the BSD License            *)
4(* ========================================================================= *)
5
6structure Parse :> Parse =
7struct
8
9open Useful;
10
11infixr 9 >>++
12infixr 8 ++
13infixr 7 >>
14infixr 6 ||
15
16(* ------------------------------------------------------------------------- *)
17(* A "cannot parse" exception.                                               *)
18(* ------------------------------------------------------------------------- *)
19
20exception NoParse;
21
22(* ------------------------------------------------------------------------- *)
23(* Recursive descent parsing combinators.                                    *)
24(* ------------------------------------------------------------------------- *)
25
26val error : 'a -> 'b * 'a = fn _ => raise NoParse;
27
28fun op ++ (parser1,parser2) input =
29    let
30      val (result1,input) = parser1 input
31      val (result2,input) = parser2 input
32    in
33      ((result1,result2),input)
34    end;
35
36fun op >> (parser : 'a -> 'b * 'a, treatment) input =
37    let
38      val (result,input) = parser input
39    in
40      (treatment result, input)
41    end;
42
43fun op >>++ (parser,treatment) input =
44    let
45      val (result,input) = parser input
46    in
47      treatment result input
48    end;
49
50fun op || (parser1,parser2) input =
51    parser1 input handle NoParse => parser2 input;
52
53fun first [] _ = raise NoParse
54  | first (parser :: parsers) input = (parser || first parsers) input;
55
56fun mmany parser state input =
57    let
58      val (state,input) = parser state input
59    in
60      mmany parser state input
61    end
62    handle NoParse => (state,input);
63
64fun many parser =
65    let
66      fun sparser l = parser >> (fn x => x :: l)
67    in
68      mmany sparser [] >> List.rev
69    end;
70
71fun atLeastOne p = (p ++ many p) >> op::;
72
73fun nothing input = ((),input);
74
75fun optional p = (p >> SOME) || (nothing >> K NONE);
76
77(* ------------------------------------------------------------------------- *)
78(* Stream-based parsers.                                                     *)
79(* ------------------------------------------------------------------------- *)
80
81type ('a,'b) parser = 'a Stream.stream -> 'b * 'a Stream.stream
82
83fun maybe p Stream.Nil = raise NoParse
84  | maybe p (Stream.Cons (h,t)) =
85    case p h of SOME r => (r, t ()) | NONE => raise NoParse;
86
87fun finished Stream.Nil = ((), Stream.Nil)
88  | finished (Stream.Cons _) = raise NoParse;
89
90fun some p = maybe (fn x => if p x then SOME x else NONE);
91
92fun any input = some (K true) input;
93
94(* ------------------------------------------------------------------------- *)
95(* Parsing whole streams.                                                    *)
96(* ------------------------------------------------------------------------- *)
97
98fun fromStream parser input =
99    let
100      val (res,_) = (parser ++ finished >> fst) input
101    in
102      res
103    end;
104
105fun fromList parser l = fromStream parser (Stream.fromList l);
106
107fun everything parser =
108    let
109      fun parserOption input =
110          SOME (parser input)
111          handle e as NoParse => if Stream.null input then NONE else raise e
112
113      fun parserList input =
114          case parserOption input of
115            NONE => Stream.Nil
116          | SOME (result,input) =>
117            Stream.append (Stream.fromList result) (fn () => parserList input)
118    in
119      parserList
120    end;
121
122(* ------------------------------------------------------------------------- *)
123(* Parsing lines of text.                                                    *)
124(* ------------------------------------------------------------------------- *)
125
126fun initialize {lines} =
127    let
128      val lastLine = ref (~1,"","","")
129
130      val chars =
131          let
132            fun saveLast line =
133                let
134                  val ref (n,_,l2,l3) = lastLine
135                  val () = lastLine := (n + 1, l2, l3, line)
136                in
137                  String.explode line
138                end
139          in
140            Stream.memoize (Stream.map saveLast lines)
141          end
142
143      fun parseErrorLocation () =
144          let
145            val ref (n,l1,l2,l3) = lastLine
146          in
147            (if n <= 0 then "at start"
148             else "around line " ^ Int.toString n) ^
149            chomp (":\n" ^ l1 ^ l2 ^ l3)
150          end
151    in
152      {chars = chars,
153       parseErrorLocation = parseErrorLocation}
154    end;
155
156fun exactChar (c : char) = some (equal c) >> K ();
157
158fun exactCharList cs =
159    case cs of
160      [] => nothing
161    | c :: cs => (exactChar c ++ exactCharList cs) >> snd;
162
163fun exactString s = exactCharList (String.explode s);
164
165fun escapeString {escape} =
166    let
167      fun isEscape c = mem c escape
168
169      fun isNormal c =
170          case c of
171            #"\\" => false
172          | #"\n" => false
173          | #"\t" => false
174          | _ => not (isEscape c)
175
176      val escapeParser =
177          (exactChar #"\\" >> K #"\\") ||
178          (exactChar #"n" >> K #"\n") ||
179          (exactChar #"t" >> K #"\t") ||
180          some isEscape
181
182      val charParser =
183          ((exactChar #"\\" ++ escapeParser) >> snd) ||
184          some isNormal
185    in
186      many charParser >> String.implode
187    end;
188
189local
190  val isSpace = Char.isSpace;
191
192  val space = some isSpace;
193in
194  val manySpace = many space >> K ();
195
196  val atLeastOneSpace = atLeastOne space >> K ();
197end;
198
199fun fromString parser s = fromList parser (String.explode s);
200
201(* ------------------------------------------------------------------------- *)
202(* Infix operators.                                                          *)
203(* ------------------------------------------------------------------------- *)
204
205fun parseLayeredInfixes {tokens,assoc} mk tokParser subParser =
206    let
207      fun layerTokParser inp =
208          let
209            val tok_rest as (tok,_) = tokParser inp
210          in
211            if StringSet.member tok tokens then tok_rest
212            else raise NoParse
213          end
214
215      fun layerMk (x,txs) =
216          case assoc of
217            Print.LeftAssoc =>
218            let
219              fun inc ((t,y),z) = mk (t,z,y)
220            in
221              List.foldl inc x txs
222            end
223          | Print.NonAssoc =>
224            (case txs of
225               [] => x
226             | [(t,y)] => mk (t,x,y)
227             | _ => raise NoParse)
228          | Print.RightAssoc =>
229            (case List.rev txs of
230               [] => x
231             | tx :: txs =>
232               let
233                 fun inc ((t,y),(u,z)) = (t, mk (u,y,z))
234
235                 val (t,y) = List.foldl inc tx txs
236               in
237                 mk (t,x,y)
238               end)
239
240      val layerParser = subParser ++ many (layerTokParser ++ subParser)
241    in
242      layerParser >> layerMk
243    end;
244
245fun parseInfixes ops =
246    let
247      val layeredOps = Print.layerInfixes ops
248
249      val iparsers = List.map parseLayeredInfixes layeredOps
250    in
251      fn mk => fn tokParser => fn subParser =>
252         List.foldr (fn (p,sp) => p mk tokParser sp) subParser iparsers
253    end;
254
255(* ------------------------------------------------------------------------- *)
256(* Quotations.                                                               *)
257(* ------------------------------------------------------------------------- *)
258
259type 'a quotation = 'a frag list;
260
261fun parseQuotation printer parser quote =
262  let
263    fun expand (QUOTE q, s) = s ^ q
264      | expand (ANTIQUOTE a, s) = s ^ printer a
265
266    val string = List.foldl expand "" quote
267  in
268    parser string
269  end;
270
271end
272