Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Modified by Vesa Karvonen on 2007-12-18. |
2 | * Create line directives in output. | |
3 | *) | |
4 | (* ML-Yacc Parser Generator (c) 1991 Andrew W. Appel, David R. Tarditi *) | |
5 | ||
6 | structure Absyn : ABSYN = | |
7 | struct | |
8 | datatype exp | |
9 | = CODE of {text : string, pos : Header.pos} | |
10 | | EAPP of exp * exp | |
11 | | EINT of int | |
12 | | ETUPLE of exp list | |
13 | | EVAR of string | |
14 | | FN of pat * exp | |
15 | | LET of decl list * exp | |
16 | | SEQ of exp * exp | |
17 | | UNIT | |
18 | and pat | |
19 | = PVAR of string | |
20 | | PAPP of string * pat | |
21 | | PINT of int | |
22 | | PLIST of pat list * pat option | |
23 | | PTUPLE of pat list | |
24 | | WILD | |
25 | | AS of string * pat | |
26 | and decl = VB of pat * exp | |
27 | and rule = RULE of pat * exp | |
28 | ||
29 | fun idchar #"'" = true | |
30 | | idchar #"_" = true | |
31 | | idchar c = Char.isAlpha c orelse Char.isDigit c | |
32 | ||
33 | fun code_to_ids s = let | |
34 | fun g(nil,r) = r | |
35 | | g(a as (h::t),r) = if Char.isAlpha h then f(t,[h],r) else g(t,r) | |
36 | and f(nil,accum,r)= implode(rev accum)::r | |
37 | | f(a as (h::t),accum,r) = | |
38 | if idchar h then f(t,h::accum,r) else g(a,implode (rev accum) :: r) | |
39 | in g(explode s,nil) | |
40 | end | |
41 | ||
42 | val simplifyRule : rule -> rule = fn (RULE(p,e)) => | |
43 | let val used : (string -> bool) = | |
44 | let fun f(CODE s) = code_to_ids (#text s) | |
45 | | f(EAPP(a,b)) = f a @ f b | |
46 | | f(ETUPLE l) = List.concat (map f l) | |
47 | | f(EVAR s) = [s] | |
48 | | f(FN(_,e)) = f e | |
49 | | f(LET(dl,e)) = | |
50 | (List.concat (map (fn VB(_,e) => f e) dl)) @ f e | |
51 | | f(SEQ(a,b)) = f a @ f b | |
52 | | f _ = nil | |
53 | val identifiers = f e | |
54 | in fn s => List.exists (fn a=>a=s) identifiers | |
55 | end | |
56 | val simplifyPat : pat -> pat = | |
57 | let fun f a = | |
58 | case a | |
59 | of (PVAR s) => if used s then a else WILD | |
60 | | (PAPP(s,pat)) => | |
61 | (case f pat | |
62 | of WILD => WILD | |
63 | | pat' => PAPP(s,pat')) | |
64 | | (PLIST (l, topt)) => | |
65 | let val l' = map f l | |
66 | val topt' = Option.map f topt | |
67 | fun notWild WILD = false | |
68 | | notWild _ = true | |
69 | in case topt' of | |
70 | SOME WILD => if List.exists notWild l' then | |
71 | PLIST (l', topt') | |
72 | else WILD | |
73 | | _ => PLIST (l', topt') | |
74 | end | |
75 | | (PTUPLE l) => | |
76 | let val l' = map f l | |
77 | in if List.exists(fn WILD=>false | _ => true) l' | |
78 | then PTUPLE l' | |
79 | else WILD | |
80 | end | |
81 | | (AS(a,b)) => | |
82 | if used a then | |
83 | case f b of | |
84 | WILD => PVAR a | |
85 | | b' => AS(a,b') | |
86 | else f b | |
87 | | _ => a | |
88 | in f | |
89 | end | |
90 | val simplifyExp : exp -> exp = | |
91 | let fun f(EAPP(a,b)) = EAPP(f a,f b) | |
92 | | f(ETUPLE l) = ETUPLE(map f l) | |
93 | | f(FN(p,e)) = FN(simplifyPat p,f e) | |
94 | | f(LET(dl,e)) = | |
95 | LET(map (fn VB(p,e) => | |
96 | VB(simplifyPat p,f e)) dl, | |
97 | f e) | |
98 | | f(SEQ(a,b)) = SEQ(f a,f b) | |
99 | | f a = a | |
100 | in f | |
101 | end | |
102 | in RULE(simplifyPat p,simplifyExp e) | |
103 | end | |
104 | ||
105 | fun printRule (say : string -> unit, sayln:string -> unit, fmtPos) r = let | |
106 | fun flat (a, []) = rev a | |
107 | | flat (a, SEQ (e1, e2) :: el) = flat (a, e1 :: e2 :: el) | |
108 | | flat (a, e :: el) = flat (e :: a, el) | |
109 | fun pl (lb, rb, c, f, [], a) = " " :: lb :: rb :: a | |
110 | | pl (lb, rb, c, f, h :: t, a) = | |
111 | " " :: lb :: f (h, foldr (fn (x, a) => c :: f (x, a)) | |
112 | (rb :: a) | |
113 | t) | |
114 | fun pe (CODE {text, pos}, a) = | |
115 | " (" :: fmtPos (SOME pos) :: text :: fmtPos NONE :: ")" :: a | |
116 | | pe (EAPP (x, y as (EAPP _)), a) = | |
117 | pe (x, " (" :: pe (y, ")" :: a)) | |
118 | | pe (EAPP (x, y), a) = | |
119 | pe (x, pe (y, a)) | |
120 | | pe (EINT i, a) = | |
121 | " " :: Int.toString i :: a | |
122 | | pe (ETUPLE l, a) = pl ("(", ")", ",", pe, l, a) | |
123 | | pe (EVAR v, a) = | |
124 | " " :: v :: a | |
125 | | pe (FN (p, b), a) = | |
126 | " (fn" :: pp (p, " =>" :: pe (b, ")" :: a)) | |
127 | | pe (LET ([], b), a) = | |
128 | pe (b, a) | |
129 | | pe (LET (dl, b), a) = | |
130 | let fun pr (VB (p, e), a) = | |
131 | " val " :: pp (p, " =" :: pe (e, "\n" :: a)) | |
132 | in " let" :: foldr pr (" in" :: pe (b, "\nend" :: a)) dl | |
133 | end | |
134 | | pe (SEQ (e1, e2), a) = | |
135 | pl ("(", ")", ";", pe, flat ([], [e1, e2]), a) | |
136 | | pe (UNIT, a) = | |
137 | " ()" :: a | |
138 | and pp (PVAR v, a) = | |
139 | " " :: v :: a | |
140 | | pp (PAPP (x, y as PAPP _), a) = | |
141 | " " :: x :: " (" :: pp (y, ")" :: a) | |
142 | | pp (PAPP (x, y), a) = | |
143 | " " :: x :: pp (y, a) | |
144 | | pp (PINT i, a) = | |
145 | " " :: Int.toString i :: a | |
146 | | pp (PLIST (l, NONE), a) = | |
147 | pl ("[", "]", ",", pp, l, a) | |
148 | | pp (PLIST (l, SOME t), a) = | |
149 | " (" :: foldr (fn (x, a) => pp (x, " ::" :: a)) | |
150 | (pp (t, ")" :: a)) | |
151 | l | |
152 | | pp (PTUPLE l, a) = | |
153 | pl ("(", ")", ",", pp, l, a) | |
154 | | pp (WILD, a) = | |
155 | " _" :: a | |
156 | | pp (AS (v, PVAR v'), a) = | |
157 | " (" :: v :: " as " :: v' :: ")" :: a | |
158 | | pp (AS (v, p), a) = | |
159 | " (" :: v :: " as (" :: pp (p, "))" :: a) | |
160 | fun out "\n" = sayln "" | |
161 | | out s = say s | |
162 | in | |
163 | case simplifyRule r of | |
164 | RULE (p, e) => app out (pp (p, " =>" :: pe (e, ["\n"]))) | |
165 | end | |
166 | end; |