<<>>
<<;;;; SchemePretty.rules>>
<<;;; Copyright (c) 1992 by Xerox Corporation.  All rights reserved.>>
;;; Spreitze, May 12, 1992 12:41 pm PDT
;;; Last changed by Pavel on August 12, 1990 7:03 pm PDT

;; default rules
form-default data
list-default white-list
data leaf
;; data (me ((precommentless 'quote) (postcommentless any)) (readermacro "'" any))
;; data (me ((precommentless 'quasiquote) (postcommentless any)) (readermacro "`" any))
;; data (me ((precommentless 'unquote) (postcommentless any)) (readermacro "," any))
;; data (me ((precommentless 'unquote-splicing) (postcommentless any)) (readermacro ",@" any))
data (lob black-list)
data (vp (lob black-list))
black-list ()
black-list (data)
black-list (data l0 .  black-list)
white-list (l0 )
white-list (l0 data)
white-list (l0 data .  white-list)

;; for pretty-printing rules files
rules (ob rulseq)
rulseq ()
rulseq (rulsub ls rule a0 .  rulseq)
rulsub definee
rulsub (lob (definee ls definee))
rule leaf
rule (me ((precommentless 'quote) (postcommentless any))
(readermacro "'" data))
rule (me ((precommentless 'quasiquote) (postcommentless any))
(readermacro "`" data))
rule (lob rule-list)
rule (vp (lob rule-list))
rule-list ()
rule-list (rule)
rule-list (rule l0 .  rule-list)

;; sequence of data
datas ()
datas (data a0 .  datas)

;; expression sequences used to give special emphasis to (define ...) forms
exprs ()
<<exprs ((me ((or 'define 'declare 'declass 'extend-syntax 'define-record-type 'macro) . any) expr)>>
<<. exprs-d)>>
exprs (expr .  exprs-o)
<<exprs-d ()>>
<<exprs-d>>
<<(a0 a0>>
<<(me ((or 'define 'declare 'declass 'extend-syntax 'define-record-type 'macro) . any) expr)>>
<<. exprs-d)>>
<<exprs-d (a0 a0 expr . exprs-o)>>
exprs-o ()
<<exprs-o>>
<<(a0 a0>>
<<(me ((or 'define 'declare 'declass 'extend-syntax 'define-record-type 'macro) . any) expr)>>
<<. exprs-d)>>
exprs-o (a0 expr .  exprs-o)

;; catch leaves and vectors real fast
expr leaf
expr (vp (lob black-list))

;; For singleton list, just print parens and recurse.
expr (lb (any))

;; Defining an atom to be a simple expression gets special-case formatting.  Pay special attention to the name being defined.

expr (lob ('define ns .  defineTail))
expr (lob ('public ns .  defineTail))
expr (lob ('set! ns .  setTail))
expr (lob ('define-method ms definee ls .  defineTail))
defineTail ((me atom defsubj) ls (me simple expr))
defineTail ((me atom defsubj) as expr)
defineTail (defsubj as ob exprs)
defsubj definee
defsubj (lb (defsubj))
defsubj (lob (definee ms ob lambda-list))
defsubj (lob (defsubj l0 ob lambda-list))
lambda-list ()
lambda-list ('"others" l0 argument l0 argument)
lambda-list (req-or-opt)
lambda-list (req-or-opt l0 . lambda-list)
formalsTail ()
formalsTail (l0 . lambda-list)
req-or-opt argument
req-or-opt (lob (argument l0 expr))
req-or-opt (lob (argument l0 expr l0 leaf))
setTail ((me atom expr) ls (me simple expr))
setTail ((me atom expr) as expr)

expr (lob ('DEFVAR ns definee ms expr ls expr))

expr (lob ('module ms (lob mod-head) as ob exprs))
mod-head ()
mod-head (mod-head-stmt)
mod-head (mod-head-stmt l0 .  mod-head)
mod-head-stmt (lob ('import .  head-tail))
mod-head-stmt (lob ('open .  head-tail))
mod-head-stmt (lob ('export .  head-tail))
mod-head-stmt (lob ('export-all .  head-tail))
head-tail ()
head-tail (ls ifcmd .  head-tail)
ifcmd definee
ifcmd (lob (definee .  ifc-items))
ifc-items ()
ifc-items (ls '...)
ifc-items (ls ifc-item .  ifc-items)
ifc-item argument
ifc-item (lob (data ns argument))

expr (lob ('interface ns definee ls leaf))
expr (lob ('interface ns definee as ob ifc-elts))
ifc-elts ()
ifc-elts (ifc-elt)
ifc-elts (ifc-elt a0 .  ifc-elts)
ifc-elt (lob ('value ns definee .  ifc-elt-decls))
ifc-elt-decls ()
ifc-elt-decls (ls ifc-elt-decl . ifc-elt-decls)
ifc-elt-decl (lob ('arguments . formalsTail))
ifc-elt-decl expr

expr (lob ('define-class ns definee . dctail))
dctail ()
dctail (as dcitem . dctail)
dcitem (lob ('super-class ls expr))
dcitem (lob ('class-vars ms ob (nvitem . nvlist)))
dcitem (lob ('instance-vars ms ob (nvitem . nvlist)))
nvlist ()
nvlist (a0 (lob (definee ls expr)) . nvlist)
nvlist (l0 definee . nvlist)
nvitem (lob (definee ls expr))
nvitem definee

ostype leaf
ostype (lob ('list ms ostype))
ostype (lob ('pair ms ob (ostype l0 ostype)))
ostype (lob ('proc ls ob ((lob procty-args) l0 ostype)))
procty-args ()
procty-args (ostype ls definee)
procty-args ((lob (ostype .  deflist)))
procty-args ((lob (ostype .  deflist)) l0 .  procty-args)
deflist ()
deflist (ls definee .  deflist)
ostype data

;; rules for (lambda ...)
expr (lob ('lambda ns (lob lambda-list) .  lambdaTail))
lambdaTail (ls (me simple expr))
lambdaTail (as ob exprs)

;; Fortunately, we can re-use a mess.
expr (lob ((or 'unless 'when) ns any .  body-s))
body-s ()
body-s (as expr .  body-s)

;; Within an (export ...), (define ...) forms are surrounded by blank lines; other forms are not.

expr (lob ('export ns data .  exportTailOther))
exportTailDef (as)
exportTailDef (as as (me ('define .  any) expr) .  exportTailDef)
exportTailDef (as as expr .  exportTailOther)
exportTailOther (as)
exportTailOther (as as (me ('define .  any) expr) .  exportTailDef)
exportTailOther (as expr .  exportTailOther)

;; Lots of special cases for (if ...).
;; In the simplest, the consequent and alternative are put in their own nested object.

expr (lob ('if ns .  ifTail))
ifTail
((me simple expr) ls begin-obj (me atom expr) l0 (me atom expr)
end-obj)
ifTail ((me simple expr) .  simpleIf)
ifTail (expr .  complexIf)
simpleIf (ls (me simple expr))
simpleIf (as expr)
simpleIf (us (me atom expr) ls (me atom expr))
simpleIf (us (me simple expr) us (me simple expr))
simpleIf (as expr us expr)
complexIf (as expr)
complexIf (as (me atom expr) ls (me atom expr))
complexIf (as expr us expr)

;; The first rule could also be written more directly as expr (lob ('cond ms ob condSeries)), remembering that (a b c) is (a . (b . 
(c . ()))), but some people find that confusing.

expr (lob ('cond ms .  condTail))
expr (lob ('case ns any as .  condTail))
condTail (ob condSeries)
condSeries ()
condSeries (condClause)
condSeries (condClause a0 .  condSeries)
condClause (lob ('else l0 (me simple expr)))
condClause (lob ((me simple expr) l0 (me simple expr)))
condClause (lob ('else a0 expr))
condClause (lob (expr a0 expr))
condClause (lob ((me simple expr) l0 '=> ns (me simple expr)))
condClause (lob (expr a0 '=> ns expr))
condClause (lob ('else .  condClauseTail))
condClause (lob (expr .  condClauseTail))
condClauseTail ()
condClauseTail (a0 expr .  condClauseTail)

;; The first rule is for named let, and groups the name and bindings into their own nested object.

expr
(lob
('let ns begin-obj definee m0 (lob bindings) end-obj as ob exprs))
expr
(lob
((or 'let 'let* 'letrec 'with 'dynamic-bind) ns (lob bindings)
as ob exprs))
bindings ()
bindings (binding)
bindings (binding a0 .  bindings)
binding (lob (argument ms expr))
binding (lob (expr ls expr))

;; The miser break will shift the whole body outward only if globally necessary.
expr (lob ('begin ms .  beginTail))
beginTail (ob body-0)
body-0 ()
body-0 (expr)
body-0 (expr a0 .  body-0)

;; Rules for (do ..)
expr
(lob ('do ns begin-obj (lob do-bindings) a0 condClause end-obj . 
body-s))
do-bindings ()
do-bindings (do-binding)
do-bindings (do-binding a0 .  do-bindings)
do-binding (lob (argument ms expr))
do-binding (lob (argument ms ob (expr l0 expr)))

;; To get particular formatting for the extension clauses:
expr (lob ('extend-syntax ns (lob (definee .  formalsTail)) . 
extendTail))
extendTail ()
extendTail (as extension .  extendTail)
extension (lob body-0)

expr (strip-list (skip 'access leaf insert "#" (leaf)))

;; The reader converts 'x into (quote x) --- we undo that.
;; We avoid losing info about where comments were attached.

expr (me ((precommentless 'quote) (postcommentless any))
(readermacro "'" data))
expr (lob ('quote ns data))

;; We have to count depth to know when we leave quasiquotation.
expr (me ((precommentless 'quasiquote) (postcommentless any))
(readermacro "`" (enter templ 1)))
expr (lob ('quasiquote ns (enter templ 1)))
(templ 0) expr
templ leaf
templ (me ((precommentless 'quote) (postcommentless any))
(readermacro "'" templ))
templ (me ((precommentless 'quasiquote) (postcommentless any))
(readermacro "`" (inc templ)))
templ (me ((precommentless 'unquote) (postcommentless any))
(readermacro "," (dec templ)))
templ
(me ((precommentless 'unquote-splicing) (postcommentless any))
(readermacro ",@" (dec templ)))
templ (lob ('quasiquote ns (inc templ)))
templ (lob ('unquote ns (dec templ)))
templ (lob ('unquote-splicing ns (dec templ)))
templ (lob templ-l)
templ (vp (lob templ-l))
templ-l ()
templ-l (templ)
templ-l (me (any 'unquote any) (templ ls dotform templ))
templ-l (templ ls .  templ-l)

;; For a local macro...
expr (lob ('define-type ns definee .  drt-tail))
expr (lob ('define-record-type ns definee .  drt-tail))
drt-tail (as)
drt-tail (as drt-clause)
drt-tail (as drt-clause .  drt-tail)
drt-clause (lob ('field ns argument .  drt-field-tail))
drt-field-tail ()
drt-field-tail (ls drt-field-clause)
drt-field-tail (as drt-field-clause .  drt-field-tail-2)
drt-field-tail-2 ()
drt-field-tail-2 (as drt-field-clause)
drt-field-tail-2 (as drt-field-clause .  drt-field-tail-2)
drt-field-clause (lob ('type ls expr))
drt-field-clause (lob ('= ls expr))
drt-field-clause (lob ('initially ls expr))
drt-field-clause (lob ('accessor ls definee))
drt-field-clause (lob ('updater ls definee))
drt-field-clause (lob ('modifier ls definee))
drt-clause (lob ('= ns argument ls expr))
drt-clause (lob ('sequence ns argument .  drt-tail))
drt-clause (lob ('unsafe-sequence .  drt-tail))
drt-clause (lob ('length ns definee))
drt-clause (lob ('array ms expr .  drt-tail))
drt-clause (lob ('subtype ns definee .  drt-tail))
drt-clause (lob ('printer ms expr))
drt-clause (lob ('constructor ns drt-cons))
drt-clause (lob ('constructor ns drt-cons as '=> ns expr))
drt-cons (lob (definee .  formalsTail))
drt-clause (lob ('tag ls expr))
drt-clause (lob ('immediate))
drt-clause (lob ('initializer ls expr))
drt-clause (lob ('override ls leaf ls (lob ('initially ls expr))))

;; for (macro ..)
expr (lob ('macro ns definee as expr))

;; Just to get keyword emphasis...
expr (lob ((or 'and 'or) ms .  args))

;; We put the rules for procedure call at the end, 'cause otherwise they'd match most syntax that wants specific rules.  The 
classification of the head determines the condition of the first break (the earlier presence of a rule for singleton lists ensures 
that we have at least one argument).  Complex arguments are separated from other args by always breaks; simple ones are separated 
by a united break; otherwise lookLeft breaks are used.

expr (lob (atom ms .  args))
expr (lob (simple l0 .  args))
expr (lob (complex a0 .  args))
args ()
args (expr)
args (ob ((me atom expr) .  args-a))
args (ob ((me simple expr) .  args-s))
args (ob ((me complex expr) .  args-c))
args-a (l0 (me atom expr))
args-a (u0 expr)
args-a (l0 (me atom expr) .  args-a)
args-a (u0 (me simple expr) .  args-s)
args-a (a0 (me complex expr) .  args-c)
args-s (u0 expr)
args-s (u0 (me atom expr) .  args-a)
args-s (u0 (me simple expr) .  args-s)
args-s (a0 (me complex expr) .  args-c)
args-c (a0 expr)
args-c (a0 (me atom expr) .  args-a)
args-c (a0 (me simple expr) .  args-s)
args-c (a0 (me complex expr) .  args-c)