Merge branch 'master' of https://github.com/mbutterick/beautiful-racket
This commit is contained in:
Matthew Butterick
commit
99951f2f07
|
|
@ -30,70 +30,38 @@
|
|||
(parameterize ([cmd-line-mode? #t])
|
||||
(do-place)))))
|
||||
|
||||
|
||||
;; ==============================================================
|
||||
;; Process parse trees from the reader:
|
||||
|
||||
(provide txtadv-program)
|
||||
(define #'(txtadv-program _section ...)
|
||||
#'(module-begin _section ...))
|
||||
(define #'txtadv-program #'module-begin)
|
||||
|
||||
(provide verb-section)
|
||||
(define-inverting #'(verb-section _heading _verb-item ...)
|
||||
(define #'(verb-section
|
||||
((_name0 . _transitive0?)
|
||||
(_name . _transitive?) ... _desc) ...)
|
||||
(inject-syntax ([#'in-verbs (shared-syntax 'in-verbs)])
|
||||
#'(define-verbs in-verbs
|
||||
_verb-item ...)))
|
||||
|
||||
|
||||
(provide verb-item)
|
||||
(define-inverting #'(verb-item (_name0 _transitive0?) (_name _transitive?) ... _desc)
|
||||
#`[_name0 #,@(if (syntax->datum #'_transitive0?) #'(_) #'()) (= _name ...) _desc])
|
||||
|
||||
(provide verb-name)
|
||||
(define-cases #'verb-name
|
||||
;; cases with literals go first, so they're not caught by wildcards
|
||||
[#'(_ "," _id) #'(_id #f)]
|
||||
[#'(_ "," _id _underscore) #'(_id #t)]
|
||||
[#'(_ _id) #'(_id #f)]
|
||||
[#'(_ _id _underscore) #'(_id #t)])
|
||||
[_name0 #,@(if (syntax->datum #'_transitive0?) #'(_) #'()) (= _name ...) _desc] ...)))
|
||||
|
||||
(provide everywhere-section)
|
||||
(define-inverting #'(everywhere-section _heading [_name _desc] ...)
|
||||
(define #'(everywhere-section [_id _desc] ...)
|
||||
#'(define-everywhere everywhere-actions
|
||||
([_name _desc] ...)))
|
||||
|
||||
(provide id-desc)
|
||||
(define-inverting #'(id-desc _id _desc)
|
||||
#'(_id _desc))
|
||||
([_id _desc] ...)))
|
||||
|
||||
(provide things-section)
|
||||
(define-inverting #'(things-section _heading _thing ...)
|
||||
#'(begin _thing ...))
|
||||
|
||||
(provide thing-item)
|
||||
(define-inverting #'(thing-item _thingname (_actionname _actiondesc) ...)
|
||||
#'(define-thing _thingname [_actionname _actiondesc] ...))
|
||||
(define #'(things-section (_thingname (_actionname _actiondesc) ...) ...)
|
||||
#'(begin (define-thing _thingname [_actionname _actiondesc] ...) ...))
|
||||
|
||||
(provide places-section)
|
||||
(define-inverting #'(places-section _heading _placeitem ...)
|
||||
#'(begin _placeitem ...))
|
||||
|
||||
(provide place-item)
|
||||
(define-inverting #'(place-item _place-id _place-desc [_place-item ...] [_actionname _actiondesc] ...)
|
||||
#'(define-place _place-id _place-desc [_place-item ...] ([_actionname _actiondesc] ...)))
|
||||
|
||||
(provide place-descrip)
|
||||
(define #'(place-descrip _desc) #'_desc)
|
||||
|
||||
(provide place-items)
|
||||
(define-inverting #'(place-items "[" _id ... "]") #'(_id ...))
|
||||
|
||||
(provide place-name)
|
||||
(define-cases #'place-name
|
||||
[#'(_ "," _id) #'_id]
|
||||
[#'(_ _id) #'_id])
|
||||
|
||||
(define #'(places-section (_place-id _place-desc [_place-item ...] [_actionname _actiondesc] ...) ...)
|
||||
#'(begin (define-place _place-id _place-desc [_place-item ...] ([_actionname _actiondesc] ...)) ...))
|
||||
|
||||
(provide s-exp)
|
||||
(define-cases-inverting #'s-exp
|
||||
[#'(_ "(" _sx ... ")") #'(_sx ...)]
|
||||
[#'(_ _sx) #'_sx])
|
||||
[#'(_ _sx) #'_sx]
|
||||
[#'(_ _sx ... ) #'(_sx ...)])
|
||||
|
||||
|
||||
;; todo: consolidate the game-starters.
|
||||
|
|
@ -107,7 +75,7 @@
|
|||
everywhere-actions)))
|
||||
|
||||
(provide start-section)
|
||||
(define #'(start-section _heading _where)
|
||||
(define #'(start-section _where)
|
||||
(inject-syntax ([#'in-verbs (shared-syntax 'in-verbs)])
|
||||
#'(init-game _where
|
||||
in-verbs
|
||||
|
|
|
|||
|
|
@ -2,30 +2,26 @@
|
|||
|
||||
txtadv-program : verb-section everywhere-section things-section places-section start-section
|
||||
|
||||
verb-section : "===VERBS===" verb-item+
|
||||
verb-section : <"===VERBS==="> verb-item+
|
||||
|
||||
verb-item : verb-name+ s-exp
|
||||
<verb-item> : verb-name+ s-exp
|
||||
|
||||
verb-name : [","] ID ["_"]
|
||||
<verb-name> : [<",">] ID ["_"]
|
||||
|
||||
everywhere-section : "===EVERYWHERE===" id-desc+
|
||||
everywhere-section : <"===EVERYWHERE==="> id-desc+
|
||||
|
||||
things-section : "===THINGS===" thing-item+
|
||||
things-section : <"===THINGS==="> thing-item+
|
||||
|
||||
thing-item : DASHED-NAME id-desc+
|
||||
<thing-item> : DASHED-NAME id-desc+
|
||||
|
||||
places-section : "===PLACES===" place-item+
|
||||
places-section : <"===PLACES==="> place-item+
|
||||
|
||||
place-item : DASHED-NAME place-descrip place-items id-desc+
|
||||
<place-item> : DASHED-NAME STRING place-items id-desc+
|
||||
|
||||
place-descrip : STRING ; `place-desc` is already used in expander
|
||||
<place-items> : <"["> ([<",">] ID)* <"]">
|
||||
|
||||
place-items : "[" place-name* "]" ; `place-things` is already used
|
||||
start-section : <"===START==="> ID
|
||||
|
||||
place-name : [","] ID
|
||||
<id-desc> : ID s-exp
|
||||
|
||||
start-section : "===START===" place-name
|
||||
|
||||
id-desc : ID s-exp
|
||||
|
||||
s-exp : ID | STRING | "(" s-exp* ")"
|
||||
s-exp : ID | STRING | <"("> s-exp* <")">
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
#lang br
|
||||
#lang racket/base
|
||||
|
||||
(require (for-template racket/base)
|
||||
racket/list
|
||||
|
|
@ -38,25 +38,9 @@
|
|||
|
||||
;; We flatten the rules so we can use the yacc-style ruleset that parser-tools
|
||||
;; supports.
|
||||
|
||||
#|
|
||||
MB: `rules` still carries 'hide syntax property
|
||||
|#
|
||||
#;(report flattened-rules)
|
||||
|
||||
|
||||
#|
|
||||
MB: `flattened-rules` still carries 'hide syntax property
|
||||
|#
|
||||
(define flattened-rules (flatten-rules rules))
|
||||
#;(report flattened-rules)
|
||||
|
||||
(define generated-rule-codes (map flat-rule->yacc-rule flattened-rules))
|
||||
|
||||
#|
|
||||
MB: `generated-rule-codes` loses the 'hide syntax property
|
||||
|#
|
||||
#;(report generated-rule-codes)
|
||||
|
||||
;; The first rule, by default, is the start rule.
|
||||
(define rule-ids (for/list ([a-rule (in-list rules)])
|
||||
|
|
@ -179,7 +163,6 @@
|
|||
;; stx :== (name (U tokens rule-stx) ...)
|
||||
;;
|
||||
(define (flat-rule->yacc-rule a-flat-rule)
|
||||
#;(report a-flat-rule)
|
||||
(syntax-case a-flat-rule ()
|
||||
[(rule-type origin name clauses ...)
|
||||
(begin
|
||||
|
|
@ -216,29 +199,29 @@
|
|||
(for/list ([translated-pattern (in-list translated-patterns)]
|
||||
[primitive-pattern (syntax->list a-clause)]
|
||||
[pos (in-naturals 1)])
|
||||
(with-syntax ([$X
|
||||
(format-id translated-pattern "$~a" pos)]
|
||||
[$X-start-pos
|
||||
(format-id translated-pattern "$~a-start-pos" pos)]
|
||||
[$X-end-pos
|
||||
(format-id translated-pattern "$~a-end-pos" pos)])
|
||||
(syntax-case primitive-pattern (id lit token inferred-id)
|
||||
|
||||
;; When a rule usage is inferred, the value of $X is a syntax object
|
||||
;; whose head is the name of the inferred rule . We strip that out,
|
||||
;; leaving the residue to be absorbed.
|
||||
[(inferred-id val reason)
|
||||
#'(syntax-case $X ()
|
||||
[(inferred-rule-name . rest)
|
||||
(syntax->list #'rest)])]
|
||||
[(id val)
|
||||
#'(list $X)]
|
||||
;; move the 'hide syntax property into the translated-action
|
||||
;; because syntax gets datum-ized
|
||||
[(lit val)
|
||||
#`(list (atomic-datum->syntax $X $X-start-pos $X-end-pos #,(syntax-property primitive-pattern 'hide)))]
|
||||
[(token val)
|
||||
#`(list (atomic-datum->syntax $X $X-start-pos $X-end-pos #,(syntax-property primitive-pattern 'hide)))]))))
|
||||
(if (syntax-property primitive-pattern 'hide)
|
||||
#'null
|
||||
(with-syntax ([$X
|
||||
(format-id translated-pattern "$~a" pos)]
|
||||
[$X-start-pos
|
||||
(format-id translated-pattern "$~a-start-pos" pos)]
|
||||
[$X-end-pos
|
||||
(format-id translated-pattern "$~a-end-pos" pos)])
|
||||
(syntax-case primitive-pattern (id lit token inferred-id)
|
||||
|
||||
;; When a rule usage is inferred, the value of $X is a syntax object
|
||||
;; whose head is the name of the inferred rule . We strip that out,
|
||||
;; leaving the residue to be absorbed.
|
||||
[(inferred-id val reason)
|
||||
#'(syntax-case $X ()
|
||||
[(inferred-rule-name . rest)
|
||||
(syntax->list #'rest)])]
|
||||
[(id val)
|
||||
#'(list $X)]
|
||||
[(lit val)
|
||||
#'(list (atomic-datum->syntax $X $X-start-pos $X-end-pos))]
|
||||
[(token val)
|
||||
#'(list (atomic-datum->syntax $X $X-start-pos $X-end-pos))])))))
|
||||
|
||||
(define whole-rule-loc
|
||||
(if (empty? translated-patterns)
|
||||
|
|
@ -246,12 +229,14 @@
|
|||
(with-syntax ([$1-start-pos (datum->syntax (first translated-patterns) '$1-start-pos)]
|
||||
[$n-end-pos (format-id (last translated-patterns) "$~a-end-pos" (length translated-patterns))])
|
||||
#`(positions->srcloc $1-start-pos $n-end-pos))))
|
||||
|
||||
|
||||
;; move 'splice property into function because name is datum-ized
|
||||
(with-syntax ([(translated-pattern ...) translated-patterns]
|
||||
[(translated-action ...) translated-actions])
|
||||
#`[(translated-pattern ...)
|
||||
(rule-components->syntax '#,rule-name/false translated-action ...
|
||||
#:srcloc #,whole-rule-loc)]))
|
||||
#:srcloc #,whole-rule-loc
|
||||
#:splice? #,(syntax-property rule-name/false 'splice))]))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang br
|
||||
#lang racket/base
|
||||
(require brag/rules/stx-types
|
||||
(for-syntax racket/base))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang br
|
||||
#lang racket/base
|
||||
|
||||
(require racket/match
|
||||
racket/list
|
||||
|
|
@ -150,26 +150,30 @@ This would be the place to check a syntax property for hiding.
|
|||
(define stx-with-original?-property
|
||||
(read-syntax #f (open-input-string "meaningless-string")))
|
||||
|
||||
(define elided (gensym))
|
||||
|
||||
;; atomic-datum->syntax: datum position position
|
||||
;; Helper that does the ugly work in wrapping a datum into a syntax
|
||||
;; with source location.
|
||||
(define (atomic-datum->syntax d start-pos end-pos [hide? #f])
|
||||
(if hide?
|
||||
elided
|
||||
(datum->syntax #f d (positions->srcloc start-pos end-pos) stx-with-original?-property)))
|
||||
|
||||
(define (atomic-datum->syntax d start-pos end-pos)
|
||||
(datum->syntax #f d (positions->srcloc start-pos end-pos) stx-with-original?-property))
|
||||
|
||||
|
||||
(define splice-signal '@)
|
||||
;; rule-components->syntax: (U symbol false) (listof stx) ... #:srcloc (U #f (list src line column offset span)) -> stx
|
||||
;; Creates an stx out of the rule name and its components.
|
||||
;; The location information of the rule spans that of its components.
|
||||
(define (rule-components->syntax rule-name/false #:srcloc [srcloc #f] . components)
|
||||
(define flattened-elided-components (filter-not (λ(c) (eq? c elided)) (apply append components)))
|
||||
(datum->syntax #f
|
||||
(cons
|
||||
(datum->syntax #f rule-name/false srcloc stx-with-original?-property)
|
||||
flattened-elided-components)
|
||||
srcloc
|
||||
stx-with-original?-property))
|
||||
(define (rule-components->syntax rule-name/false #:srcloc [srcloc #f] #:splice? [splice #f] . componentss)
|
||||
(let ([spliced-componentss (append-map (λ(cs)
|
||||
(if (and (pair? cs) (syntax-property (car cs) 'splice))
|
||||
(list (list (syntax-case (car cs) ()
|
||||
[(rule-name c ...)
|
||||
#'(c ...)])))
|
||||
(list cs))) componentss)])
|
||||
(syntax-property
|
||||
(datum->syntax #f
|
||||
(cons
|
||||
(datum->syntax #f rule-name/false srcloc stx-with-original?-property)
|
||||
(apply append spliced-componentss))
|
||||
srcloc
|
||||
stx-with-original?-property)
|
||||
'splice splice)))
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
#lang brag
|
||||
|
||||
;; Simple baby example of JSON structure
|
||||
json: ID <":"> ID
|
||||
|
|
@ -1,8 +1,7 @@
|
|||
#lang brag
|
||||
|
||||
;; Simple baby example of JSON structure
|
||||
json: number
|
||||
| string
|
||||
json: number | string
|
||||
| array
|
||||
| object
|
||||
|
||||
|
|
@ -14,4 +13,4 @@ array: "[" [json ("," json)*] "]"
|
|||
|
||||
object: <"{"> [kvpair ("," kvpair)*] <"}">
|
||||
|
||||
kvpair: <ID> <":"> json
|
||||
<kvpair>: <ID> ":" <json>
|
||||
|
|
@ -22,9 +22,6 @@
|
|||
(:+ id-char)))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define lex/1
|
||||
(lexer-src-pos
|
||||
[(:: "'"
|
||||
|
|
@ -64,6 +61,8 @@
|
|||
(token-EOF lexeme)]
|
||||
[(:: id (:* whitespace) ":")
|
||||
(token-RULE_HEAD lexeme)]
|
||||
[(:: "<" id ">" (:* whitespace) ":")
|
||||
(token-RULE_HEAD_HIDDEN lexeme)]
|
||||
[id
|
||||
(token-ID lexeme)]
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang br
|
||||
#lang racket/base
|
||||
(require parser-tools/yacc
|
||||
parser-tools/lex
|
||||
racket/list
|
||||
|
|
@ -17,6 +17,7 @@
|
|||
token-PIPE
|
||||
token-REPEAT
|
||||
token-RULE_HEAD
|
||||
token-RULE_HEAD_HIDDEN
|
||||
token-ID
|
||||
token-LIT
|
||||
token-EOF
|
||||
|
|
@ -45,6 +46,7 @@
|
|||
PIPE
|
||||
REPEAT
|
||||
RULE_HEAD
|
||||
RULE_HEAD_HIDDEN
|
||||
ID
|
||||
LIT
|
||||
EOF))
|
||||
|
|
@ -84,6 +86,21 @@
|
|||
(position-col $1-start-pos))
|
||||
trimmed
|
||||
#f)
|
||||
$2))]
|
||||
|
||||
;; angles indicate splicing. set splice value to #t
|
||||
[(RULE_HEAD_HIDDEN pattern)
|
||||
(begin
|
||||
(define trimmed (cadr (regexp-match #px"<(.+)>\\s*:$" $1)))
|
||||
(rule (position->pos $1-start-pos)
|
||||
(position->pos $2-end-pos)
|
||||
(lhs-id (position->pos $1-start-pos)
|
||||
(pos (+ (position-offset $1-start-pos)
|
||||
(string-length trimmed))
|
||||
(position-line $1-start-pos)
|
||||
(position-col $1-start-pos))
|
||||
trimmed
|
||||
#t)
|
||||
$2))]]
|
||||
|
||||
[pattern
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@
|
|||
(struct rule (start end lhs pattern)
|
||||
#:transparent)
|
||||
|
||||
(struct lhs-id (start end val hide)
|
||||
(struct lhs-id (start end val splice)
|
||||
#:transparent)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang br
|
||||
#lang racket/base
|
||||
|
||||
(require "rule-structs.rkt"
|
||||
parser-tools/lex
|
||||
|
|
@ -21,17 +21,19 @@
|
|||
|
||||
(define (rule->stx source a-rule)
|
||||
(define id-stx
|
||||
(datum->syntax #f
|
||||
(string->symbol (lhs-id-val (rule-lhs a-rule)))
|
||||
(list source
|
||||
(pos-line (lhs-id-start (rule-lhs a-rule)))
|
||||
(pos-col (lhs-id-start (rule-lhs a-rule)))
|
||||
(pos-offset (lhs-id-start (rule-lhs a-rule)))
|
||||
(if (and (number? (pos-offset (lhs-id-start (rule-lhs a-rule))))
|
||||
(number? (pos-offset (lhs-id-end (rule-lhs a-rule)))))
|
||||
(- (pos-offset (lhs-id-end (rule-lhs a-rule)))
|
||||
(pos-offset (lhs-id-start (rule-lhs a-rule))))
|
||||
#f))))
|
||||
(syntax-property
|
||||
(datum->syntax #f
|
||||
(string->symbol (lhs-id-val (rule-lhs a-rule)))
|
||||
(list source
|
||||
(pos-line (lhs-id-start (rule-lhs a-rule)))
|
||||
(pos-col (lhs-id-start (rule-lhs a-rule)))
|
||||
(pos-offset (lhs-id-start (rule-lhs a-rule)))
|
||||
(if (and (number? (pos-offset (lhs-id-start (rule-lhs a-rule))))
|
||||
(number? (pos-offset (lhs-id-end (rule-lhs a-rule)))))
|
||||
(- (pos-offset (lhs-id-end (rule-lhs a-rule)))
|
||||
(pos-offset (lhs-id-start (rule-lhs a-rule))))
|
||||
#f)))
|
||||
'splice (lhs-id-splice (rule-lhs a-rule))))
|
||||
(define pattern-stx (pattern->stx source (rule-pattern a-rule)))
|
||||
(define line (pos-line (rule-start a-rule)))
|
||||
(define column (pos-col (rule-start a-rule)))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang br
|
||||
#lang racket/base
|
||||
|
||||
|
||||
(require "test-0n1.rkt"
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
#lang br
|
||||
(require "json-elider.rkt"
|
||||
#lang racket/base
|
||||
(require brag/examples/baby-json-hider
|
||||
brag/support
|
||||
rackunit)
|
||||
|
||||
|
|
@ -10,7 +10,7 @@
|
|||
":"
|
||||
(token 'STRING "'hello world'")
|
||||
"}")))
|
||||
'(json (object (kvpair (json (string "'hello world'"))))))
|
||||
'(json (object (":"))))
|
||||
|
||||
|
||||
(check-equal?
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
#lang br
|
||||
#lang racket/base
|
||||
|
||||
|
||||
(require rackunit
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user