Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2002-2005 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * | |
4 | * MLton is released under a BSD-style license. | |
5 | * See the file MLton-LICENSE for details. | |
6 | *) | |
7 | ||
8 | structure ChoicePattern: CHOICE_PATTERN = | |
9 | struct | |
10 | ||
11 | datatype t = | |
12 | Concat of t vector | |
13 | | Choice of t vector | |
14 | | String of string | |
15 | ||
16 | fun layout t = | |
17 | let | |
18 | open Layout | |
19 | in | |
20 | case t of | |
21 | Concat v => seq [str "Concat ", Vector.layout layout v] | |
22 | | Choice v => seq [str "Choice ", Vector.layout layout v] | |
23 | | String s => seq [str "\"", String.layout s, str "\""] | |
24 | end | |
25 | ||
26 | fun fromString (s: string): t Result.t = | |
27 | let | |
28 | val n = String.size s | |
29 | exception Error of string | |
30 | fun error ss = raise Error (concat ss) | |
31 | datatype state = | |
32 | Nest of {start: int} | |
33 | | Normal | |
34 | fun loop (cur: int, | |
35 | ac: char list, | |
36 | prev: t list, | |
37 | prevChoices: t list, | |
38 | state: state): int * t = | |
39 | let | |
40 | fun accum () = String (String.fromListRev ac) :: prev | |
41 | fun finishChoice () = | |
42 | Concat (Vector.fromListRev (accum ())) :: prevChoices | |
43 | fun keepChar cur = | |
44 | loop (cur + 1, String.sub (s, cur) :: ac, | |
45 | prev, prevChoices, state) | |
46 | in | |
47 | if cur < n | |
48 | then | |
49 | let | |
50 | val c = String.sub (s, cur) | |
51 | in | |
52 | case c of | |
53 | #"{" => let | |
54 | val (cur, t) = | |
55 | loop (cur + 1, [], [], [], | |
56 | Nest {start = cur}) | |
57 | in | |
58 | loop (cur, [], t :: accum (), prevChoices, | |
59 | state) | |
60 | end | |
61 | | #"}" => | |
62 | (case state of | |
63 | Nest _ => | |
64 | (cur + 1, | |
65 | Choice (Vector.fromList (finishChoice ()))) | |
66 | | Normal => | |
67 | error ["unmatched } at position ", | |
68 | Int.toString cur]) | |
69 | | #"," => | |
70 | (case state of | |
71 | Nest _ => loop (cur + 1, [], [], finishChoice (), | |
72 | state) | |
73 | | Normal => keepChar cur) | |
74 | | #"\\" => | |
75 | let | |
76 | val cur = cur + 1 | |
77 | in | |
78 | if cur = n | |
79 | then error ["terminating backslash"] | |
80 | else keepChar cur | |
81 | end | |
82 | | _ => keepChar cur | |
83 | end | |
84 | else | |
85 | (case state of | |
86 | Nest {start} => | |
87 | error ["unmatched { at position ", | |
88 | Int.toString start] | |
89 | | Normal => | |
90 | (cur, Concat (Vector.fromListRev (accum ())))) | |
91 | end | |
92 | in | |
93 | Result.Yes (#2 (loop (0, [], [], [], Normal))) | |
94 | handle Error s => Result.No s | |
95 | end | |
96 | ||
97 | val fromString = | |
98 | Trace.trace ("ChoicePattern.fromString", String.layout, Result.layout layout) | |
99 | fromString | |
100 | ||
101 | fun foldDown (v, a, f) = | |
102 | let | |
103 | fun loop (i, a) = | |
104 | if i < 0 | |
105 | then a | |
106 | else loop (i - 1, f (Vector.sub (v, i), a)) | |
107 | in | |
108 | loop (Vector.length v - 1, a) | |
109 | end | |
110 | ||
111 | fun expandTree (t: t): string list = | |
112 | case t of | |
113 | Choice v => | |
114 | Vector.fold (v, [], fn (t, ac) => | |
115 | expandTree t @ ac) | |
116 | | Concat v => | |
117 | foldDown (v, [""], fn (t, ac) => | |
118 | List.fold | |
119 | (expandTree t, [], fn (s, all) => | |
120 | List.fold | |
121 | (ac, all, fn (s', all) => | |
122 | concat [s, s'] :: all))) | |
123 | | String s => [s] | |
124 | ||
125 | fun expand (s: string): string list Result.t = | |
126 | Result.map (fromString s, expandTree) | |
127 | ||
128 | end |