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 2003 - (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 :     pps "(";
30 :     pp elem;
31 :     pps ")";
32 :     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 :     (case LK.tcSplit(tycenv) of
65 :     NONE => []
66 :     | SOME(elem, rest) => elem::tycEnvFlatten(rest))
67 :    
68 :     fun ppTycEnvElem ppstrm (tycop, i) =
69 :     let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm
70 :     in
71 :     openHOVBox 1;
72 :     pps "(";
73 :     (case tycop of
74 :     NONE => pps "*"
75 :     | SOME(tycs) => ppList ppstrm {sep=",", pp=ppTyc ppstrm} tycs);
76 :     pps ", ";
77 :     PP.break ppstrm {nsp = 1, offset=0};
78 :     ppi ppstrm i;
79 :     pps ")";
80 :     closeBox()
81 :     end (* function ppTycEnvElem *)
82 :    
83 :     and ppTyc ppstrm (tycon : LK.tyc) =
84 : georgekuan 1999 (* FLINT variables are represented using deBruijn indices *)
85 : georgekuan 2000 let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm
86 :     (* eta-expansion of ppList to avoid
87 :     value restriction *)
88 :     val ppList' : {pp:'a -> unit, sep: string} -> 'a list -> unit = fn x => ppList ppstrm x
89 :     val ppTKind' = ppTKind ppstrm
90 :     val ppTyc' = ppTyc ppstrm
91 :     fun ppTycI (LK.TC_VAR(depth, cnt)) =
92 : georgekuan 1999 (pps "TC_VAR(";
93 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
94 : georgekuan 1999 (* depth is a deBruijn index set in elabmod.sml/instantiate.sml *)
95 :     pps (DebIndex.di_print depth);
96 :     pps ",";
97 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
98 : georgekuan 2003 (* cnt is computed in instantiate.sml sigToInst or
99 :     alternatively may be simply the IBOUND index *)
100 : georgekuan 1999 pps (Int.toString cnt);
101 :     pps ")")
102 :     (* Named tyc VAR; is actually an lvar *)
103 :     | ppTycI (LK.TC_NVAR tvar) =
104 :     (pps "TC_NVAR(";
105 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
106 : georgekuan 1999 pps (Int.toString tvar);
107 :     pps ")")
108 :     | ppTycI (LK.TC_PRIM primtycon) =
109 :     (pps "TC_PRIM(";
110 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
111 : georgekuan 1999 pps (PT.pt_print primtycon);
112 :     pps ")")
113 :     | ppTycI (LK.TC_FN (argTkinds, resultTyc)) =
114 :     (openHOVBox 1;
115 :     pps "TC_FN(";
116 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
117 : georgekuan 2000 ppList' {sep="* ", pp=ppTKind'} argTkinds;
118 : georgekuan 1999 pps ",";
119 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
120 : georgekuan 2000 ppTyc' resultTyc;
121 : georgekuan 1999 pps ")";
122 :     closeBox())
123 :     | ppTycI (LK.TC_APP(contyc, tys)) =
124 :     (openHOVBox 1;
125 :     pps "TC_APP(";
126 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
127 : georgekuan 2000 ppTyc' contyc;
128 : georgekuan 1999 pps ",";
129 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
130 : georgekuan 2000 ppList' {sep="* ", pp=ppTyc'} tys;
131 : georgekuan 1999 pps ")";
132 :     closeBox())
133 :     | ppTycI (LK.TC_SEQ tycs) =
134 :     (openHOVBox 1;
135 :     pps "TC_SEQ(";
136 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
137 : georgekuan 2000 ppList' {sep=", ", pp=ppTyc'} tycs;
138 : georgekuan 1999 pps ")";
139 :     closeBox())
140 :     | ppTycI (LK.TC_PROJ(tycon, index)) =
141 :     (openHOVBox 1;
142 :     pps "TC_PROJ(";
143 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
144 : georgekuan 2000 ppTyc' tycon;
145 : georgekuan 1999 pps ", ";
146 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
147 : georgekuan 1999 pps (Int.toString index);
148 :     pps ")";
149 :     closeBox())
150 :     | ppTycI (LK.TC_SUM(tycs)) =
151 :     (pps "TC_SUM(";
152 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
153 : georgekuan 2000 ppList' {sep=", ", pp=ppTyc'} tycs;
154 : georgekuan 1999 pps ")")
155 :     (* TC_FIX is a recursive DATATYPE *)
156 :     | ppTycI (LK.TC_FIX((numStamps, datatypeFamily, freetycs), index)) =
157 :     (openHOVBox 1;
158 :     pps "TC_FIX(";
159 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
160 : georgekuan 1999 pps "nStamps = ";
161 :     pps (Int.toString numStamps);
162 : georgekuan 2002 pps ",";
163 :     PP.break ppstrm {nsp=1, offset=0};
164 : georgekuan 1999 pps "datatypeFamily = ";
165 : georgekuan 2000 ppTyc' datatypeFamily;
166 : georgekuan 1999 pps ", ";
167 : georgekuan 2002 PP.break ppstrm {nsp=1, offset=0};
168 : georgekuan 1999 pps "freeTycs = ";
169 : georgekuan 2000 ppList' {sep = ", ", pp = ppTyc'} freetycs;
170 : georgekuan 1999 pps ", ";
171 : georgekuan 2002 PP.break ppstrm {nsp=1, offset=0};
172 : georgekuan 1999 pps "index = ";
173 :     pps (Int.toString index);
174 :     pps ")";
175 :     closeBox())
176 :     | ppTycI (LK.TC_ABS tyc) =
177 :     (pps "TC_ABS(";
178 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
179 : georgekuan 2000 ppTyc' tyc;
180 : georgekuan 1999 pps ")")
181 :     | ppTycI (LK.TC_BOX tyc) =
182 :     (pps "TC_BOX(";
183 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
184 : georgekuan 2000 ppTyc' tyc;
185 : georgekuan 1999 pps ")")
186 :     (* rflag is a tuple kind template, a singleton datatype RF_TMP *)
187 :     | ppTycI (LK.TC_TUPLE (rflag, tycs)) =
188 :     (pps "TC_TUPLE(";
189 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
190 : georgekuan 2000 ppList' {sep="* ", pp=ppTyc'} tycs;
191 : georgekuan 1999 pps ")")
192 :     (* fflag records the calling convention: either FF_FIXED or FF_VAR *)
193 : georgekuan 2000 | ppTycI (LK.TC_ARROW (fflag, argTycs, resTycs)) =
194 : georgekuan 1999 (pps "TC_ARROW(";
195 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
196 : georgekuan 1999 (case fflag of LK.FF_FIXED => pps "FF_FIXED"
197 : georgekuan 2000 | LK.FF_VAR(b1, b2) => (pps "<FF_VAR>" (*;
198 :     ppBool b1;
199 : georgekuan 1999 pps ", ";
200 : georgekuan 2000 ppBool b2;
201 :     pps ")"*) ));
202 :     ppList' {sep="* ", pp=ppTyc'} argTycs;
203 : georgekuan 1999 pps ", ";
204 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
205 : georgekuan 2000 ppList' {sep="* ", pp=ppTyc'} resTycs;
206 : georgekuan 1999 pps ")")
207 :     (* According to ltykernel.sml comment, this arrow tyc is not used *)
208 : georgekuan 2000 | ppTycI (LK.TC_PARROW (argTyc, resTyc)) =
209 : georgekuan 1999 (pps "TC_PARROW(";
210 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
211 : georgekuan 2000 ppTyc' argTyc;
212 : georgekuan 1999 pps ", ";
213 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
214 : georgekuan 2000 ppTyc' resTyc;
215 : georgekuan 1999 pps ")")
216 : georgekuan 2000 | ppTycI (LK.TC_TOKEN (tok, tyc)) =
217 : georgekuan 1999 (pps "TC_TOKEN(";
218 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
219 : georgekuan 2000 pps (LK.token_name tok);
220 : georgekuan 1999 pps ", ";
221 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
222 : georgekuan 2000 ppTyc' tyc;
223 : georgekuan 1999 pps ")")
224 : georgekuan 2000 | ppTycI (LK.TC_CONT tycs) =
225 : georgekuan 1999 (pps "TC_CONT(";
226 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
227 : georgekuan 2000 ppList' {sep=", ", pp=ppTyc'} tycs;
228 : georgekuan 1999 pps ")")
229 : georgekuan 2000 | ppTycI (LK.TC_IND (tyc, tycI)) =
230 : georgekuan 1999 (openHOVBox 1;
231 :     pps "TC_IND(";
232 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
233 : georgekuan 2000 ppTyc' tyc;
234 :     pps ", ";
235 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
236 : georgekuan 1999 ppTycI tycI;
237 :     pps ")";
238 :     closeBox())
239 : georgekuan 2000 | ppTycI (LK.TC_ENV (tyc, ol, nl, tenv)) =
240 : georgekuan 1999 (openHOVBox 1;
241 :     pps "TC_ENV(";
242 : georgekuan 2003 PP.break ppstrm {nsp=1,offset=1};
243 : georgekuan 2000 ppTyc' tyc;
244 : georgekuan 1999 pps ", ";
245 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
246 : georgekuan 1999 pps "ol = ";
247 :     pps (Int.toString ol);
248 :     pps ", ";
249 :     pps "nl = ";
250 :     pps (Int.toString nl);
251 :     pps ", ";
252 : georgekuan 2002 PP.break ppstrm {nsp=1,offset=0};
253 : georgekuan 2003 ppList' {sep=", ", pp=(ppTycEnvElem ppstrm)} (tycEnvFlatten tenv);
254 : georgekuan 1999 closeBox())
255 :     in ppTycI (LK.tc_out tycon)
256 : georgekuan 2000 end (* ppTyc *)
257 :    
258 : georgekuan 2003 fun ppTycEnv ppstrm (tycEnv : LK.tycEnv) =
259 :     let val {openHOVBox, closeBox, pps, ...} = en_pp ppstrm
260 :     in
261 :     openHOVBox 1;
262 :     pps "TycEnv(";
263 :     ppList ppstrm {sep=", ", pp=ppTycEnvElem ppstrm} (tycEnvFlatten tycEnv);
264 :     pps ")";
265 :     closeBox()
266 :     end (* function ppTycEnv *)
267 :    
268 : georgekuan 2000 end (* local *)
269 : georgekuan 1999
270 : georgekuan 1998 end

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