Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Control Layout and Parser define id namings.

  • Loading branch information...
commit dc2ef5f2bc527565693ce957493ba7b46939bda7 1 parent aa91947
@RayRacine authored
Showing with 30 additions and 20 deletions.
  1. +3 −3 RpR/format/layout.rkt
  2. +27 −17 RpR/format/parser.rkt
View
6 RpR/format/layout.rkt
@@ -1,7 +1,7 @@
#lang typed/racket/base
(provide
- layout)
+ define-fixed-layout)
(require
(only-in "layout-types.rkt" Field Layout)
@@ -12,7 +12,7 @@
format-id)
(only-in "layout-types.rkt" Field Layout)))
-(define-syntax (layout stx)
+(define-syntax (define-fixed-layout stx)
(define-syntax-class field
(pattern (fid:id type:id length:nat)))
@@ -53,7 +53,7 @@
[(_ name:id f0:field f1:field ...)
(with-syntax ((lo #`(list #,@(field-syntax-with-offsets
(syntax->list #'(f0 f1 ...)))))
- (desc-name (format-id #'name "~a-desc" (syntax-e #'name))))
+ (desc-name (format-id #'name "~a-desc" (syntax-e #'name))))
(let ((name-id (symbol->string (syntax->datum #'name))))
#'(begin
(define-syntax desc-name (Layout 'name lo))
View
44 RpR/format/parser.rkt
@@ -1,11 +1,14 @@
#lang typed/racket/base
-(provide define-parser-for-layout)
+(provide define-static-parser-for-layout)
+
+(require/typed racket
+ [string-trim (String -> String)])
(require
(for-syntax
racket/pretty
- typed/racket/base
+ typed/racket/base
syntax/parse
(only-in racket/syntax
format-id)
@@ -33,31 +36,38 @@
(: build-struct-field-syntax ((Listof Field) -> Syntax))
(define (build-struct-field-syntax fields)
(for/list ([field fields])
- #`[#,(Field-name field) : #,(Field-type field)]))
+ #`[#,(Field-name field) : #,(Field-type field)]))
(: build-parser-let-bindings ((Listof Field) -> Syntax))
(define (build-parser-let-bindings fields)
- (for/list ([field fields])
- (let ((name (Field-name field))
- (type (Field-type field))
- (start (Field-offset field)))
- (let ((end (sub1 (+ start (Field-length field)))))
- #`(#,name : #,type (substring line #,start #,end))))))
+ (for/list ([field fields])
+ (let ((name (Field-name field))
+ (type (Field-type field))
+ (start (Field-offset field)))
+ (let ((end (+ start (Field-length field))))
+ (case type
+ ((String) #`(#,name : #,type (string-trim (substring line #,start #,end))))
+ ((Symbol) #`(#,name : #,type (string->symbol (substring line #,start #,end))))
+ (else #`(#,name : #,type (substring line #,start #,end))))))))
(: build-ctor-args ((Listof Field) -> Syntax))
(define (build-ctor-args fields)
(for/list ([field fields])
#`#,(Field-name field)))
- )
-
-(define-syntax (define-parser-for-layout stx)
+ (: extract-base-name (Syntax Symbol -> Syntax))
+ (define (extract-base-name stx full-name)
+ (define base (car (regexp-split #rx"-" (symbol->string full-name))))
+ (datum->syntax stx (string->symbol base))))
+
+(define-syntax (define-static-parser-for-layout stx)
(syntax-parse stx
- [(_ name:id (f0:id f1:id ...))
- (let ((sname (syntax-e #'name)))
- (with-syntax ((desc-name (format-id #'name "~a-desc" sname))
- (parser-name (format-id #'name "~a-parser" sname))
- (parser-struct (format-id #'name "~a-fields" sname)))
+ [(_ (parser-name:id layout-name:id) (f0:id f1:id ...))
+ (let* ((full-name (syntax-e #'layout-name))
+ (base-name (extract-base-name stx full-name)))
+ (with-syntax ((desc-name (format-id #'layout-name "~a-desc" full-name))
+ ;(parser-name (format-id #'layout-name "~a-parser" base-name))
+ (parser-struct (format-id #'layout-name "~a" base-name)))
(let ((pfields (fields-to-project
(syntax-local-value #'desc-name)
(syntax->list #'(f0 f1 ...)))))
Please sign in to comment.
Something went wrong with that request. Please try again.