syndicate-lang
/
preserves
mirror of https://gitlab.com/preserves/preserves.git
1
0
Fork 1
Code Releases Activity

Simpler and prettier

This commit is contained in:
Tony Garnock-Jones 2023-11-07 20:54:01 +01:00
parent 401e3973ee
commit 5edcca1e7f
3 changed files with 157 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
implementations/racket/preserves/preserves/block-write.rkt
View File

@ -23,59 +23,60 @@
(struct vertical-mode (mode item) #:transparent)
(struct separated (items separator terminator) #:transparent)
(struct grouped separated (opener closer) #:transparent)
(struct grouped (items separator terminator opener closer) #:transparent)
(struct emitter (port indentation) #:transparent)
(define (emit-seq vs sep ter e indent mode)
(define (emit-seq op vs sep ter cl e indent mode)
(define p (emitter-port e))
(when op (display op p))
(let loop ((vs vs) (need-sep #f))
(match vs
['()
(when need-sep (display ter (emitter-port e)))]
(when need-sep (display ter p))
(when cl (display cl p))]
[(cons v vs)
(when need-sep (display sep (emitter-port e)))
(when need-sep (display sep p))
(emit* v e indent mode)
(loop vs #t)])))
(define (emit-vertical print-indent-if-vertical? vs sep ter e indent mode)
(when print-indent-if-vertical? (display indent (emitter-port e)))
(emit-seq vs (string-append (trim-delimiter sep) indent) (trim-delimiter ter) e indent mode))
(define (emit-vertical op vs sep ter cl e indent mode)
(define inner-indent (if op (string-append indent (emitter-indentation e)) indent))
(let ((sep (string-append (trim-delimiter-right sep) inner-indent))
(ter (trim-delimiter-right ter))
(op (and op (string-append (trim-delimiter-right op) inner-indent)))
(cl (and cl (string-append indent (trim-delimiter-left cl)))))
(emit-seq op vs sep ter cl e inner-indent mode)))
(define (trim-delimiter s)
(define (trim-delimiter-right s)
(string-trim #:left? #f s #px"[ \t\f\v]+"))
(define (try-horizontal vs sep ter e indent mode)
(define (trim-delimiter-left s)
(string-trim #:right? #f s #px"[ \t\f\v]+"))
(define (try-horizontal op vs sep ter cl e indent mode)
(call-with-output-string
(lambda (p)
(emit-seq vs sep ter (emitter p (emitter-indentation e)) indent 'never))))
(emit-seq op vs sep ter cl (emitter p (emitter-indentation e)) indent 'never))))
(define (emit-separated print-indent-if-vertical? vs sep ter e indent mode)
(define (emit-separated op vs sep ter cl e indent mode)
(match mode
['never (emit-seq vs sep ter e indent mode) #f]
['variable (let ((s (try-horizontal vs sep ter e indent mode)))
['never (emit-seq op vs sep ter cl e indent mode)]
['variable (let ((s (try-horizontal op vs sep ter cl e indent mode)))
(if (> (string-length s) (pretty-print-columns))
(begin (emit-vertical print-indent-if-vertical? vs sep ter e indent mode) #t)
(begin (display s (emitter-port e)) #f)))]
['always (emit-vertical print-indent-if-vertical? vs sep ter e indent mode) #t]
['extra-newline (emit-vertical print-indent-if-vertical?
vs
(and sep (string-append sep "\n"))
ter
e
indent
mode) #t]))
(emit-vertical op vs sep ter cl e indent mode)
(display s (emitter-port e))))]
['always (emit-vertical op vs sep ter cl e indent mode)]
['extra-newline (let ((sep (string-append sep "\n")))
(emit-vertical op vs sep ter cl e indent mode))]))
(define (emit* v e indent mode)
(define (w v) (emit* v e indent mode))
(match v
[(? string? s) (display s (emitter-port e))]
[(? list? vs) (map w vs)]
[(grouped vs sep ter op cl)
(display op (emitter-port e))
(when (emit-separated #t vs sep ter e (string-append indent (emitter-indentation e)) mode)
(display indent (emitter-port e)))
(display cl (emitter-port e))]
[(separated vs sep ter) (emit-separated #f vs sep ter e indent mode)]
[(separated vs sep ter) (emit-separated #f vs sep ter #f e indent mode)]
[(grouped vs sep ter op cl) (emit-separated op vs sep ter cl e indent mode)]
[(vertical-mode new-mode v) (emit* v e indent new-mode)]))
(define (emit v [o (current-output-port)]

47
implementations/racket/preserves/preserves/pexprs.rkt
View File

@ -7,6 +7,7 @@
preserve->pexpr
write-pexpr
write-pexprs
COMMA
SEMICOLON
@ -231,34 +232,34 @@
[v v])))
(define (write-pexpr v0 [o (current-output-port)]
#:indent [indent-amount0 4]
#:encode-embedded [encode-embedded0 #f]
#:outer-sequence? [outer-sequence? #f]
#:indent [indent-amount 4]
#:encode-embedded [encode-embedded #f]
#:write-annotations? [write-annotations? #t])
(local-require "block-write.rkt")
(local-require "write-text.rkt")
(local-require (only-in racket/string string-prefix?))
(define (space span)
(if (null? span)
'()
(cons " " span)))
(define (convert-inner vs)
(define (finish-span span spans)
(if (null? span)
spans
(cons (reverse span) spans)))
(define (colons? s)
(string-prefix? s ":"))
(define (starts-with-delimiter? s)
(and (not (zero? (string-length s)))
(preserves-delimiter? (string-ref s 0))))
(let loop ((es (map convert vs)) (spans '()) (span '()))
(match es
['() (reverse (finish-span span spans))]
[(cons ";" more) (loop more (finish-span (cons ";" span) spans) '())]
[(cons "," more) (loop more (finish-span (cons "," span) spans) '())]
[(cons ":" more) (loop more spans (cons ":" span))]
[(cons (? string? (? colons? s)) (cons (? string? (? colons? e)) more))
(loop (cons e more) spans (cons " " (cons s span)))]
[(cons (? string? (? starts-with-delimiter? s)) more) (loop more spans (cons s span))]
[(cons (? string? s) more) (loop more spans (cons s (if (null? span) '() (cons " " span))))]
[(cons (? string? s) more) (loop more spans (cons s (space span)))]
[(cons (? separated? e) more) (loop more (finish-span span spans) (list e))]
[(cons (and e (grouped _ _ _ "{ " " }")) more) (loop more (finish-span (cons e (space span)) spans) '())]
[(cons (and e (grouped _ _ _ "<" ">")) more) (loop more spans (cons e (space span)))]
[(cons (and e (grouped _ _ _ "[" "]")) more) (loop more spans (cons e (space span)))]
[(cons e more) (loop more spans (cons e span))])))
(define (convert v)
@ -275,11 +276,25 @@
[(? list? ps) (grouped (convert-inner ps) " " "" "[" "]")]
[(RECORD ps ...) (grouped (convert-inner ps) " " "" "<" ">")]
[(GROUP ps ...) (grouped (convert-inner ps) " " "" "(" ")")]
[(BLOCK ps ...) (grouped (convert-inner ps) " " "" "{" "}")]
[(SET ps ...) (grouped (convert-inner ps) " " "" "#{" "}")]
[(BLOCK ps ...) (grouped (convert-inner ps) " " "" "{ " " }")]
[(SET ps ...) (grouped (convert-inner ps) " " "" "#{ " " }")]
[(TRAILER-ANCHOR) ""]
[(embedded v) (list "#!" (convert (encode-embedded0 v)))]
[(embedded v) (list "#!" (convert (encode-embedded v)))]
[(strip-annotations (record 'p (list s))) (symbol->string s)]
[v (preserve->string v)]))
(emit (convert v0) o #:indentation indent-amount0))
(emit (if outer-sequence?
(separated (convert-inner v0) " " "")
(convert v0))
o
#:indentation indent-amount))
(define (write-pexprs vs [o (current-output-port)]
#:indent [indent-amount 4]
#:encode-embedded [encode-embedded #f]
#:write-annotations? [write-annotations? #t])
(write-pexpr vs o
#:outer-sequence? #t
#:indent indent-amount
#:encode-embedded encode-embedded
#:write-annotations? write-annotations?))

98
implementations/racket/preserves/preserves/tests/test-pexprs.rkt
View File

@ -17,5 +17,99 @@
ENDDOC
)
(parameterize ((pretty-print-columns 80)) (write-pexpr (string->pexprs P #:read-syntax? #t)) (newline))
(parameterize ((pretty-print-columns 10)) (write-pexpr (string->pexprs P #:read-syntax? #t)) (newline))
(define Q #<<ENDDOC
{
setUp();
# Now enter the loop
loop: {
greet("World");
}
tearDown();
}
ENDDOC
)
(define R #<<ENDDOC
define ?ds (newDataspace);
define ?space (subspace (?ds: $ds) {
$ds ::= 999;
print {
1: 2,
3: 4,
};
print <record 1 2 3 +>;
$ds during ?a {
onStop print <retracted $a>;
print <asserted $a>;
}
spawn {
define ?root (currentFacet);
$ds during =ready1 {
$ds .= 123;
$ds during =ready2 {
$ds .= 123.5;
stop $root;
}
$ds ::= 234;
}
spawn {
print "hi there";
}
}
});
spawn {
define ?root (currentFacet);
$ds on message ?x {
print <message $x>;
snapshot $space (
?outcome:
# TODO: save outcome?
printFlat <post-snap $outcome>;
unpause $space;
turn $root (: $ds ::= =ready2);
)
$ds ::= =ready1;
}
}
ENDDOC
)
(define S #<<ENDDOC
# SPDX-License-Identifier: GPL-3.0-or-later
# SPDX-FileCopyrightText: Copyright © 2016-2023 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
import { SyndicateRollup } from "../../rollup.js";
const r = new SyndicateRollup("syndicate", { globalName: "Syndicate" });
export default [
r.config("lib/index.js", r.umd, {
output: {
globals: {
"crypto": "crypto",
},
},
}),
r.config("lib/index.js", r.es6, {
resolve: {
moduleDirectories: ["stubs", "node_modules"],
},
}),
];
ENDDOC
)
(parameterize ((pretty-print-columns 80)) (write-pexprs (string->pexprs P #:read-syntax? #t)) (newline))
(parameterize ((pretty-print-columns 10)) (write-pexprs (string->pexprs P #:read-syntax? #t)) (newline))
(parameterize ((pretty-print-columns 80)) (write-pexprs (string->pexprs Q #:read-syntax? #t)) (newline))
(parameterize ((pretty-print-columns 10)) (write-pexprs (string->pexprs Q #:read-syntax? #t)) (newline))
(parameterize ((pretty-print-columns 40)) (write-pexprs (string->pexprs R #:read-syntax? #t)) (newline))
(parameterize ((pretty-print-columns 40)) (write-pexprs (string->pexprs S #:read-syntax? #t)) (newline))