
<<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_64,
lateTrigger: NAT_80,
smallSons: NAT_2,

<<the real state information>>
sizing: BOOL_FALSE,
lastChar: CHAR_'\000,
lastIndex: Index_Index.LAST,
nextIndex: Index_0,
indent: NAT_0,
position: NAT_0,
line: INT_0
];


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_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["@%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_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];
<<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_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 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]};

}.

