<> <> <> <> <> <> <> DIRECTORY AMBridge USING [SetTVFromLI, TVToLI], AMTypes USING [Apply, Class, Copy, Domain, Error, First, Index, IndexToName, IndexToTV, IndexToType, IsComputed, IsOverlaid, Last, Length, NComponents, Next, Range, Referent, Tag, TVToName, TVType, TypeClass, UnderClass, UnderType, Variant, TV], BackStop USING [Call], IO USING [STREAM, Put, PutRope, PutChar, int], PrintTV USING [TVPrintProc, Print, RegisterClassPrintProc], Rope USING [ROPE, Size, Cat, Length], SafeStorage USING [Type, EquivalentTypes], StructuredStreams USING [Begin, End, Bp] ; PrettyPrinters: CEDAR PROGRAM IMPORTS AMBridge, AMTypes, BackStop, IO, PrintTV, Rope, SafeStorage, StructuredStreams = BEGIN OPEN PrintTV, Rope, AMBridge, AMTypes, SafeStorage, StructuredStreams; <> CR: CHAR = '\n; STREAM: TYPE = IO.STREAM; Pair: TYPE = MACHINE DEPENDENT RECORD [lo, hi: CARDINAL]; indent: INTEGER _ 3; <> PrintRecord: TVPrintProc = {PutRecord[stream, tv, 1, depth, width]}; PrintStructure: TVPrintProc = { IF IsAList[UnderType[TVType[tv]]] THEN PutList[stream, tv, depth, width] ELSE PutRecord[stream, tv, 1, depth, width]; }; PrintList: TVPrintProc = {PutList[stream, Referent[tv], depth, width]}; PrintArraySeq: TVPrintProc = BEGIN type: Type _ TVType[tv]; under: Type; class: Class; indexType: Type; index: TV; max: INT _ LAST[INT]; [under, class] _ UnderTypeAndClass[type]; indexType _ AMTypes.Domain[under]; index _ AMTypes.First[indexType]; IF AMTypes.UnderClass[indexType] = integer THEN { <> index _ AMTypes.Copy[index]; TRUSTED {AMBridge.SetTVFromLI[index, 0]}; }; IF class = sequence THEN <> max _ AMTypes.Length[tv] ELSE TRUSTED { <> low: INT _ AMBridge.TVToLI[index]; high: INT _ AMBridge.TVToLI[AMTypes.Last[indexType]]; max _ high-low+1; }; <> stream.PutRope["("]; stream.Put[IO.int[max]]; stream.PutRope[")["]; <> IF depth <= 1 THEN stream.PutRope["..."] <> ELSE FOR i: INT IN [0..width] WHILE index # NIL AND i < max DO ENABLE {AMTypes.Error => GO TO urp}; elem: TV _ NIL; msg: ROPE _ NIL; WriteElt: PROC = { PutTV[stream, elem, depth - 1, width]; }; IF i > 0 THEN stream.PutRope[", "]; IF i = width THEN {stream.PutRope["..."]; EXIT}; elem _ AMTypes.Apply[tv, index]; MakePiece[stream, WriteElt]; index _ AMTypes.Next[index]; ENDLOOP; stream.PutChar[']]; EXITS urp => {PutErr[stream, "Can't fetch element"]; stream.PutChar[']]} END; PutRecord: PROC [put: STREAM, tv: TV, start: NAT _ 0, depth, width: INT] = { size: Index; sep: ROPE _ NIL; type: Type; innerSize: PROC = { type _ TVType[tv]; size _ NComponents[type]}; IF depth <= 1 THEN {put.PutRope["[...]"]; RETURN}; sep _ BackStop.Call[innerSize]; IF sep # NIL THEN {PutErr[put, "can't examine, ", sep]; RETURN}; put.PutChar['[]; FOR i: Index IN [start..size] DO inner: TV _ NIL; quitFlag: BOOL _ FALSE; innerIndexToTV: PROC = { inner _ IndexToTV[tv, i]}; innerPut: PROC = { itype: Type _ TVType[inner]; iunder: Type; iclass: Class; [iunder, iclass] _ UnderTypeAndClass[itype]; IF i = size AND iclass = union THEN { variantTV: TV; IF IsOverlaid[iunder] THEN {put.PutRope["--Overlaid--"]; RETURN}; IF IsComputed[iunder] THEN {put.PutRope["--Computed--"]; RETURN}; variantTV _ Variant[inner]; QPutName[put, TVToName[Tag[inner]]]; PutRecord[put, variantTV, i, depth - 1, width]; RETURN}; PutTV[put, inner, depth - 1, width]; }; WriteValue: PROC = { msg: ROPE _ NIL; msg _ BackStop.Call[innerIndexToTV]; IF msg # NIL THEN {PutErr[put, "Can't get element: ", msg]; RETURN}; msg _ BackStop.Call[innerPut]; IF msg # NIL THEN {PutErr[put, "Can't print element: ", msg]; RETURN}; }; WriteField: PROC = { msg: ROPE _ NIL; name: ROPE = IndexToName[type, i]; named: BOOL = name.Length[] > 0; IF named THEN { put.PutRope[name.Cat[": "]]; MakePiece[put, WriteValue]; } ELSE WriteValue[]; }; IF i > start THEN put.PutRope[", "]; IF i > width THEN {put.PutRope["..."]; EXIT}; MakePiece[put, WriteField]; ENDLOOP; put.PutChar[']]; }; IsAList: PROC [underType: Type] RETURNS [result: BOOL _ FALSE] = { <> IF TypeClass[underType] = structure AND NComponents[underType] = 2 THEN { ENABLE AMTypes.Error => GO TO nope; <> IF EquivalentTypes[ Range[IndexToType[underType, 2]], underType] THEN RETURN [TRUE]; EXITS nope => {}; }; RETURN [FALSE]; }; PutList: PROC [put: STREAM, node: TV, depth, width: INT] = { <> sep: ROPE _ NIL; count: INT _ 0; put.PutRope["LIST["]; -- used to be LIST[ WHILE node # NIL DO WriteElt: PROC = { PutTV[put, IndexToTV[node, 1], depth, width]; }; put.PutRope[sep]; sep _ ", "; IF (count _ count + 1) > width THEN {put.PutRope["..."]; EXIT}; MakePiece[put, WriteElt]; node _ Referent[IndexToTV[node, 2]]; ENDLOOP; put.PutChar[']]; }; PutTV: PROC [put: STREAM, tv: TV, depth, width: INT, verbose: BOOL _ FALSE] = TRUSTED { deep: BOOL _ TRUE; msg1, msg2: ROPE _ NIL; IF tv = NIL THEN {put.PutRope["NIL"]; RETURN}; IF depth <= 0 THEN {put.PutRope["&"]; RETURN}; Print[tv, put, depth, width, verbose]; }; PutErr: PROC [put: STREAM, r1,r2: ROPE _ NIL] = {put.PutRope[Rope.Cat["--{", r1, r2, "}--"]]}; QPutName: PROC [put: STREAM, name: ROPE] = { IF name.Size[] = 0 THEN put.PutRope["??"] ELSE put.PutRope[name] }; <> UnderTypeAndClass: PROC [type: Type] RETURNS [under: Type, class: Class] = { under _ type; WHILE (class _ TypeClass[under]) = definition DO under _ UnderType[under]; ENDLOOP; }; MakePiece: PROC [to: IO.STREAM, write: PROC, united: BOOL _ FALSE] = { Bp[to, IF united THEN united ELSE lookLeft, indent]; Begin[to]; write[ !UNWIND => End[to] ]; End[to]; }; Setup: PROC = BEGIN RegisterClassPrintProc[class: record, proc: PrintRecord]; RegisterClassPrintProc[class: structure, proc: PrintStructure]; RegisterClassPrintProc[class: array, proc: PrintArraySeq]; RegisterClassPrintProc[class: sequence, proc: PrintArraySeq]; RegisterClassPrintProc[class: list, proc: PrintList]; END; Setdown: PROC = BEGIN RegisterClassPrintProc[class: record, proc: NIL]; RegisterClassPrintProc[class: structure, proc: NIL]; RegisterClassPrintProc[class: array, proc: NIL]; RegisterClassPrintProc[class: sequence, proc: NIL]; RegisterClassPrintProc[class: list, proc: NIL]; END; Setup[]; END. <> <> <> <<>>