<> <> <> 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_, <<>> <> earlyTrigger: NAT_64, lateTrigger: NAT_80, smallSons: NAT_2, <> 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] ~ { <> 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]}; <> WillExceed: PROC[ pps: PPS, t: Tree.Link, pattern: Rope.Text, level, pos: NAT, lineExceed: BOOL_FALSE] RETURNS[exceed: BOOL _ FALSE] ~ { <> 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]; <> 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; <> 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]; <> 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 <> 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] ~ { <> <> <> <<(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>> <<|: 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]>> <> <<@: indent _ position>> <> <> 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]}; }.