-- SMPrettyImpl.mesa, module to output pretty text from a parse tree
-- last edit by Russ Atkinson, 16-Dec-81 14:36:33
-- last edit by Schmidt, May 16, 1983 4:52 pm
-- last edit by Satterthwaite, August 11, 1983 2:20 pm
-- The following comment is useful to measure indentation.
-- 1 2 3 4 5 6 7 8 9
-- 456789012345678901234567890123456789012345678901234567890123456789012345678901234567890
DIRECTORY
Atom: TYPE USING [GetPName],
CS: TYPE USING [RopeFromStamp],
IO: TYPE USING [card, PutChar, PutF, PutFR, rope, STREAM],
Rope: TYPE USING [Flatten, Text],
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, NodeName, 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
SHARES Rope ~ {
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←, -- the output stream
indent: NAT←0,
position: NAT←0,
line: INT←0,
sizing: BOOL←FALSE,
lastChar: CHAR←'\000,
lateTrigger: NAT←80,
earlyTrigger: NAT←64,
-- options
smallSons: NAT←2,
-- this stuff is the state information
comments: SMCommentTableOps.CommentM←, -- comment table
lastIndex: Index←Index.LAST,
nextIndex: Index←0];
Excess: ERROR ~ CODE;
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};
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.Text] ~ {
len: CARDINAL ~ r.length;
IF len # 0 THEN {
pps.position ← pps.position + len;
pps.lastChar ← r[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[i]] ENDLOOP;
};
};
WriteText: PROC[pps: PPS, r: Rope.Text] ~ {
IF r # NIL THEN
FOR i: CARDINAL IN [0..r.length) DO WriteChar[pps, r[i]] ENDLOOP;
};
WriteQuotedText: PROC[pps: PPS, r: Rope.Text] ~ {
-- we assume that the scanner has left escape marks
-- but that the leading and trailing quotes are gone
WriteChar[pps, '"];
IF r # NIL THEN {
FOR i: NAT IN [0..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] ~ {
-- First, save the entire 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];
-- now, 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;
-- last, restore the entire state
pps.lastChar ← oldLastChar;
pps.lastIndex ← oldLastIndex;
pps.nextIndex ← oldNextIndex;
pps.indent ← oldIndent;
pps.position ← oldPosition;
pps.line ← oldLine;
pps.sizing ← FALSE};
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←0] ~ {
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["@%s!%d", IO.rope[fiSrc.localName], IO.card[fiSrc.create]].Flatten[]];
fiBcd: SMFI.BcdFileInfo =>
WriteToken[pps,
IO.PutFR["@%s!%s", IO.rope[fiBcd.localName],
IO.rope[CS.RopeFromStamp[fiBcd.stamp]]].Flatten[]];
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};
PrettyNode: PROC[pps: PPS, node: Tree.Handle, level: NAT←0] ~ {
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];
level ← 0;
text ← NIL;
kind ← $pattern;
SELECT node.name FROM
$lambda => text ← "LAMBDA %(%+4%1%) => %2 IN %(%+2%3%)";
$let => text ← "LET %1 IN %(%+2%2%)";
$arrow => text ← "%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";
$cross => text ← "%1 CROSS %2";
$cross2 => text ← "%1 CROSS CROSS %2";
$group => text ← "[%,0]";
$bind => text ← "[%,0]";
$bindRec => text ← "REC [%;0]";
$bindElem => text ← "%|%1~%2";
$nBind => text ← "[%1~%2]";
$nBindRec => text ← "REC [%1~%2]";
$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");
-- $type => text ← "TYPE%(0%?1 %0%)";
$type => text ← (IF node.son[1]=Tree.null THEN "TYPE" ELSE "TYPE %1");
$typeSTRING => text ← "STRING";
$control => text ← "CONTROL";
$env => text ← "ENV";
$nil => text ← "NIL";
$unitId => kind ← $special; -- old: text ← "@%1%2%[.3%0%]"
-- $uiPart => text ← "%(%B*%)%1%(%A↑%)";
ENDCASE => ERROR;
};
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 {
WriteChar[pps, '[]; WriteToken[pps, NARROW[son1]]; WriteChar[pps, ']]};
IF son2 ~= Tree.null THEN {
WriteChar[pps, '<];
FOR i: NAT IN [1 .. TreeOps.NSons[son2]] DO
WriteToken[pps, NARROW[TreeOps.NthSon[son2, i]]]; WriteChar[pps, '>];
ENDLOOP;
};
FOR i: NAT IN [1 .. TreeOps.NSons[son3]] DO
t: Tree.Link ~ TreeOps.NthSon[son3, i];
IF i # 1 THEN WriteChar[pps, '.];
WITH t SELECT FROM
part: Rope.Text => WriteToken[pps, part];
node: Tree.Link => {
PrettyLink[pps, TreeOps.NthSon[node, 1], 0]; WriteChar[pps, '↑]};
ENDCASE;
ENDLOOP;
IF son4 ~= Tree.null THEN {
WriteChar[pps, '!]; WriteToken[pps, NARROW[son4]]};
};
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 AND separator = '; THEN LOOP;
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: NAT←0, pos: NAT←0, 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 TreeOps.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]; LOOP};
SELECT (c ← GetChar[]) FROM
'), '] => EXIT;
'( => {pos ← PrettyPattern[pps, GetSon[], pattern, level, pos, enable]; LOOP};
'[ => {-- 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];
LOOP}
ENDCASE;
IF ~enable THEN LOOP;
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]};
}.