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/trunk/src/compiler/Elaborator/print/pptype.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/Elaborator/print/pptype.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1344 - (view) (download)

1 : blume 902 (* Copyright 1991 by AT&T Bell Laboratories *)
2 : macqueen 1344 (* Copyright 2003 by The SML/NJ Fellowship *)
3 :     (* pptype.sml *)
4 : blume 902
5 : macqueen 1344 (* modified to use SML/NJ Lib PP. [dbm, 7/30/03]) *)
6 :    
7 : blume 902 signature PPTYPE =
8 :     sig
9 :     val typeFormals : int -> string list
10 :     val tyvarPrintname : Types.tyvar -> string
11 : macqueen 1344 val ppTycon : StaticEnv.staticEnv -> PrettyPrint.stream
12 : blume 902 -> Types.tycon -> unit
13 : macqueen 1344 val ppTyfun : StaticEnv.staticEnv -> PrettyPrint.stream
14 : blume 902 -> Types.tyfun -> unit
15 : macqueen 1344 val ppType : StaticEnv.staticEnv -> PrettyPrint.stream
16 : blume 902 -> Types.ty -> unit
17 :     val ppDconDomain : (Types.dtmember vector * Types.tycon list)
18 :     -> StaticEnv.staticEnv
19 : macqueen 1344 -> PrettyPrint.stream -> Types.ty -> unit
20 :     val ppDataconTypes : StaticEnv.staticEnv -> PrettyPrint.stream
21 : blume 902 -> Types.tycon -> unit
22 :     val resetPPType : unit -> unit
23 : macqueen 1344 val ppFormals : PrettyPrint.stream -> int -> unit
24 : blume 902
25 :     val debugging : bool ref
26 :     val unalias : bool ref
27 :    
28 :     end (* signature PPTYPE *)
29 :    
30 :     structure PPType : PPTYPE =
31 :     struct
32 :    
33 :     local
34 :     structure SP = SymPath
35 : macqueen 1336 structure IP = InvPath
36 : blume 902 structure BT = BasicTypes
37 :     structure T = Types
38 :     structure TU = TypesUtil
39 :     structure PP = PrettyPrint
40 :     open Types PPUtil
41 :     in
42 :    
43 :     val debugging = ref false
44 :     val unalias = ref true
45 :    
46 :     fun bug s = ErrorMsg.impossible ("PPType: " ^ s)
47 : macqueen 1344 val pps = PP.string
48 : blume 902
49 :     fun C f x y = f y x
50 :    
51 :     val internals = ElabControl.internals
52 :    
53 : macqueen 1336 val unitPath = IP.extend(IP.empty,Symbol.tycSymbol "unit")
54 :    
55 : blume 902 fun boundTyvarName k =
56 :     let val a = Char.ord #"a"
57 :     in if k < 26
58 :     then String.str(Char.chr(k+a))
59 :     else implode[Char.chr(Int.div(k,26) + a),
60 :     Char.chr(Int.mod(k,26) + a)]
61 :     end
62 :    
63 :     fun metaTyvarName' k =
64 :     let val a = Char.ord #"Z" (* use reverse order for meta vars *)
65 :     in if k < 26
66 :     then String.str(Char.chr(a - k))
67 :     else implode[Char.chr(a - (Int.div(k,26))),
68 :     Char.chr(a - (Int.mod(k,26)))]
69 :     end
70 :    
71 :     fun typeFormals n =
72 :     let fun loop i =
73 :     if i>=n then []
74 :     else (boundTyvarName i)::loop(i+1)
75 :     in loop 0
76 :     end
77 :    
78 :     fun litKindPrintName (lk: T.litKind) =
79 :     case lk
80 :     of T.INT => "int" (* or "INT" *)
81 :     | T.WORD => "word" (* or "WORD" *)
82 :     | T.REAL => "real" (* or "REAL" *)
83 :     | T.CHAR => "char" (* or "CHAR" *)
84 :     | T.STRING => "string" (* or "STRING" *)
85 :    
86 :     local (* WARNING -- compiler global variables *)
87 :     val count = ref(~1)
88 :     val metaTyvars = ref([]:tyvar list)
89 :     in
90 :     fun metaTyvarName(tv: tyvar) =
91 :     let fun find([],_) =
92 :     (metaTyvars := tv::(!metaTyvars);
93 :     count := !count+1;
94 :     !count)
95 :     | find(tv'::rest,k) =
96 :     if tv = tv'
97 :     then !count - k
98 :     else find(rest,k+1)
99 :     in metaTyvarName' (find(!metaTyvars,0))
100 :     end
101 :     fun resetPPType() = (count := ~1; metaTyvars := [])
102 :     end
103 :    
104 :     fun tvHead (eq,base) =
105 :     (if eq then "''" else "'")^base
106 :    
107 :     fun annotate (name,annotation,depthOp) =
108 :     if !internals
109 :     then concat(name::"."::annotation::
110 :     (case depthOp
111 :     of SOME depth => ["[",(Int.toString depth),"]"]
112 :     | NONE => nil))
113 :     else name
114 :    
115 :     fun tyvarPrintname (tyvar) = let
116 :     fun prKind info =
117 :     case info of
118 :     INSTANTIATED(VARty(tyvar)) => tyvarPrintname tyvar
119 :     | INSTANTIATED _ => "<INSTANTIATED ?>"
120 :     | OPEN{depth,eq,kind} =>
121 :     tvHead(eq, annotate(metaTyvarName tyvar,
122 :     case kind of META => "M" | FLEX _ => "F",
123 :     SOME depth))
124 :     | UBOUND{name,depth,eq} =>
125 :     tvHead(eq,annotate(Symbol.name name,"U",SOME depth))
126 :     | LITERAL{kind,...} =>
127 :     annotate(litKindPrintName kind,"L",NONE)
128 :     | SCHEME eq =>
129 :     tvHead(eq,annotate(metaTyvarName tyvar,"S",NONE))
130 :     | TV_MARK _ => "<TV_MARK ?>"
131 :     in
132 :     prKind (!tyvar)
133 :     end
134 :    
135 :     (*
136 :     fun ppkind ppstrm kind =
137 :     pps ppstrm
138 :     (case kind
139 :     of PRIMITIVE _ => "PRIMITIVE" | FORMAL => "FORMAL"
140 :     | FLEXTYC _ => "FLEXTYC" | ABSTRACT _ => "ABSTYC"
141 :     | DATATYPE _ => "DATATYPE" | TEMP => "TEMP")
142 :     *)
143 :     fun ppkind ppstrm kind =
144 :     pps ppstrm
145 :     (case kind
146 :     of PRIMITIVE _ => "P" | FORMAL => "F"
147 :     | FLEXTYC _ => "X" | ABSTRACT _ => "A"
148 :     | DATATYPE _ => "D" | TEMP => "T")
149 :    
150 :     fun effectivePath(path,tyc,env) : string =
151 :     let fun tycPath (GENtyc{path,...} | DEFtyc{path,...} | PATHtyc{path,...}) =
152 :     SOME path
153 :     | tycPath _ = NONE
154 :     fun find(path,tyc) =
155 :     (findPath(path,
156 :     (fn tyc' => TU.equalTycon(tyc',tyc)),
157 :     (fn x => Lookup.lookTyc(env,x,
158 :     (fn _ => raise StaticEnv.Unbound)))))
159 :     fun search(path,tyc) =
160 :     let val (suffix,found) = find(path,tyc)
161 :     in if found then (suffix,true)
162 :     else if not (!unalias) then (suffix, false)
163 :     else case TU.unWrapDef1 tyc
164 :     of SOME tyc' =>
165 :     (case tycPath tyc'
166 :     of SOME path' =>
167 :     let val x as (suffix',found') = search(path',tyc')
168 :     in if found' then x
169 :     else (suffix,false)
170 :     end
171 :     | NONE => (suffix,false))
172 :     | NONE => (suffix,false)
173 :     end
174 :     val (suffix,found) = search(path,tyc)
175 :     val name = SP.toString(SP.SPATH suffix)
176 :     in if found
177 :     then name
178 :     else "?."^name
179 :     end
180 :    
181 :     val arrowStamp = BT.arrowStamp
182 :    
183 :     fun strength(ty) =
184 :     case ty
185 :     of VARty(ref(INSTANTIATED ty')) => strength(ty')
186 :     | CONty(tycon, args) =>
187 :     (case tycon
188 :     of GENtyc { stamp, kind = PRIMITIVE _, ... } =>
189 :     if Stamps.eq(stamp,arrowStamp) then 0 else 2
190 :     | RECORDtyc (_::_) => (* excepting type unit *)
191 :     if Tuples.isTUPLEtyc(tycon) then 1 else 2
192 :     | _ => 2)
193 :     | _ => 2
194 :    
195 :     fun ppEqProp ppstrm p =
196 :     let val a = case p
197 :     of NO => "NO"
198 :     | YES => "YES"
199 :     | IND => "IND"
200 :     | OBJ => "OBJ"
201 :     | DATA => "DATA"
202 :     | ABS => "ABS"
203 :     | UNDEF => "UNDEF"
204 :     in pps ppstrm a
205 :     end
206 :    
207 :     fun ppInvPath ppstream (InvPath.IPATH path: InvPath.path) =
208 : macqueen 1344 PP.string ppstream (SymPath.toString (SymPath.SPATH(rev path)))
209 : blume 902
210 :     fun ppTycon1 env ppstrm membersOp =
211 : macqueen 1344 let val {openHVBox,openHOVBox,closeBox,pps,break,...} = en_pp ppstrm
212 : blume 902 fun ppTyc (tyc as GENtyc { path, stamp, eq, kind, ... }) =
213 :     if !internals
214 : macqueen 1344 then (openHOVBox 1;
215 : blume 902 ppInvPath ppstrm path;
216 :     pps "[";
217 :     pps "G"; ppkind ppstrm kind; pps ";";
218 :     pps (Stamps.toShortString stamp);
219 :     pps ";";
220 :     ppEqProp ppstrm (!eq);
221 :     pps "]";
222 : macqueen 1344 closeBox())
223 : blume 902 else pps(effectivePath(path,tyc,env))
224 :     | ppTyc(tyc as DEFtyc{path,tyfun=TYFUN{body,...},...}) =
225 :     if !internals
226 : macqueen 1344 then (openHOVBox 1;
227 : blume 902 ppInvPath ppstrm path;
228 :     pps "["; pps "D;";
229 :     ppType env ppstrm body;
230 :     pps "]";
231 : macqueen 1344 closeBox())
232 : blume 902 else pps(effectivePath(path,tyc,env))
233 :     | ppTyc(RECORDtyc labels) =
234 :     ppClosedSequence ppstrm
235 : macqueen 1344 {front=C PP.string "{",
236 :     sep=fn ppstrm => (PP.string ppstrm ",";
237 :     PP.break ppstrm {nsp=0,offset=0}),
238 :     back=C PP.string "}",
239 :     style=INCONSISTENT,
240 : blume 902 pr=ppSym} labels
241 :    
242 :     | ppTyc (RECtyc n) =
243 :     (case membersOp
244 :     of SOME (members,_) =>
245 :     let val {tycname,dcons,...} = Vector.sub(members,n)
246 :     in ppSym ppstrm tycname
247 :     end
248 :     | NONE => pps (String.concat ["<RECtyc ",Int.toString n,">"]))
249 :    
250 :     | ppTyc (FREEtyc n) =
251 :     (case membersOp
252 :     of SOME (_, freetycs) =>
253 :     let val tyc = (List.nth(freetycs, n) handle _ =>
254 :     bug "unexpected freetycs in ppTyc")
255 :     in ppTyc tyc
256 :     end
257 :     | NONE =>
258 :     pps (String.concat ["<FREEtyc ",Int.toString n,">"]))
259 :    
260 :     | ppTyc (tyc as PATHtyc{arity,entPath,path}) =
261 :     if !internals
262 : macqueen 1344 then (openHOVBox 1;
263 : blume 902 ppInvPath ppstrm path; pps "[P;";
264 :     pps (EntPath.entPathToString entPath);
265 :     pps "]";
266 : macqueen 1344 closeBox())
267 : blume 902 else ppInvPath ppstrm path
268 :    
269 :     | ppTyc ERRORtyc = pps "[E]"
270 :     in ppTyc
271 :     end
272 :    
273 :    
274 :     and ppType1 env ppstrm (ty: ty, sign: T.polysign,
275 :     membersOp: (T.dtmember vector * T.tycon list) option) : unit =
276 : macqueen 1344 let val {openHVBox,openHOVBox,closeBox,pps,break,newline} = en_pp ppstrm
277 : blume 902 fun prty ty =
278 :     case ty
279 :     of VARty(ref(INSTANTIATED ty')) => prty(ty')
280 :     | VARty(tv) => ppTyvar tv
281 :     | IBOUND n =>
282 :     let val eq = List.nth(sign,n)
283 :     handle Subscript => false
284 :     in pps (tvHead(eq,(boundTyvarName n)))
285 :     end
286 :     | CONty(tycon, args) => let
287 :     fun otherwise () =
288 : macqueen 1344 (openHOVBox 2;
289 : blume 902 ppTypeArgs args;
290 : macqueen 1344 break{nsp=0,offset=0};
291 : blume 902 ppTycon1 env ppstrm membersOp tycon;
292 : macqueen 1344 closeBox())
293 : blume 902 in
294 :     case tycon
295 :     of GENtyc { stamp, kind, ... } =>
296 :     (case kind of
297 :     PRIMITIVE _ =>
298 :     if Stamps.eq(stamp,arrowStamp)
299 :     then case args
300 :     of [domain,range] =>
301 : macqueen 1344 (openHVBox 0;
302 : blume 902 if strength domain = 0
303 : macqueen 1344 then (openHVBox 1;
304 : blume 902 pps "(";
305 :     prty domain;
306 :     pps ")";
307 : macqueen 1344 closeBox())
308 : blume 902 else prty domain;
309 : macqueen 1344 break{nsp=1,offset=0};
310 : blume 902 pps "-> ";
311 :     prty range;
312 : macqueen 1344 closeBox())
313 : blume 902 | _ => bug "CONty:arity"
314 : macqueen 1344 else (openHOVBox 2;
315 : blume 902 ppTypeArgs args;
316 : macqueen 1344 break{nsp=0,offset=0};
317 : blume 902 ppTycon1 env ppstrm membersOp tycon;
318 : macqueen 1344 closeBox())
319 : blume 902 | _ => otherwise ())
320 :     | RECORDtyc labels =>
321 :     if Tuples.isTUPLEtyc(tycon)
322 :     then ppTUPLEty args
323 :     else ppRECORDty(labels, args)
324 :     | _ => otherwise ()
325 :     end
326 :     | POLYty{sign,tyfun=TYFUN{arity,body}} =>
327 :     ppType1 env ppstrm (body,sign, membersOp)
328 :     | WILDCARDty => pps "_"
329 :     | UNDEFty => pps "undef"
330 :    
331 :     and ppTypeArgs [] = ()
332 :     | ppTypeArgs [ty] =
333 :     (if strength ty <= 1
334 : macqueen 1344 then (openHOVBox 1;
335 : blume 902 pps "(";
336 :     prty ty;
337 :     pps ")";
338 : macqueen 1344 closeBox())
339 : blume 902 else prty ty;
340 : macqueen 1344 break{nsp=1,offset=0})
341 : blume 902 | ppTypeArgs tys =
342 :     ppClosedSequence ppstrm
343 : macqueen 1344 {front=C PP.string "(",
344 :     sep=fn ppstrm => (PP.string ppstrm ",";
345 :     PP.break ppstrm {nsp=0,offset=0}),
346 :     back=C PP.string ") ",
347 :     style=INCONSISTENT,
348 : blume 902 pr=fn _ => fn ty => prty ty}
349 :     tys
350 :    
351 : macqueen 1336 and ppTUPLEty [] = pps(effectivePath(unitPath,RECORDtyc [],env))
352 : blume 902 | ppTUPLEty tys =
353 :     ppSequence ppstrm
354 : macqueen 1344 {sep = fn ppstrm => (PP.break ppstrm {nsp=1,offset=0};
355 :     PP.string ppstrm "* "),
356 :     style = INCONSISTENT,
357 : blume 902 pr = (fn _ => fn ty =>
358 :     if strength ty <= 1
359 : macqueen 1344 then (openHOVBox 1;
360 : blume 902 pps "(";
361 :     prty ty;
362 :     pps ")";
363 : macqueen 1344 closeBox())
364 : blume 902 else prty ty)}
365 :     tys
366 :    
367 : macqueen 1344 and ppField(lab,ty) = (openHVBox 0;
368 : blume 902 ppSym ppstrm lab;
369 :     pps ":";
370 :     prty ty;
371 : macqueen 1344 closeBox())
372 : blume 902
373 : macqueen 1336 and ppRECORDty([],[]) = pps(effectivePath(unitPath,RECORDtyc [],env))
374 :     (* this case should not occur *)
375 : blume 902 | ppRECORDty(lab::labels, arg::args) =
376 : macqueen 1344 (openHOVBox 1;
377 : blume 902 pps "{";
378 :     ppField(lab,arg);
379 :     ListPair.app
380 : macqueen 1344 (fn field => (pps ","; break{nsp=1,offset=0}; ppField field))
381 : blume 902 (labels,args);
382 :     pps "}";
383 : macqueen 1344 closeBox())
384 : blume 902 | ppRECORDty _ = bug "PPType.ppRECORDty"
385 :    
386 :     and ppTyvar (tv as (ref info) :tyvar) :unit =
387 :     let val printname = tyvarPrintname tv
388 :     in case info
389 :     of OPEN{depth,eq,kind} =>
390 :     (case kind
391 :     of FLEX fields =>
392 :     (case fields
393 :     of [] => (pps "{"; pps printname; pps "}")
394 :     | field::fields =>
395 : macqueen 1344 (openHOVBox 1;
396 : blume 902 pps "{";
397 :     ppField field;
398 :     app (fn x => (pps ",";
399 : macqueen 1344 break{nsp=1,offset=0};
400 : blume 902 ppField x))
401 :     fields;
402 :     pps ";";
403 : macqueen 1344 break{nsp=1,offset=0};
404 : blume 902 pps printname;
405 :     pps "}";
406 : macqueen 1344 closeBox()))
407 : blume 902 | _ => pps printname)
408 :     | _ => pps printname
409 :     end
410 :     in prty ty
411 :     end (* ppType1 *)
412 :    
413 :     and ppType (env:StaticEnv.staticEnv) ppstrm (ty:ty) : unit =
414 : macqueen 1344 (PP.openHOVBox ppstrm (PP.Rel 1);
415 : blume 902 ppType1 env ppstrm (ty,[],NONE);
416 : macqueen 1344 PP.closeBox ppstrm)
417 : blume 902
418 :     fun ppDconDomain members (env:StaticEnv.staticEnv)
419 :     ppstrm (ty:ty) : unit =
420 : macqueen 1344 (PP.openHOVBox ppstrm (PP.Rel 1);
421 : blume 902 ppType1 env ppstrm (ty,[],SOME members);
422 : macqueen 1344 PP.closeBox ppstrm)
423 : blume 902
424 :     fun ppTycon env ppstrm tyc = ppTycon1 env ppstrm NONE tyc
425 :    
426 :     fun ppTyfun env ppstrm (TYFUN{arity,body}) =
427 : macqueen 1344 let val {openHVBox, openHOVBox, closeBox, pps, break,...} = en_pp ppstrm
428 :     in openHOVBox 2;
429 : blume 902 pps "TYFUN({arity=";
430 : macqueen 1344 ppi ppstrm arity; ppcomma ppstrm;
431 :     break{nsp=0,offset=0};
432 : blume 902 pps "body=";
433 :     ppType env ppstrm body;
434 :     pps "})";
435 : macqueen 1344 closeBox()
436 : blume 902 end
437 :    
438 :     fun ppFormals ppstrm =
439 :     let fun ppF 0 = ()
440 :     | ppF 1 = pps ppstrm " 'a"
441 :     | ppF n = (pps ppstrm " ";
442 :     ppTuple ppstrm (fn ppstrm => fn s => pps ppstrm ("'"^s))
443 :     (typeFormals n))
444 :     in ppF
445 :     end
446 :    
447 :     fun ppDataconTypes env ppstrm (GENtyc { kind = DATATYPE dt, ... }) =
448 :     let val {index,freetycs,family={members,...},...} = dt
449 : macqueen 1344 val {openHVBox, openHOVBox, closeBox, pps, break,...} = en_pp ppstrm
450 : blume 902 val {dcons,...} = Vector.sub(members,index)
451 :     in
452 : macqueen 1344 openHVBox 0;
453 : blume 902 app (fn {name,domain,...} =>
454 :     (pps (Symbol.name name); pps ":";
455 :     case domain
456 :     of SOME ty =>
457 :     ppType1 env ppstrm (ty,[],SOME (members,freetycs))
458 :     | NONE => pps "CONST";
459 : macqueen 1344 break{nsp=1,offset=0}))
460 : blume 902 dcons;
461 : macqueen 1344 closeBox()
462 : blume 902 end
463 :     | ppDataconTypes env ppstrm _ = bug "ppDataconTypes"
464 :    
465 :     end (* toplevel local *)
466 :     end (* structure PPType *)

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