94 lines
4.8 KiB
Scheme
94 lines
4.8 KiB
Scheme
(module structs scheme/base
|
|
|
|
(provide (all-defined-out))
|
|
|
|
(require parser-tools/lex)
|
|
|
|
;fail-src: (list line col pos span loc)
|
|
|
|
;make-src-lst: position position -> src-list
|
|
(define (make-src-lst start end)
|
|
(list (position-line start)
|
|
(position-col start)
|
|
(position-offset start)
|
|
(- (position-offset end)
|
|
(position-offset start))))
|
|
|
|
;(make-fail-type float fail-src string int int)
|
|
(define-struct fail-type (chance src name used may-use) #:transparent #:mutable)
|
|
;(make-terminal-fail float fail-src string symbol 'a)
|
|
(define-struct (terminal-fail fail-type) (kind found))
|
|
;(make-sequence-fail float fail-src string symbol (list string) string 'a boolean string)
|
|
(define-struct (sequence-fail fail-type) (id kind correct expected found repeat? last-seen))
|
|
;(make-choice-fail float fail-src string int (list string) (list fail-type) boolean)
|
|
(define-struct (choice-fail fail-type) (options names ended? (messages #:mutable)) #:transparent)
|
|
;(make-options-fail float #f #f (list fail-type))
|
|
(define-struct (options-fail fail-type) ((opts #:mutable)))
|
|
|
|
;result = res | choice-res | repeat-res | (listof (U res choice-res))
|
|
|
|
;(make-res (U #f (listof 'b)) (listof 'a) (U string fail-type) (U string 'a) int) [U #f fail-type] token
|
|
(define-struct res (a rest msg id used possible-error first-tok) #:transparent)
|
|
;make-choice-res string (listof res) fail-type)
|
|
(define-struct choice-res (name matches errors) #:transparent)
|
|
;(make-repeat-res answer (U symbol fail-type))
|
|
(define-struct repeat-res (a stop) #:transparent)
|
|
;(make-lazy-opts (listof res) fail-type (listof (_ => res)))
|
|
(define-struct lazy-opts ((matches #:mutable) errors (thunks #:mutable)) #:transparent)
|
|
;(make-lazy-choice (listof res) fail-type (listof (_ -> res)) string)
|
|
(define-struct (lazy-choice lazy-opts) (name) #:transparent)
|
|
|
|
(define (update-lazy-errors failc mss)
|
|
(set-fail-type-chance! failc (max (fail-type-chance failc) (fail-type-chance mss)))
|
|
(set-fail-type-used! failc (max (fail-type-used failc) (fail-type-used mss)))
|
|
(set-fail-type-may-use! failc (max (fail-type-may-use failc) (fail-type-may-use mss)))
|
|
(if (choice-fail? failc)
|
|
(set-choice-fail-messages! failc (cons mss (choice-fail-messages failc)))
|
|
(set-options-fail-opts! failc (cons mss (options-fail-opts failc)))))
|
|
|
|
|
|
(define (next-opt lc)
|
|
(letrec ([next
|
|
(lambda (lc update-errors)
|
|
#;(printf "next-opt ~a~n" lc)
|
|
(cond
|
|
[(null? (lazy-opts-thunks lc)) #f]
|
|
[else
|
|
(let ([curr-res ((car (lazy-opts-thunks lc)))])
|
|
(unless (null? (lazy-opts-thunks lc))
|
|
(set-lazy-opts-thunks! lc (cdr (lazy-opts-thunks lc))))
|
|
(cond
|
|
[(and (not curr-res) (null? (lazy-opts-thunks lc))) curr-res]
|
|
[(and (not curr-res) (not (null? (lazy-opts-thunks lc)))) (next lc update-errors)]
|
|
[(or (and (res? curr-res) (res-a curr-res)) (repeat-res? curr-res))
|
|
(set-lazy-opts-matches! lc (cons curr-res (lazy-opts-matches lc)))
|
|
curr-res]
|
|
[(lazy-opts? curr-res)
|
|
(let* ([next-matches (map (lambda (m) (lambda () m)) (lazy-opts-matches curr-res))]
|
|
[remaining (map (lambda (t)
|
|
(lambda ()
|
|
(next curr-res
|
|
(lambda (_ msg) (update-lazy-errors (lazy-opts-errors curr-res) msg)))))
|
|
(lazy-opts-thunks curr-res))])
|
|
(set-lazy-opts-thunks! lc (append next-matches remaining (lazy-opts-thunks lc)))
|
|
(update-errors (lazy-opts-errors lc) (lazy-opts-errors curr-res))
|
|
(next lc update-errors))]
|
|
[else
|
|
(update-errors (lazy-opts-errors lc)
|
|
(cond
|
|
[(res? curr-res) (res-msg curr-res)]
|
|
[else (error 'next (format "Internal error: failure other than res ~a" curr-res))]))
|
|
(next lc update-errors)]))]))])
|
|
(next lc update-lazy-errors)))
|
|
|
|
(define (update-lazy-opts old-opts matches thunks)
|
|
(cond
|
|
[(lazy-choice? old-opts)
|
|
(make-lazy-choice matches (lazy-opts-errors old-opts) thunks (lazy-choice-name old-opts))]
|
|
[(lazy-opts? old-opts)
|
|
(make-lazy-opts matches (lazy-opts-errors old-opts) thunks)]))
|
|
|
|
(define (fail-res rst msg) (make-res #f rst msg "" 0 #f #f))
|
|
|
|
)
|