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

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