DIRECTORY
AMTypes USING  [Class, Domain, Error, First, Ground, Index, IndexToDefaultInitialValue, IndexToName, IndexToType, Last, NComponents, NValues, Range, ReferentStatus, IsComputed, IsMachineDependent, IsOverlaid, IsPacked, TypeClass, TypeToName, UnderType, UnderClass, Value, TV, TVToType],
BackStop USING [Call],
IO USING [STREAM, PutRope, PutChar],
PrintTV USING [Print, RegisterClassPrintProc],
Rope USING [Fetch, ROPE, Equal, Length, IsEmpty, Cat, Concat],
SafeStorage USING [nullType, Type, EquivalentTypes],
StructuredStreams USING [Begin, End, Bp]
;

PrettyTypePrinter: CEDAR MONITOR
IMPORTS AMTypes, BackStop, IO, PrintTV, Rope, SafeStorage, StructuredStreams
=  BEGIN OPEN Rope, SafeStorage, AMTypes, StructuredStreams;

MakePiece: PROC [put: IO.STREAM, Write: PROC, united: BOOL _ FALSE] = {
Bp[put, IF united THEN united ELSE lookLeft, indent];
Begin[put];
Write[ !UNWIND => End[put] ];
End[put];
};
indent: INTEGER _ 3;

UnderBoolean: Type _ LOOPHOLE[CODE[BOOL]]; 

PrettyPrintType: PROC [tv: TV, data: REF ANY, stream: IO.STREAM, depth: INT _ 4, width: INT _ 32, verbose: BOOL _ FALSE] RETURNS [useOld: BOOL _ FALSE] --PrintTV.TVPrintProc-- = {
type: Type = TVToType[tv];
PrintType[type, stream, depth, width, verbose];
};

