[ivy]<Satterthwaite>SML>SMPrettyImpl.mesa!17

SMPrettyImpl.mesa
Copyright (C) 1985 by Xerox Corporation. All rights reserved.
last edit by Satterthwaite, May 29, 1986 11:22:13 am PDT
DIRECTORY
Atom: TYPE USING [GetPName],
CS: TYPE USING [RopeFromGMT],
IO: TYPE USING [STREAM, PutChar, PutFR, rope],
Rope: TYPE USING [ROPE, Text, Fetch, Length],
SMCommentTable: TYPE USING [Ref],
SMCommentTableOps: TYPE USING [CommentM, Explode, FindNext, TestBreakHint],
SMFI: TYPE USING [BcdFileInfo, SrcFileInfo],
SMUtil: TYPE USING [],
SMTree: TYPE Tree USING [
Handle, Id, Link, Name, Text, null, nullHandle, nullId, nullName],
SMTreeOps: TYPE TreeOps USING [GetName, NSons, NthSon, OpName];
SMPrettyImpl: CEDAR PROGRAM
IMPORTS Atom, CS, IO, Rope, SMCommentTableOps, SMTreeOps
EXPORTS SMUtil ~ {
OPEN Tree~~SMTree, TreeOps~~SMTreeOps;
Index: TYPE ~ INT;
InvalidIndex: Index ~ Index.LAST;
PPS: TYPE ~ REF PPState;
PPState: TYPE~RECORD[-- global information used by the pretty printer
out: IO.STREAM←,
comments: SMCommentTableOps.CommentM←,
options
earlyTrigger: NAT�,
lateTrigger: NAT�,
smallSons: NAT𡤂,
the real state information
sizing: BOOL←FALSE,
lastChar: CHAR←'\000,
lastIndex: Index←Index.LAST,
nextIndex: Index𡤀,
indent: NAT𡤀,
position: NAT𡤀,
line: INT𡤀
];
Excess: ERROR~CODE;
WriteChar: PROC[pps: PPS, c: CHAR] ~ {
IF (pps.lastChar ← c) < '\040 THEN {
SELECT c FROM
'\t => {
pps.position ← pps.position + 8;
pps.position ← pps.position - pps.position MOD 8;
pps.lastChar ← ' };
'\n, '\f => {pps.position ← 0; pps.line ← pps.line + 1};
ENDCASE}
ELSE pps.position ← pps.position + 1;
IF pps.sizing THEN {
IF pps.lastChar # ' AND pps.position >= pps.lateTrigger THEN ERROR Excess}
ELSE pps.out.PutChar[c]};
WriteName: PROC[pps: PPS, name: Tree.Name] ~ {
r: Rope.Text ~ Atom.GetPName[name];
len: CARDINAL ~ r.Length;
pps.position ← pps.position + len;
pps.lastChar ← 'A;
IF pps.sizing THEN {
IF pps.position >= pps.lateTrigger THEN ERROR Excess}
ELSE
FOR i: CARDINAL IN [0..len) DO pps.out.PutChar[r[i]] ENDLOOP;
};
WriteToken: PROC[pps: PPS, r: Rope.ROPE] ~ {
len: CARDINAL ~ r.Length;
IF len # 0 THEN {
pps.position ← pps.position + len;
pps.lastChar ← r.Fetch[len-1];
IF pps.sizing THEN {
IF pps.position >= pps.lateTrigger THEN ERROR Excess}
ELSE
FOR i: CARDINAL IN [0..len) DO pps.out.PutChar[r.Fetch[i]] ENDLOOP;
};
};
WriteText: PROC[pps: PPS, r: Rope.Text] ~ {
IF r # NIL THEN
FOR i: CARDINAL IN [0..CARDINAL[r.Length]) DO WriteChar[pps, r[i]] ENDLOOP;
};
WriteQuotedText: PROC[pps: PPS, r: Rope.Text] ~ {
assumes that the scanner has left excape marks
WriteChar[pps, '"];
IF r # NIL THEN
FOR i: CARDINAL IN [0..CARDINAL[r.Length]) DO WriteChar[pps, r[i]] ENDLOOP;
WriteChar[pps, '"]};
Indent: PROC[pps: PPS] ~ {
THROUGH [pps.position .. pps.indent) DO WriteChar[pps, ' ] ENDLOOP};
Break: PROC[pps: PPS] ~ {
IF pps.position > pps.indent THEN WriteChar[pps, '\n];
Indent[pps]};
sizing procedures
WillExceed: PROC[
pps: PPS, t: Tree.Link, pattern: Rope.Text, level, pos: NAT, lineExceed: BOOL←FALSE]
RETURNS[exceed: BOOL ← FALSE] ~ {
save the state
oldLastChar: CHAR ~ pps.lastChar;
oldLastIndex: Index ~ pps.lastIndex;
oldNextIndex: Index ~ pps.nextIndex;
oldIndent: NAT ~ pps.indent;
oldPosition: NAT ~ pps.position;
oldLine: INT ~ pps.line;
IF pps.sizing THEN RETURN[FALSE];
try to determine the size of things
pps.sizing ← TRUE;
[] ← PrettyPattern[pps, t, pattern, level, pos
! Excess => {exceed ← TRUE; CONTINUE}];
IF lineExceed AND pps.line > oldLine THEN exceed ← TRUE;
pps.sizing ← FALSE;
restore the state
pps.line ← oldLine;
pps.position ← oldPosition;
pps.indent ← oldIndent;
pps.nextIndex ← oldNextIndex;
pps.lastIndex ← oldLastIndex;
pps.lastChar ← oldLastChar;
RETURN};
FlushCommentsBefore: PROC[pps: PPS, index: Index] ~ {
IF pps.comments # NIL THEN {
comment: SMCommentTable.Ref ← NIL;
WHILE index >= pps.nextIndex DO
oldLine: Index ~ pps.line;
comment ← (pps.comments).FindNext[pps.nextIndex];
IF comment = NIL THEN EXIT ELSE {
cIndex, lastToken, prefix: Index;
text: Rope.Text;
[cIndex, text, lastToken, prefix] ← SMCommentTableOps.Explode[comment];
pps.nextIndex ← cIndex;
IF pps.nextIndex > index THEN EXIT;
pps.nextIndex ← pps.nextIndex + 1;
IF ~(pps.sizing OR index = InvalidIndex) THEN
IF prefix > 0 OR pps.position + text.Length > pps.lateTrigger THEN Break[pps];
IF text = NIL OR text.Length < 2 THEN WriteChar[pps, '\n]
ELSE IF pps.position > pps.indent AND pps.lastChar # ' THEN WriteChar[pps, ' ];
FOR i: Index IN [2..prefix] DO WriteChar[pps, '\n] ENDLOOP;
Indent[pps];
WriteText[pps, text]};
IF pps.line = oldLine THEN WriteChar[pps, ' ];
Indent[pps]
ENDLOOP
};
};
PrettyPrint: PUBLIC PROC[
out: IO.STREAM, root: Tree.Link, comments: SMCommentTableOps.CommentM] ~ {
IF root # Tree.null THEN {
next: SMCommentTable.Ref ~ (IF comments=NIL THEN NIL ELSE comments.FindNext[0]);
pps: PPS ~ NEW[PPState ← [
out~out,
comments~comments,
nextIndex~
(IF next=NIL THEN InvalidIndex ELSE SMCommentTableOps.Explode[next].start),
lastIndex~InvalidIndex,
lastChar~' ]];
PrettyLink[pps, root, 0];
FlushCommentsBefore[pps, InvalidIndex];
WriteChar[pps, '\n]};
};
PrettyLink: PROC[pps: PPS, t: Tree.Link, info: Index, level: NAT𡤀] ~ {
IF t # Tree.null THEN {
SELECT pps.position FROM
< pps.indent => Indent[pps];
> pps.lateTrigger => IF ~ pps.sizing THEN Break[pps];
ENDCASE;
WITH t SELECT FROM
name: Tree.Name => PrettyName[pps, name, info];
id: Tree.Id => PrettyId[pps, id];
text: Tree.Text => PrettyText[pps, text, info];
node: Tree.Handle => PrettyNode[pps, node, level];
fiSrc: SMFI.SrcFileInfo =>
WriteToken[pps,
IO.PutFR["@%g!%g", IO.rope[fiSrc.localName],
IO.rope[CS.RopeFromGMT[fiSrc.create]]]];
fiBcd: SMFI.BcdFileInfo =>
WriteToken[pps,
IO.PutFR["@%g!%g", IO.rope[fiBcd.localName],
IO.rope[CS.RopeFromGMT[fiBcd.create]]]];
ENDCASE => ERROR;
};
};
PrettyName: PROC[pps: PPS, name: Tree.Name, info: Index] ~ {
IF name = Tree.nullName THEN WriteToken[pps, "(anon)"]
ELSE {FlushCommentsBefore[pps, info]; WriteName[pps, name]}};
PrettyId: PROC[pps: PPS, id: Tree.Id] ~ INLINE {
IF id = Tree.nullId THEN WriteToken[pps, "(anon)"]
ELSE {-- cf. SMValImpl.IdName
d: Tree.Handle ~ (IF id.db.name = $decl THEN id.db ELSE NARROW[id.db[1]]);
WriteName[pps, TreeOps.GetName[TreeOps.NthSon[d.son[id.p], 1]]]};
};
PrettyText: PROC[pps: PPS, text: Tree.Text, info: Index] ~ {
FlushCommentsBefore[pps, info];
WriteQuotedText[pps, text]};
OpKind: TYPE~{binary, pattern, special};
GetInfo: PROC[t: Tree.Link] RETURNS[info: Index] ~ {
WITH t SELECT FROM
x: Tree.Handle => {
info ← x.info;
IF info = 0 THEN
FOR i: NAT IN [1..TreeOps.NSons[t]] WHILE info = 0 DO
info ← GetInfo[TreeOps.NthSon[t, i]]
ENDLOOP};
ENDCASE => info ← 0};
PrettyNode: PROC[pps: PPS, node: Tree.Handle, level: NAT𡤀] ~ {
oldIndent: Index ~ pps.indent;
IF node = Tree.nullHandle THEN NULL
ELSE IF node.name = $locator THEN PrettyLink[pps, node.son[1], node.info, level]
ELSE {
text: Rope.Text;
kind: OpKind;
newLevel: NAT;
info: Index ~ GetInfo[node];
IF info # 0 THEN FlushCommentsBefore[pps, info];
[text, newLevel, kind] ← LookAtNode[node];
IF newLevel < level THEN {WriteChar[pps, '(]; pps.indent ← pps.position};
SELECT kind FROM
$special => PrettySpecial[pps, node];
$binary => {
left: Tree.Link ~ TreeOps.NthSon[node, 1];
right: Tree.Link ~ TreeOps.NthSon[node, 2];
[] ← PrettyPattern[pps, left, "%0", newLevel];
WriteToken[pps, text];
[] ← PrettyPattern[pps, right, "%+2%|%0", newLevel+1]};
$pattern => [] ← PrettyPattern[pps, node, text, newLevel];
ENDCASE => ERROR;
IF newLevel < level THEN WriteChar[pps, ')]};
pps.indent ← oldIndent};
LookAtNode: PROC[node: Tree.Handle] RETURNS[text: Rope.Text, level: NAT, kind: OpKind] ~ {
nSons: CARDINAL ~ TreeOps.NSons[node];
the default case
level ← 0; text ← NIL; kind ← $pattern;
SELECT node.name FROM
$lambda =>
text ← (IF node.son[2]=Tree.null
THEN "LAMBDA %(%+4%1%) IN %(%+2%|%3%)"
ELSE "LAMBDA %(%+4%1%) => %2 IN %(%+2%|%3%)");
$let => text ← "LET %(%+2%1%) IN %(%|%2%)";
$arrow =>
text ← (IF TreeOps.OpName[node.son[2]] = $none THEN "%1->%2" ELSE "%1->(%2)");
$arrow2 =>
text ← (IF TreeOps.OpName[node.son[2]] = $none THEN "%1->>%2" ELSE "%1->>(%2)");
$apply => text ← "%1%2";
$applyDefault => text ← "%1*%2";
$subscript => text ← "%1.%2";
$union => text ← "%1 %*+ %2";
$then => text ← "%1 %*THEN %2";
$exclusion => text ← "%1 - %2";
$restriction => text ← "%1^%2";
$splitUpper => text ← "%1\\%2";
$splitLower => text ← "%1/%2";
$group => text ← "[%,0]";
$decl =>
text ← (SELECT TRUE FROM
(nSons = 0) => "[]",
(nSons = 1 AND ~node.attrs[1]) => "%1",
ENDCASE => "[%|%,0]");
$declElem => text ← (IF node.son[2]=Tree.null THEN "%|%1:" ELSE "%|%1: %2");
$bind => text ← "[%*%,0]";
$bindRec => text ← "REC [%*%;0]";
$bindElem => text ← "%|%1~%*%2";
$type => text ← (IF node.son[1]=Tree.null THEN "TYPE" ELSE "TYPE %1");
$env => text ← "ENV";
$nil => text ← "NIL";
$control => text ← "CONTROL";
$unitId => kind ← $special;
$typeSTRING => text ← "STRING";
$nBind => text ← "[%1~%2]";
$nBindRec => text ← "REC [%*%1~%2]";
$stamp => kind ← $special;
$cross => text ← "%1 CROSS %2";
$cross2 => text ← "(%1 CROSS CROSS %2)";
ENDCASE => ERROR;
RETURN};
PrettySpecial: PROC[pps: PPS, t: Tree.Link] ~ {
oldIndent: Index ~ pps.indent;
SELECT TreeOps.OpName[t] FROM
$unitId => {
son1: Tree.Link ~ TreeOps.NthSon[t, 1];
son2: Tree.Link ~ TreeOps.NthSon[t, 2];
son3: Tree.Link ~ TreeOps.NthSon[t, 3];
son4: Tree.Link ~ TreeOps.NthSon[t, 4];
WriteChar[pps, '@];
IF son1 ~= Tree.null THEN WriteToken[pps, NARROW[son1]];
IF son2 ~= Tree.null THEN WriteToken[pps, NARROW[son2]];
IF son1 ~= Tree.null OR son2 ~= Tree.null THEN WriteChar[pps, '/];
WriteToken[pps, NARROW[son3]];
IF son4 ~= Tree.null THEN {
WriteChar[pps, '!]; WriteToken[pps, NARROW[son4]]}
};
$stamp => {
WriteToken[pps, "NIL"]};-- *** temporary ***
ENDCASE => ERROR;
pps.indent ← oldIndent};
PrettyList: PROC[pps: PPS, t: Tree.Link, separator: CHAR←';] ~ PrettySons;
PrettyBrackets: PROC[pps: PPS, t: Tree.Link, left: CHAR←'\000, separator: CHAR←';] ~ {
oldIndent: Index ← pps.indent;
IF left # '\000 THEN WriteChar[pps, left];
pps.indent ← pps.position;
PrettyList[pps, t, separator];
SELECT left FROM
'{ => WriteChar[pps, '}];
'( => WriteChar[pps, ')];
'[ => WriteChar[pps, ']];
ENDCASE;
pps.indent ← oldIndent};
PrettySons: PROC[pps: PPS, t: Tree.Link, separator: CHAR←';] ~ {
WITH t SELECT FROM
node: Tree.Handle => {
sons: NAT ~ TreeOps.NSons[node];
break: BOOL ← (separator = '; AND sons > pps.smallSons);
IF separator = '. THEN {break ← TRUE; separator ← ',};
IF separator = ': THEN {break ← FALSE; separator ← ';};
IF sons # 0 THEN {
son1: Tree.Link ~ node.son[1];
lastInfo: Index ← GetInfo[son1];
lastLine: INT ← pps.line;
FlushCommentsBefore[pps, lastInfo];
IF break THEN Break[pps];
lastLine ← pps.line;
PrettyLink[pps, son1, lastInfo];
FOR i: NAT IN [2..sons] DO
link: Tree.Link ~ node.son[i];
thisInfo: Index ~ GetInfo[link];
thisBreak: BOOL ←-- lots of ways to break here
break
OR pps.line # lastLine
OR pps.position > pps.earlyTrigger AND sons-i > 1
OR separator = '; AND
(pps.comments # NIL AND (pps.comments).TestBreakHint[lastInfo, thisInfo])
OR pps.position > pps.indent AND WillExceed[pps, link, ",%@ %0", 0, 0]
-- OR (separator = ', AND BreakHintFromNode[link])--;
IF i = 2 AND ~break AND thisInfo > lastInfo AND lastInfo > 0 AND
(pps.comments # NIL AND (pps.comments).TestBreakHint[lastInfo, thisInfo]) THEN
HINT: first two items in list are on separate lines
break ← thisBreak ← TRUE;
IF link # Tree.null OR separator # '; THEN {
WriteChar[pps, separator];
WriteChar[pps, ' ];
FlushCommentsBefore[pps, lastInfo ← thisInfo];
IF thisBreak THEN Break[pps];
lastLine ← pps.line;
PrettyLink[pps, link, thisInfo]}
ENDLOOP;
};
};
ENDCASE;
};
PrettyPattern: PROC[
pps: PPS, t: Tree.Link, pattern: Rope.Text, level, pos: NAT𡤀, enable: BOOL←TRUE]
RETURNS[NAT] ~ {
This procedure takes care of expanding formatting patterns
The '% character is used to denote the start of an expansion
The characters following the % character are decoded specially, as follows:
(the following options are interpreted regardless of the enable flag)
(n: start a new recursion level, saving context, using son n
[n: start iteration over son n (wants separator character before n)
): return from current level, should pair with '(
]: end of iteration, should pair with '[
(the following options are interpreted only when enable is true)
0..9: expand the Nth son (where NthSon[t, 0] = t)
,n: expand list using son n, ', separator, default no break
;n: expand list using son n, '; separator, default break
.n: expand list using son n, ', separator, default break
:n: expand list using son n, '; separator, default no break
?n: enable ← Nth son # NIL
~?n: enable ← Nth son = NIL
|: break if remainder of pattern will exceed margin
*: same as %+2%|%@
^n: break if break hint between t and son n, or remainder exceeds margin
+n: pps.indent ← MIN[original indent + n, position]
/n: flush comments before son n, then break
@: indent ← position
!: exit entire pattern
all other characters following % are written literally
size: Index ~ (IF pattern = NIL THEN 0 ELSE pattern.Length);
GetSon: PROC RETURNS[Tree.Link] ~ {
n: NAT ~ GetNum[];
RETURN [SELECT n FROM
0 => t,
> nSons => Tree.null,
ENDCASE => TreeOps.NthSon[t, n]]
};
GetChar: PROC RETURNS[c: CHAR] ~ INLINE {
IF pos >= size THEN RETURN['%];
c ← pattern[pos];
pos ← pos + 1};
GetNum: PROC RETURNS[NAT] ~ INLINE {
IF pos >= size THEN RETURN[0]
ELSE {
nc: CHAR ~ pattern[pos];
IF nc IN ['0..'9] THEN {pos ← pos+1; RETURN[nc.ORD - '0.ORD]};
RETURN[0]};
};
nSons: NAT ← 0;
oldIndent: NAT ~ pps.indent;
oldLevel: NAT ~ level;
oldLine: INT ~ pps.line;
WITH t SELECT FROM
node: Tree.Handle => nSons ← node.sonLimit-1;
ENDCASE;
WHILE pos < size DO
c: CHAR ← GetChar[];
IF c # '% THEN {IF enable THEN WriteChar[pps, c]}
ELSE SELECT (c ← GetChar[]) FROM
'), '] => EXIT;
'( => pos ← PrettyPattern[pps, GetSon[], pattern, level, pos, enable];
'[ => {-- looping construct
term: CHAR ~ GetChar[];
link: Tree.Link ← GetSon[];
lenb: BOOL ~ (enable AND link # Tree.null);
IF lenb -- AND TreeOps.Opname[link] = $list-- THEN {
node: Tree.Handle ~ NARROW[link];
nls: NAT ~ node.sonLimit - 1;
FOR i: NAT IN [1 .. nls-1] DO
[] ← PrettyPattern[pps, node[i], pattern, 0, pos];
WriteChar[pps, term]
ENDLOOP;
link ← node[nls]};
pos ← PrettyPattern[pps, link, pattern, 0, pos, lenb]};
ENDCASE =>
IF enable THEN
SELECT c FROM
'0, '1, '2, '3, '4, '5, '6, '7, '8, '9 => {
pos ← pos - 1; PrettyLink[pps, GetSon[], 0, level]};
'?, '~ => {
IF c = '~ THEN {c ← GetChar[]; enable ← FALSE};
SELECT c FROM
'? => IF GetSon[] = Tree.null THEN enable ← ~enable;
ENDCASE => enable ← FALSE
};
';, ',, '., ': => PrettyList[pps, GetSon[], c];
'| =>
IF pps.position > pps.indent
AND WillExceed[pps, t, pattern, level, pos, TRUE] THEN Break[pps];
'* => {
pps.indent ← MIN[oldIndent + 2, pps.position];
IF pps.position > pps.indent
AND WillExceed[pps, t, pattern, level, pos, TRUE] THEN Break[pps];
pps.indent ← pps.position};
'^ =>
IF pps.position > pps.indent THEN {
link: Tree.Link ← GetSon[];
IF link # Tree.null THEN {
start: Index ~ GetInfo[t];
next: Index ~ GetInfo[link];
IF pps.position > pps.earlyTrigger
OR (start # 0 AND next > start
AND (pps.comments # NIL AND (pps.comments).TestBreakHint[start, next]))
OR WillExceed[pps, t, pattern, level, pos, TRUE] THEN {
FlushCommentsBefore[pps, next]; Break[pps]}
}
};
'/, '= => {FlushCommentsBefore[pps, GetInfo[GetSon[]]]; IF c = '/ THEN Break[pps]};
'$ => level ← GetNum[];
'! => {pos ← pos - 2; EXIT};
'@ => pps.indent ← MAX[pps.position, pps.indent];
'+ => pps.indent ← MIN[oldIndent + GetNum[], pps.position];
ENDCASE => WriteChar[pps, c];
ENDLOOP;
pps.indent ← oldIndent;
level ← oldLevel;
RETURN[pos]};
}.