Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/branches/primop-branch-2/src/compiler/FLINT/kernel/pplty.sml
ViewVC logotype

Annotation of /sml/branches/primop-branch-2/src/compiler/FLINT/kernel/pplty.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2013 - (view) (download)

1 : georgekuan 1999 (* pplty.sml
2 :     *
3 :     * (c) 2006 SML/NJ Fellowship
4 :     *
5 : georgekuan 1998 * Pretty Printer for PLambda types using the new SMLNJ-lib new pretty printer
6 :     *
7 :     *)
8 :    
9 :     structure PPLTy =
10 :     struct
11 :    
12 : georgekuan 2000 local
13 : georgekuan 1999
14 : georgekuan 2000 structure LK = LtyKernel
15 :     structure PT = PrimTyc
16 :     structure PP = PrettyPrintNew
17 :     open PPUtilNew
18 :     in
19 :    
20 :     fun ppList ppstrm {sep, pp : 'a -> unit} list =
21 :     let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm
22 :     in
23 :     (ppSequence ppstrm
24 : georgekuan 2002 {sep = fn ppstrm => (PP.string ppstrm sep;
25 :     PP.break ppstrm {nsp=1, offset=0}),
26 : georgekuan 2000 style = INCONSISTENT,
27 :     pr = (fn _ => fn elem =>
28 :     (openHOVBox 1;
29 : georgekuan 2011 (* pps "("; *)
30 : georgekuan 2000 pp elem;
31 : georgekuan 2011 (* pps ")"; *)
32 : georgekuan 2000 closeBox()))}
33 :     list)
34 :     end (* ppList *)
35 :    
36 : georgekuan 1998 (* ppTKind : tkind -> unit
37 :     * Print a hashconsed representation of the kind *)
38 : georgekuan 2000 fun ppTKind ppstrm (tk : LK.tkind) =
39 :     let val ppTKind' = ppTKind ppstrm
40 :     val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm
41 :     val ppList' = ppList ppstrm
42 :     fun ppTKindI(LK.TK_MONO) = pps "TK_MONO"
43 :     | ppTKindI(LK.TK_BOX) = pps "TK_BOX"
44 : georgekuan 1999 | ppTKindI(LK.TK_FUN (argTkinds, resTkind)) =
45 :     (* res_tkind is a TK_SEQ wrapping some tkinds
46 :     * These are produced by Elaborate/modules/instantiate.sml
47 :     *)
48 : georgekuan 1998 (openHOVBox 1;
49 :     pps "TK_FUN (";
50 : georgekuan 2000 ppList' {sep="* ", pp=ppTKind'} argTkinds;
51 :     ppTKind' resTkind;
52 : georgekuan 1999 pps ")";
53 :     closeBox())
54 : georgekuan 1998 | ppTKindI(LK.TK_SEQ tkinds) =
55 :     (openHOVBox 1;
56 : georgekuan 1999 pps "TK_SEQ(";
57 : georgekuan 2000 ppList' {sep=", ", pp=ppTKind'} tkinds;
58 : georgekuan 1999 pps ")";
59 :     closeBox())
60 : georgekuan 1998 in ppTKindI (LK.tk_out tk)
61 : georgekuan 2000 end (* ppTKind *)
62 : georgekuan 2003
63 :     fun tycEnvFlatten(tycenv) =
64 : georgekuan 2013 (print "flatten";
65 :     (case LK.tcSplit(tycenv) of
66 : georgekuan 2003 NONE => []
67 : georgekuan 2013 | SOME(elem, rest) => elem::tycEnvFlatten(rest)))
68 : georgekuan 2003
69 :     fun ppTycEnvElem ppstrm (tycop, i) =
70 :     let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm
71 :     in
72 :     openHOVBox 1;
73 : georgekuan 2011 (* pps "("; *)
74 : georgekuan 2003 (case tycop of
75 :     NONE => pps "*"
76 :     | SOME(tycs) => ppList ppstrm {sep=",", pp=ppTyc ppstrm} tycs);
77 :     pps ", ";
78 :     PP.break ppstrm {nsp = 1, offset=0};
79 :     ppi ppstrm i;
80 : georgekuan 2011 (* pps ")"; *)
81 : georgekuan 2003 closeBox()
82 :     end (* function ppTycEnvElem *)
83 :    
84 :     and ppTyc ppstrm (tycon : LK.tyc) =
85 : georgekuan 1999 (* FLINT variables are represented using deBruijn indices *)
86 : georgekuan 2000 let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm
87 :     (* eta-expansion of ppList to avoid
88 :     value restriction *)
89 :     val ppList' : {pp:'a -> unit, sep: string} -> 'a list -> unit = fn x => ppList ppstrm x
90 :     val ppTKind' = ppTKind ppstrm
91 :     val ppTyc' = ppTyc ppstrm
92 :     fun ppTycI (LK.TC_VAR(depth, cnt)) =
93 : georgekuan 1999 (pps "TC_VAR(";
94 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
95 : georgekuan 1999 (* depth is a deBruijn index set in elabmod.sml/instantiate.sml *)
96 :     pps (DebIndex.di_print depth);
97 :     pps ",";
98 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
99 : georgekuan 2003 (* cnt is computed in instantiate.sml sigToInst or
100 :     alternatively may be simply the IBOUND index *)
101 : georgekuan 1999 pps (Int.toString cnt);
102 :     pps ")")
103 :     (* Named tyc VAR; is actually an lvar *)
104 :     | ppTycI (LK.TC_NVAR tvar) =
105 :     (pps "TC_NVAR(";
106 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
107 : georgekuan 1999 pps (Int.toString tvar);
108 :     pps ")")
109 :     | ppTycI (LK.TC_PRIM primtycon) =
110 :     (pps "TC_PRIM(";
111 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
112 : georgekuan 1999 pps (PT.pt_print primtycon);
113 :     pps ")")
114 :     | ppTycI (LK.TC_FN (argTkinds, resultTyc)) =
115 :     (openHOVBox 1;
116 :     pps "TC_FN(";
117 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
118 : georgekuan 2000 ppList' {sep="* ", pp=ppTKind'} argTkinds;
119 : georgekuan 1999 pps ",";
120 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
121 : georgekuan 2000 ppTyc' resultTyc;
122 : georgekuan 1999 pps ")";
123 :     closeBox())
124 :     | ppTycI (LK.TC_APP(contyc, tys)) =
125 :     (openHOVBox 1;
126 :     pps "TC_APP(";
127 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
128 : georgekuan 2000 ppTyc' contyc;
129 : georgekuan 1999 pps ",";
130 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
131 : georgekuan 2000 ppList' {sep="* ", pp=ppTyc'} tys;
132 : georgekuan 1999 pps ")";
133 :     closeBox())
134 :     | ppTycI (LK.TC_SEQ tycs) =
135 :     (openHOVBox 1;
136 :     pps "TC_SEQ(";
137 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
138 : georgekuan 2000 ppList' {sep=", ", pp=ppTyc'} tycs;
139 : georgekuan 1999 pps ")";
140 :     closeBox())
141 :     | ppTycI (LK.TC_PROJ(tycon, index)) =
142 :     (openHOVBox 1;
143 :     pps "TC_PROJ(";
144 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
145 : georgekuan 2000 ppTyc' tycon;
146 : georgekuan 1999 pps ", ";
147 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
148 : georgekuan 1999 pps (Int.toString index);
149 :     pps ")";
150 :     closeBox())
151 :     | ppTycI (LK.TC_SUM(tycs)) =
152 :     (pps "TC_SUM(";
153 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
154 : georgekuan 2000 ppList' {sep=", ", pp=ppTyc'} tycs;
155 : georgekuan 1999 pps ")")
156 : georgekuan 2008 (* TC_FIX is a recursive datatype constructor
157 :     from a (mutually-)recursive family *)
158 : georgekuan 1999 | ppTycI (LK.TC_FIX((numStamps, datatypeFamily, freetycs), index)) =
159 :     (openHOVBox 1;
160 :     pps "TC_FIX(";
161 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
162 : georgekuan 2013 print "LK.tc_out";
163 : georgekuan 2008 (case (LK.tc_out datatypeFamily) of
164 :     LK.TC_FN(params, rectyc) => (* generator function *)
165 :     let fun ppMus 0 = ()
166 :     | ppMus i = (pps "mu";
167 :     ppi ppstrm i;
168 :     pps " ";
169 :     ppMus (i - 1))
170 :     in
171 :     (pps "RECTYCGEN(";
172 :     if (length params) > 0 then (pps "[";
173 :     ppMus (length params);
174 :     pps "]")
175 :     else ();
176 : georgekuan 2013 PP.break ppstrm {nsp=1,offset=1};
177 :     print "LK.tc_out";
178 : georgekuan 2008 (case (LK.tc_out rectyc) of
179 :     (rectycI as LK.TC_FN _) => ppTycI rectycI
180 :     | LK.TC_SEQ(dconstycs) =>
181 :     ppTyc' (List.nth(dconstycs, index))
182 :     | tycI => ppTycI tycI);
183 :     PP.break ppstrm {nsp=0,offset=0};
184 :     pps ")")
185 :     end
186 :     | _ => pps "<No rectyc generator>");
187 :     PP.break ppstrm {nsp=0,offset=0};
188 :     pps ")";
189 :     closeBox()
190 :     (* pps "TC_FIX(";
191 :     PP.break ppstrm {nsp=1,offset=1};
192 : georgekuan 1999 pps "nStamps = ";
193 :     pps (Int.toString numStamps);
194 : georgekuan 2002 pps ",";
195 :     PP.break ppstrm {nsp=1, offset=0};
196 : georgekuan 1999 pps "datatypeFamily = ";
197 : georgekuan 2000 ppTyc' datatypeFamily;
198 : georgekuan 1999 pps ", ";
199 : georgekuan 2002 PP.break ppstrm {nsp=1, offset=0};
200 : georgekuan 1999 pps "freeTycs = ";
201 : georgekuan 2000 ppList' {sep = ", ", pp = ppTyc'} freetycs;
202 : georgekuan 1999 pps ", ";
203 : georgekuan 2002 PP.break ppstrm {nsp=1, offset=0};
204 : georgekuan 1999 pps "index = ";
205 :     pps (Int.toString index);
206 :     pps ")";
207 : georgekuan 2008 closeBox() *) )
208 : georgekuan 1999 | ppTycI (LK.TC_ABS tyc) =
209 :     (pps "TC_ABS(";
210 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
211 : georgekuan 2000 ppTyc' tyc;
212 : georgekuan 1999 pps ")")
213 :     | ppTycI (LK.TC_BOX tyc) =
214 :     (pps "TC_BOX(";
215 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
216 : georgekuan 2000 ppTyc' tyc;
217 : georgekuan 1999 pps ")")
218 :     (* rflag is a tuple kind template, a singleton datatype RF_TMP *)
219 :     | ppTycI (LK.TC_TUPLE (rflag, tycs)) =
220 : georgekuan 2011 (case tycs of
221 :     [] => pps "UNIT"
222 :     | _ => (pps "TC_TUPLE(";
223 :     PP.break ppstrm {nsp=1,offset=1};
224 :     ppList' {sep="* ", pp=ppTyc'} tycs;
225 :     pps ")"))
226 : georgekuan 1999 (* fflag records the calling convention: either FF_FIXED or FF_VAR *)
227 : georgekuan 2000 | ppTycI (LK.TC_ARROW (fflag, argTycs, resTycs)) =
228 : georgekuan 1999 (pps "TC_ARROW(";
229 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
230 : georgekuan 1999 (case fflag of LK.FF_FIXED => pps "FF_FIXED"
231 : georgekuan 2000 | LK.FF_VAR(b1, b2) => (pps "<FF_VAR>" (*;
232 :     ppBool b1;
233 : georgekuan 1999 pps ", ";
234 : georgekuan 2000 ppBool b2;
235 :     pps ")"*) ));
236 :     ppList' {sep="* ", pp=ppTyc'} argTycs;
237 : georgekuan 1999 pps ", ";
238 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
239 : georgekuan 2000 ppList' {sep="* ", pp=ppTyc'} resTycs;
240 : georgekuan 1999 pps ")")
241 :     (* According to ltykernel.sml comment, this arrow tyc is not used *)
242 : georgekuan 2000 | ppTycI (LK.TC_PARROW (argTyc, resTyc)) =
243 : georgekuan 1999 (pps "TC_PARROW(";
244 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
245 : georgekuan 2000 ppTyc' argTyc;
246 : georgekuan 1999 pps ", ";
247 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
248 : georgekuan 2000 ppTyc' resTyc;
249 : georgekuan 1999 pps ")")
250 : georgekuan 2000 | ppTycI (LK.TC_TOKEN (tok, tyc)) =
251 : georgekuan 1999 (pps "TC_TOKEN(";
252 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
253 : georgekuan 2013 print "LK.token_name\n";
254 : georgekuan 2000 pps (LK.token_name tok);
255 : georgekuan 1999 pps ", ";
256 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
257 : georgekuan 2000 ppTyc' tyc;
258 : georgekuan 1999 pps ")")
259 : georgekuan 2000 | ppTycI (LK.TC_CONT tycs) =
260 : georgekuan 1999 (pps "TC_CONT(";
261 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
262 : georgekuan 2000 ppList' {sep=", ", pp=ppTyc'} tycs;
263 : georgekuan 1999 pps ")")
264 : georgekuan 2000 | ppTycI (LK.TC_IND (tyc, tycI)) =
265 : georgekuan 1999 (openHOVBox 1;
266 :     pps "TC_IND(";
267 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
268 : georgekuan 2000 ppTyc' tyc;
269 :     pps ", ";
270 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
271 : georgekuan 1999 ppTycI tycI;
272 :     pps ")";
273 :     closeBox())
274 : georgekuan 2000 | ppTycI (LK.TC_ENV (tyc, ol, nl, tenv)) =
275 : georgekuan 1999 (openHOVBox 1;
276 :     pps "TC_ENV(";
277 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
278 : georgekuan 2000 ppTyc' tyc;
279 : georgekuan 1999 pps ", ";
280 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
281 : georgekuan 1999 pps "ol = ";
282 :     pps (Int.toString ol);
283 :     pps ", ";
284 :     pps "nl = ";
285 :     pps (Int.toString nl);
286 :     pps ", ";
287 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
288 : georgekuan 2003 ppList' {sep=", ", pp=(ppTycEnvElem ppstrm)} (tycEnvFlatten tenv);
289 : georgekuan 1999 closeBox())
290 : georgekuan 2013 val _ = print "LK.tc_out 1 \n"
291 : georgekuan 1999 in ppTycI (LK.tc_out tycon)
292 : georgekuan 2000 end (* ppTyc *)
293 :    
294 : georgekuan 2003 fun ppTycEnv ppstrm (tycEnv : LK.tycEnv) =
295 :     let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm
296 :     in
297 :     openHOVBox 1;
298 :     pps "TycEnv(";
299 :     ppList ppstrm {sep=", ", pp=ppTycEnvElem ppstrm} (tycEnvFlatten tycEnv);
300 :     pps ")";
301 :     closeBox()
302 :     end (* function ppTycEnv *)
303 :    
304 : georgekuan 2000 end (* local *)
305 : georgekuan 1999
306 : georgekuan 1998 end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0