PrintType: PROC [type: Type, put: IO.STREAM, depth: INT _ 4, width: INT _ 32, verbose: BOOL _ FALSE] = {
PutReadonly: PROC [t: Type] = {
IF ReferentStatus[t] = readOnly THEN put.PutRope["READONLY "];
};
PutInnards: PROC [type: Type, start: INT _ 1] = {
n: INT _ 0;
class: Class _ TypeClass[type];
indexStart: NAT _ start;
sep: ROPE _ NIL;
SELECT class FROM
union => {
NCases: PROC [type: Type] RETURNS [n: INT] = {
SELECT AMTypes.UnderClass[type] FROM
record, structure => {
last: INT _ AMTypes.NComponents[type];
lastType: Type _ nullType;
IF last = 0 THEN GO TO noCases;
lastType _ AMTypes.IndexToType[type, last];
IF AMTypes.UnderClass[lastType] # union THEN GO TO noCases;
type _ lastType;
};
union => {};
ENDCASE => GO TO noCases;
n _ AMTypes.NValues[AMTypes.Domain[type]];
WHILE n > 0 DO
[] _ AMTypes.IndexToType[type, n ! AMTypes.Error =>
IF reason = badIndex THEN {n _ n - 1; LOOP}
];
RETURN;
ENDLOOP;
EXITS
noCases => ERROR AMTypes.Error[typeFault, NIL, type];
};
tagType: Type _ nullType;
sep _ " => ";
indexStart _ 1;
put.PutRope["SELECT "];
tagType _ AMTypes.Domain[type];
n _ NCases[type];
IF IsOverlaid[type]
THEN put.PutRope["OVERLAID "]
ELSE put.PutRope[Rope.Concat[AMTypes.IndexToName[type, 0], ": "]];
PrintType[tagType, put, depth, width];
put.PutRope[" FROM "];
};
record, structure => {sep _ ": "; n _ AMTypes.NComponents[type]};
ENDCASE => {PrintType[type, put, depth, width]; RETURN};
FOR i: INT IN [indexStart..n] DO
subType: Type _ nullType;
subClass: Class _ nil;
WriteSepAndType: PROC = {put.PutRope[sep]; WriteType[]};
WriteType: PROC = {
IF class = union
THEN {
put.PutRope["["];
PutInnards[subType, start];
put.PutRope["]"];
}
ELSE SELECT subClass FROM
union => PutInnards[subType, i];       
sequence => PrintType[subType, put, depth, width];
ENDCASE => PrintType[subType, put, depth-1, width];
};
WriteInitialization: PROC = {
IF class # union THEN SELECT subClass FROM
union => NULL;
sequence => NULL;
ENDCASE => {
defaultTV: TV _ NIL;
defaultTV _ IndexToDefaultInitialValue[type, i ! ANY => CONTINUE];
IF defaultTV # NIL THEN {
put.PutRope[" _ "];
PrintTV.Print[defaultTV, put, depth, width, verbose];
};
};
};
subInner: PROC = {
name: ROPE = IndexToName[type, i];
named: BOOL = NOT name.IsEmpty[];
subType _ IndexToType[type, i];
subClass _ TypeClass[subType];
IF named THEN {
put.PutRope[name];
MakePiece[put, WriteSepAndType, TRUE];
MakePiece[put, WriteInitialization, TRUE];
}
ELSE {
WriteType[];
MakePiece[put, WriteInitialization];
};
};
WriteField: PROC = {
msg: ROPE _ NIL;
msg _ BackStop.Call[subInner];
IF msg # NIL THEN put.PutRope[Rope.Cat["--{", msg, "}--"]];
};
IF i > indexStart THEN put.PutRope[", "]; 
IF i > width AND i < n THEN {put.PutRope["..."]; EXIT};
MakePiece[put, WriteField];
ENDLOOP;
IF class = union THEN put.PutRope[" ENDCASE"];
}; 
class: Class _ nil;
innerPut: PROC = {
IF depth <= 0 THEN {put.PutRope["..."]; RETURN};
class _ TypeClass[type];
SELECT class FROM

definition => {
mod: REF ROPE _ NEW[ROPE _ NIL];
name: ROPE _ TypeToName[type, mod];
length: INT = mod^.Length[];
IF length # 0 THEN -- put out module name unless type name is all caps.
FOR i: INT IN [0..Rope.Length[name]) DO
IF Rope.Fetch[name, i] NOT IN ['A..'Z] THEN {put.PutRope[Rope.Cat[mod^, "."]]; EXIT};
REPEAT
FINISHED => IF Rope.Equal[name, "LORA"] THEN { -- sorry Russ. 
PrintType[UnderType[type], put, depth, width, verbose];
RETURN;
};
ENDLOOP;
put.PutRope[name];
IF NOT name.IsEmpty[] AND verbose THEN
FOR l: LIST OF ROPE _ everybodyKnowsThese, l.rest UNTIL l = NIL DO
IF Rope.Equal[l.first, name] THEN EXIT;
REPEAT
FINISHED =>
{put.PutRope[": TYPE = "];
PrintType[UnderType[type], put, depth, width, verbose];
};
ENDLOOP;
};

cardinal => put.PutRope["CARDINAL"];

longCardinal => put.PutRope["LONG CARDINAL"];

integer => put.PutRope["INTEGER"];

longInteger => put.PutRope["INT"];

real => put.PutRope["REAL"];

character => put.PutRope["CHAR"];

atom => put.PutRope["ATOM"];

rope => put.PutRope["ROPE"];

list => {
put.PutRope["LIST OF "];
PrintType[IndexToType[Range[type], 1], put, depth, width];
};

ref => {
range: Type _ Range[type];
put.PutRope["REF "];
PutReadonly[type];
IF range # nullType THEN {PrintType[range, put, depth, width]};
IF verbose THEN
SELECT TypeClass[UnderType[range]] FROM
record, structure =>
{put.PutRope["; \n"];
PrintType[range, put, depth, width];
put.PutRope[": TYPE = "];
PrintType[UnderType[range], put, depth, width]};
ENDCASE;
};

pointer, longPointer, basePointer, relativePointer =>  {
range: Type _ Range[type];
SELECT class FROM
longPointer => put.PutRope["LONG "];
relativePointer => put.PutRope["RELATIVE "];
basePointer => put.PutRope["LONG BASE "];
ENDCASE;
SELECT TRUE FROM
range = nullType OR TypeClass[range] = unspecified => put.PutRope["POINTER"];
EquivalentTypes[range, CODE[StringBody]] => put.PutRope["STRING"];
ENDCASE =>
{put.PutRope["POINTER TO "];
SELECT class FROM
longPointer, pointer => PutReadonly[type];
ENDCASE;
PrintType[range, put, depth, width]};
};

descriptor, longDescriptor => {
range: Type _ nullType;
IF class = longPointer THEN put.PutRope["LONG "];
put.PutRope["DESCRIPTOR"];
range _ Range[type];
IF range # nullType AND TypeClass[range] # unspecified THEN
{put.PutRope[" TO "];
PutReadonly[type];
PrintType[range, put, depth, width]};
};

procedure, signal, error, program, port =>  {
argsType, rtnsType: Type _ nullType;
prefix: ROPE _
SELECT class FROM
procedure => "PROC", signal => "SIGNAL", error => "ERROR",
program => "PROGRAM" , port => "PORT", ENDCASE => "??";     
WriteArg: PROC = {
PrintType[argsType, put, depth-1, width]
};
WriteRtn: PROC = {
put.PutRope["RETURNS "];
PrintType[rtnsType, put, depth-1, width];
};
put.PutRope[prefix];
argsType _ Domain[type];
IF argsType # nullType THEN {
put.PutChar[' ];
MakePiece[put, WriteArg];
};
SELECT class FROM
procedure, signal => {
rtnsType _ Range[type];
IF rtnsType # nullType THEN {
put.PutChar[' ];
MakePiece[put, WriteRtn];
};
};
ENDCASE;
}; 

enumerated =>  {
n: INT _ 0;
md: BOOL _ IsMachineDependent[type];
IF type = UnderBoolean THEN {put.PutRope["BOOL"]; RETURN};
IF IsMachineDependent[type] THEN put.PutRope["MACHINE DEPENDENT "];
put.PutRope["{"];
FOR i: INT IN [1..NValues[type]] DO
WriteElt: PROC = {
PrintTV.Print[Value[type, i], put];
};
IF i > 1 THEN {put.PutChar[', ]; put.PutChar[' ]};
IF i > width THEN {put.PutRope["..."]; EXIT};
MakePiece[put, WriteElt];
ENDLOOP;
put.PutRope["}"];
};

subrange =>  {
ENABLE Error => IF reason = rangeFault THEN {put.PutRope["0..0)"]; CONTINUE};
IF verbose AND depth > 1 THEN PrintType[Ground[type], put, depth-1, width];
put.PutChar['[];
PrintTV.Print[First[type], put, depth, width];
put.PutRope[".."];
PrintTV.Print[Last[type], put, depth, width];
put.PutChar[']];
};

union =>
put.PutRope["UNION??"];

sequence => {
IF IsComputed[type] THEN put.PutRope["COMPUTED "];
IF IsPacked[type] THEN put.PutRope["PACKED "];
put.PutRope["SEQUENCE "];
PrintType[Domain[type], put, depth-1, width];
put.PutRope[" OF "];
PrintType[Range[type], put, depth-1, width];
};

record, structure => {
IF class = record THEN put.PutRope["RECORD"];
IF depth < 2 THEN {put.PutRope["[...]"]; RETURN};
put.PutChar['[];
PutInnards[type];
put.PutChar[']];
};

array =>  {
IF IsPacked[type] THEN put.PutRope["PACKED "];
put.PutRope["ARRAY "];
PrintType[Domain[type], put, depth-1, width];
put.PutRope[" OF "];
PrintType[Range[type], put, depth-1, width];
};

countedZone => put.PutRope["ZONE"];

uncountedZone => put.PutRope["UNCOUNTED ZONE"];

nil => put.PutRope["nullType"];

unspecified => put.PutRope["UNSPECIFIED"];

process => put.PutRope["PROCESS"];

type => put.PutRope["TYPE"];

opaque => put.PutRope["OPAQUE"];

any => put.PutRope["ANY"];

globalFrame => put.PutRope["GF??"];

localFrame => put.PutRope["LF??"];

ENDCASE => put.PutRope["??"];

};
msg: ROPE _ BackStop.Call[innerPut];
IF msg # NIL THEN
put.PutRope[Rope.Cat["--{", msg, "}--"]];
};

everybodyKnowsThese: LIST OF ROPE _ LIST["INT", "REAL", "ROPE", "ATOM", "BOOL", "CHAR"];

Setup: PROC =
BEGIN
PrintTV.RegisterClassPrintProc[class: type, proc: PrettyPrintType];
END;

Setdown: PROC =
BEGIN
PrintTV.RegisterClassPrintProc[class: type, proc: NIL];
END;

Setup[];


END.  
September 1, 1982 10:57 am fixed bug in PrintType so that LONG STRING would print correctly.

September 14, 1982 2:15 pm added 3.4 operations for IsPacked, IsMachineDependent, etc.
August 16, 1985 11:35:04 am PDT added everybodyKnowsThese check so that things like 3.2? didnt print out is of type REAL: TYPE = REAL

ΚPrettyTypePrinter.mesa
Copyright c 1985 by Xerox Corporation.  All rights reserved.
Russ Atkinson, February 12, 1985 2:08:53 pm PST
Warren Teitelman, January 6, 1983 7:22 pm
Paul Rovner, July 13, 1983 5:39 pm
Spreitzer, September 20, 1985 10:20:45 am PDT
Mike Spreitzer July 30, 1986 7:53:05 pm PDT
this procedure returns the number of cases for a variant record. we need this proc because the number of cases is sometimes less than the number of values for the domain type. ERROR AMTypes.Error[typeFault] is raised when the type is not right
output the SELECT stuff
the subType must be a record or structure which describes the bound variant type (so be careful where you start)
be prepared: rttypes bug when NValues[...] > LAST[CARDINAL]
now fetch and print the element (if possible)
empty subrange causes First to raise a RangeFault.
Spreitzer, August 16, 1985 11:27:22 am PDT
Moved from PrintTV>PrintTypeImpl.Mesa!2 of February 12, 1985 2:08:54 pm PST to PrettyPrint>PrettyTypePrinter.  Added StructuredStreams bracketing in PutInner and listing of enumeration values.
changes to: DIRECTORY, PrintTypeImpl, PrintType, PutReadonly (local of PrintType), PutInnards (local of PrintType), innerPut (local of PrintType)

Κ|–
"Mesa" style˜
codeš
Οc™Kšœ
Οm
œ1™<Kš
/™/Kš
)™)Kš
"™"K™-K™+—K˜š
Οk	˜	KšœŸœƒŸœ
˜žKšœ	Ÿœ˜KšŸœ
ŸœŸœŸœ	˜$KšœŸœ!˜.KšœŸœ	Ÿœ'˜>KšœŸœ#˜4KšœŸœ˜(K˜
K˜—šΠbxœŸœ
Ÿ˜ KšŸœŸœ/˜LKšœŸœ
Ÿœ/˜<—K˜šΟn	œŸœŸœ
Ÿœ‘œŸœ
ŸœŸœ˜GKšœŸœŸœŸœ˜5K˜KšœŸœ˜K˜	K˜KšœŸœ˜—K˜Kš‘œ	Ÿœ
Ÿœ
Ÿœ˜+K˜š‘œŸœŸœŸœ
Ÿœ
Ÿœ
Ÿœ	Ÿœ
ŸœŸœŸœŸœ
ŸœŸœœ˜³
Kš
œ˜K˜/Kš
œ˜—K˜š‘	œŸœŸœ
Ÿœ	Ÿœ
ŸœŸœŸœ˜hš‘œŸœ˜KšŸœŸœ˜>K˜—š‘
œŸœŸœ	˜1KšœŸœ˜K˜KšœŸœ	˜KšœŸœŸœ
˜šŸœŸ˜˜
š‘œŸœŸœŸœ˜.Kš
œσ
™σ
šŸœŸ˜$˜KšœŸœ˜&K˜KšŸœ
Ÿœ
Ÿœ
Ÿœ	˜K˜+KšŸœ&Ÿœ
Ÿœ
Ÿœ	˜;K˜K˜—K˜KšŸœŸœ
Ÿœ	˜—K˜*šŸœŸ˜˜3KšŸœŸœ
Ÿœ
˜+Kš
œ˜—KšŸœ
˜KšŸœ
˜—š
Ÿ˜KšœŸœŸœ˜5—K˜—K˜K˜
K˜Kš
™K˜K˜K˜šŸœ˜KšŸœ˜KšŸœ>˜B—K˜&K˜K˜—K˜AKšŸœ)Ÿœ˜8—šŸœŸœ
ŸœŸ˜ K˜K˜Kš‘œŸœ#˜8š‘	œŸœ˜šŸœ˜šŸœ˜Kšœ)G™pK˜K˜K˜Kš
œ
˜
—šŸœ
Ÿœ
Ÿ˜K˜'K˜2KšŸœ,˜3——K˜—š‘œŸœ˜šŸœŸœ
Ÿœ
Ÿ˜*Kšœ	Ÿœ
˜KšœŸœ
˜šŸœ˜KšœŸœŸœ
˜Kš
;™;Kšœ1ŸœŸœ˜BšŸœ
Ÿœ
Ÿœ˜Kš
œ˜K˜5K˜—K˜——K˜—šœ
Ÿœ˜KšœŸœ˜"KšœŸœŸœ˜!K˜K˜šŸœŸœ˜Kš
œ˜Kšœ Ÿœ˜&Kšœ$Ÿœ˜*K˜
—šŸœ˜K˜K˜$K˜—K˜—š‘
œŸœ˜KšœŸœŸœ
˜K˜KšŸœŸœ
Ÿœ*˜;K˜—KšŸœŸœ˜*KšŸœŸœŸœŸœ˜7K˜KšŸœ
˜—KšŸœŸœ˜.K˜—K˜š‘œŸœ˜KšŸœŸœŸœ˜0K˜šŸœŸ˜K˜š
œ˜KšœŸœ
ŸœŸœ
ŸœŸœ˜ KšœŸœ˜#KšœŸœ˜šŸœŸœ
4˜GKšŸœŸœ
ŸœŸ˜'Kš
ŸœŸœ
Ÿœ
Ÿœ$Ÿœ˜UKš
Ÿ˜šŸœŸœŸœ˜>K˜7Kš
Ÿ˜K˜—KšŸœ
˜—K˜šŸœ
ŸœŸœ	Ÿ˜&š
ŸœŸœ
Ÿœ
ŸœŸœŸœ
Ÿ˜BKšŸœŸœ
Ÿœ
˜'Kš
Ÿ˜šŸœ˜K˜K˜7K˜—KšŸœ
˜——K˜K˜—K˜$K˜K˜-K˜K˜"K˜K˜"K˜K˜K˜K˜!K˜K˜K˜K˜K˜˜	K˜K˜:K˜K˜—˜K˜K˜K˜KšŸœŸœ'˜?šŸœ	Ÿ˜šŸœŸ˜'˜˜K˜$K˜K˜0——KšŸœ
˜——K˜K˜—˜8K˜šŸœŸ˜K˜$K˜,K˜)KšŸœ
˜—šŸœ
Ÿœ
Ÿ˜KšœŸœ:˜MKšœŸœ'˜BšŸœ˜
˜šŸœŸ˜K˜*KšŸœ
˜—K˜%———K˜K˜—˜K˜KšŸœŸœ˜1K˜K˜šŸœŸœ Ÿ˜;˜K˜K˜%——K˜K˜—˜-K˜$šœŸœ˜šŸœŸ˜K˜:Kšœ'Ÿœ˜<——š‘œŸœ˜K˜(K˜—š‘œŸœ˜K˜K˜)K˜—K˜K˜šŸœŸœ˜Kš
œ˜K˜K˜—šŸœŸ˜˜K˜šŸœŸœ˜Kš
œ˜K˜K˜—K˜—KšŸœ
˜—K˜K˜—š
œ˜KšœŸœ˜KšœŸœ˜$KšŸœŸœŸœ˜:KšŸœŸœ#˜CK˜šŸœŸœ
ŸœŸ˜#š‘œŸœ˜Kš
œ#˜#K˜—KšŸœŸœ%˜2KšŸœŸœŸœ˜-Kš
-™-K˜KšŸœ
˜—K˜K˜K˜—š
œ˜šŸœ
ŸœŸœŸœ˜MKš
œ2™2—KšŸœ	ŸœŸœ.˜KK˜K˜.K˜K˜-K˜K˜K˜—˜K˜K˜—š
œ
˜
KšŸœŸœ˜2KšŸœŸœ˜.K˜K˜-K˜K˜,K˜K˜—š
œ˜KšŸœŸœ˜-KšŸœŸœŸœ˜1K˜K˜K˜K˜K˜—š
œ˜KšŸœŸœ˜.K˜K˜-K˜K˜,K˜K˜—K˜#K˜K˜/K˜K˜K˜K˜*K˜K˜"K˜K˜K˜K˜ K˜K˜K˜K˜#K˜K˜"K˜KšŸœ˜K˜K˜——KšœŸœ˜$šŸœŸœ
Ÿ˜K˜)—K˜K˜Kš
‘œŸœ
Ÿœ
ŸœŸœ0˜XK˜š‘œŸœ˜
Kš
Ÿ˜K˜CKšŸœ
˜—K˜š‘œŸœ˜Kš
Ÿ˜Kšœ2Ÿœ˜7KšŸœ
˜—K˜K˜K˜—K˜KšŸœ˜Kšœ:Ÿœ
Ÿœ˜\K˜K˜VKš
œ…
˜…
K˜™*Kš
œΐ
™ΐ
KšœΟr0œ’œ’
œ™‘
—K™—…—%ς68