Remove old packages
The following packages were removed:
- combinator-parser
(see `asumu/combinator-parser` on PLaneT)
- tex2page
(see `asumu/tex2page` on PLaneT)
- test-box-recovery
This commit is contained in:
Asumu Takikawa
parent
05b88930c0
commit
b33509bc0d
|
|
@ -1,11 +0,0 @@
|
||||||
(module combinator-unit mzscheme
|
|
||||||
|
|
||||||
(require "private-combinator/combinator-parser.scm"
|
|
||||||
"private-combinator/parser-sigs.rkt")
|
|
||||||
|
|
||||||
(provide combinator-parser-tools@
|
|
||||||
combinator-parser^ err^
|
|
||||||
error-format-parameters^ language-format-parameters^ language-dictionary^
|
|
||||||
terminals recurs)
|
|
||||||
|
|
||||||
)
|
|
||||||
|
|
@ -1,133 +0,0 @@
|
||||||
_combinator-parser_
|
|
||||||
|
|
||||||
This documentation provides directions on using the combinator parser library. It assumes familiarity with lexing and with combinator parsers.
|
|
||||||
|
|
||||||
_combinator-unit.ss_
|
|
||||||
This library provides a unit implementing four higher-order functions
|
|
||||||
that can be used to build a combinator parser, and the export and
|
|
||||||
import signatures related to it. The functions contained in this unit
|
|
||||||
automatically build error reporting mechanisms in the event that no parse
|
|
||||||
is found. Unlike other combinator parsers, this system assumes that the
|
|
||||||
input is already lexed into tokens using _lex.ss_. This library relies on
|
|
||||||
_(lib "lazy.ss" "lazy")_.
|
|
||||||
|
|
||||||
The unit _combinator-parser-tools_ exports the signature
|
|
||||||
_combinator-parser^_ and imports the signatures _error-format-parameters^_, _language-format-parameters^_, and _language-dictionary^_.
|
|
||||||
|
|
||||||
The signature combinator-parser^ references functions to build combinators,
|
|
||||||
a function to build a runable parser using a combinator, a structure for
|
|
||||||
recording errors and macro definitions to specify combinators with:
|
|
||||||
|
|
||||||
>(terminal predicate result name spell-check case-check type-check) ->
|
|
||||||
(list token) -> parser-result
|
|
||||||
The returned function accepts one terminal from a token stream, and
|
|
||||||
returns produces an opaque value that interacts with other combinators.
|
|
||||||
|
|
||||||
predicate: token -> boolean - check that the token is the expected one
|
|
||||||
result: token -> beta - create the ast node for this terminal
|
|
||||||
name: string - human-language name for this terminal
|
|
||||||
spell-check, case-check, type-check: (U bool (token -> bool))
|
|
||||||
optional arguments, default to #f, perform spell checking, case
|
|
||||||
checking, and kind checking on incorrect tokens
|
|
||||||
|
|
||||||
>(seq sequence result name) -> (list token) -> parser-result
|
|
||||||
The returned function accepts a term made up of a sequence of smaller
|
|
||||||
terms, and produces an opaque value that interacts with other
|
|
||||||
combinators.
|
|
||||||
|
|
||||||
sequence: (listof ((list token) -> parser-result)) - the subterms
|
|
||||||
result: (list alpha) -> beta - create the ast node for this sequence.
|
|
||||||
Input list matches length of sequence list
|
|
||||||
name: human-language name for this term
|
|
||||||
|
|
||||||
>(choice options name) -> (list token) -> parser-result
|
|
||||||
The returned function selects between different terms, and produces an
|
|
||||||
opaque value that interacts with other combinators
|
|
||||||
|
|
||||||
options: (listof ((list token) -> parser-result) - the possible terms
|
|
||||||
name: human-language name for this term
|
|
||||||
|
|
||||||
>(repeat term) -> (list token) -> parser-result
|
|
||||||
The returned function accepts 0 or more instances of term, and produces
|
|
||||||
an opaque value that interacts with other combinators
|
|
||||||
|
|
||||||
term: (list token) -> parser-result
|
|
||||||
|
|
||||||
>(parser term) -> (list token) location -> ast-or-error
|
|
||||||
Returns a function that parses a list of tokens, producing either the
|
|
||||||
result of calling all appropriate result functions or an err
|
|
||||||
|
|
||||||
term: (list token) -> parser-result
|
|
||||||
location: string | editor
|
|
||||||
Either the string representing the file name or the editor being read,
|
|
||||||
typically retrieved from file-path
|
|
||||||
ast-or-error: AST | err
|
|
||||||
AST is the result of calling the given result function
|
|
||||||
|
|
||||||
The err structure is:
|
|
||||||
>(make-err string source-list)
|
|
||||||
|
|
||||||
>(err-msg err) -> string
|
|
||||||
The error message
|
|
||||||
>(err-src err) -> (list location line-k col-k pos-k span-k)
|
|
||||||
This list is suitable for calling raise-read-error,
|
|
||||||
*-k are positive integers
|
|
||||||
|
|
||||||
The language forms provided are:
|
|
||||||
>(define-simple-terminals NAME (simple-spec ...))
|
|
||||||
Expands to a define-empty-tokens and one terminal definition per
|
|
||||||
simple-spec
|
|
||||||
|
|
||||||
NAME is an identifier specifying a group of tokens
|
|
||||||
|
|
||||||
simple-spec = NAME | (NAME string) | (NAME proc) | (NAME string proc)
|
|
||||||
NAME is an identifier specifying a token/terminal with no value
|
|
||||||
proc: token -> ast - A procedure from tokens to AST nodes. id is used
|
|
||||||
by default. The token will be a symbol.
|
|
||||||
string is the human-language name for the terminal, NAME is used by
|
|
||||||
default
|
|
||||||
|
|
||||||
>(define-terminals NAME (terminal-spec ...))
|
|
||||||
Like define-simple-terminals, except uses define-tokens
|
|
||||||
|
|
||||||
terminal-spec = (NAME proc) | (NAME string proc)
|
|
||||||
proc: token -> ast - a procedure from tokens to AST node.
|
|
||||||
The token will be the token defined as NAME and will be a value token.
|
|
||||||
|
|
||||||
>(sequence (NAME ...) proc string)
|
|
||||||
Generates a call to seq with the specified names in a list,
|
|
||||||
proc => result and string => name.
|
|
||||||
The name can be omitted when nested in another sequence or choose
|
|
||||||
|
|
||||||
>(sequence (NAME_ID ...) proc string)
|
|
||||||
where NAME_ID is either NAME or (^ NAME)
|
|
||||||
The ^ form identifies a parser production that can be used to identify
|
|
||||||
this production in an error message. Otherwise the same as above
|
|
||||||
|
|
||||||
>(choose (NAME ...) string)
|
|
||||||
Generates a call to choice using the given terms as the list of options,
|
|
||||||
string => name.
|
|
||||||
The name can be omitted when nested in another sequence or choose
|
|
||||||
|
|
||||||
>(eta NAME)
|
|
||||||
Eta expands name with a wrapping that properly mimcs a parser term
|
|
||||||
|
|
||||||
The _error-format-parameters^_ signature requires five names:
|
|
||||||
src?: boolean- will the lexer include source information
|
|
||||||
input-type: string- used to identify the source of input
|
|
||||||
show-options: boolean- presently ignored
|
|
||||||
max-depth: int- The depth of errors reported
|
|
||||||
max-choice-depth: int- The max number of options listed in an error
|
|
||||||
|
|
||||||
The _language-format-parameters^_ requires two names
|
|
||||||
class-type: string - general term for language keywords
|
|
||||||
input->output-name: token -> string - translates tokens into strings
|
|
||||||
|
|
||||||
The _language-dictionary^_ requires three names
|
|
||||||
misspelled: string string -> number -
|
|
||||||
check the spelling of the second arg against the first, return a number
|
|
||||||
that is the probability that the second is a misspelling of the first
|
|
||||||
misscap: string string -> boolean -
|
|
||||||
check the capitalization of the second arg against the first
|
|
||||||
missclass: string string -> boolean -
|
|
||||||
check if the second arg names a correct token kind
|
|
||||||
|
|
@ -1,63 +0,0 @@
|
||||||
(module combinator-example scheme/base
|
|
||||||
|
|
||||||
(require scheme/unit
|
|
||||||
parser-tools/lex
|
|
||||||
combinator-parser/combinator-unit)
|
|
||||||
|
|
||||||
(define-unit support
|
|
||||||
(import)
|
|
||||||
(export error-format-parameters^
|
|
||||||
language-format-parameters^
|
|
||||||
language-dictionary^)
|
|
||||||
|
|
||||||
(define src? #t)
|
|
||||||
(define input-type "file")
|
|
||||||
(define show-options #f)
|
|
||||||
(define max-depth 1)
|
|
||||||
(define max-choice-depth 2)
|
|
||||||
|
|
||||||
(define class-type "keyword")
|
|
||||||
(define (input->output-name t) (token-name t))
|
|
||||||
|
|
||||||
(define (misspelled s1 s2)
|
|
||||||
(and (equal? s1 "lam")
|
|
||||||
(equal? s2 "lambda")))
|
|
||||||
(define (misscap s1 s2)
|
|
||||||
(and (equal? s1 "lam")
|
|
||||||
(equal? s2 "Lam")))
|
|
||||||
(define (missclass s1 s2) #f)
|
|
||||||
)
|
|
||||||
|
|
||||||
(define-signature parser^ (parse-prog))
|
|
||||||
|
|
||||||
(define-unit lambda-calc
|
|
||||||
(import combinator-parser^)
|
|
||||||
(export parser^)
|
|
||||||
|
|
||||||
(define-simple-terminals keywords
|
|
||||||
(lam (O_paren "(") (C_paren ")")))
|
|
||||||
|
|
||||||
(define string->symbol*
|
|
||||||
(case-lambda
|
|
||||||
[(one) (string->symbol one)]
|
|
||||||
[(one two three) (error 'string->symbol* "Cannot accept so many arguments")]))
|
|
||||||
|
|
||||||
(define-terminals ids
|
|
||||||
((id "variable" string->symbol*) (number (lambda (x) (read (open-input-string x))))))
|
|
||||||
|
|
||||||
(define app
|
|
||||||
(sequence (O_paren (repeat (eta expr)) C_paren)
|
|
||||||
(lambda (id) id)
|
|
||||||
"application"))
|
|
||||||
|
|
||||||
(define func
|
|
||||||
(sequence (O_paren lam O_paren (repeat id) (eta expr))
|
|
||||||
(lambda (id) id)
|
|
||||||
"function"))
|
|
||||||
|
|
||||||
(define expr (choose (id number app func) "expression"))
|
|
||||||
|
|
||||||
(define parse-prog (parser expr))
|
|
||||||
)
|
|
||||||
|
|
||||||
)
|
|
||||||
|
|
@ -1,3 +0,0 @@
|
||||||
#lang setup/infotab
|
|
||||||
|
|
||||||
(define compile-omit-paths '("examples"))
|
|
||||||
|
|
@ -1,217 +0,0 @@
|
||||||
(module combinator-parser scheme/base
|
|
||||||
|
|
||||||
(require scheme/list
|
|
||||||
scheme/unit
|
|
||||||
parser-tools/lex)
|
|
||||||
(require "structs.scm" "parser-sigs.ss" "combinator.scm" "errors.scm")
|
|
||||||
|
|
||||||
(provide combinator-parser-tools@)
|
|
||||||
|
|
||||||
(define-unit main-parser@
|
|
||||||
(import error^ out^ error-format-parameters^ language-format-parameters^ ranking-parameters^)
|
|
||||||
(export parser^)
|
|
||||||
|
|
||||||
(define (sort-used reses)
|
|
||||||
(sort reses
|
|
||||||
(lambda (a b) (> (res-used a) (res-used b)))))
|
|
||||||
(define (sort-repeats repeats)
|
|
||||||
(sort repeats
|
|
||||||
(lambda (a b) (> (res-used (repeat-res-a a))
|
|
||||||
(res-used (repeat-res-a b))))))
|
|
||||||
|
|
||||||
(define (parser start)
|
|
||||||
(lambda (input file)
|
|
||||||
(let* ([first-src (and src? (pair? input)
|
|
||||||
(make-src-lst (position-token-start-pos (car input))
|
|
||||||
(position-token-end-pos (car input))))]
|
|
||||||
[result (if first-src (start input first-src) (start input))]
|
|
||||||
[out
|
|
||||||
(cond
|
|
||||||
[(and (res? result) (res-a result) (null? (res-rest result)))
|
|
||||||
(car (res-a result))]
|
|
||||||
[(and (res? result) (res-a result) (res-possible-error result))
|
|
||||||
(fail-type->message (res-possible-error result))]
|
|
||||||
[(and (res? result) (res-a result))
|
|
||||||
(make-err
|
|
||||||
(format "Found extraneous input after ~a, starting with ~a, at the end of ~a."
|
|
||||||
(res-msg result)
|
|
||||||
(input->output-name (car (res-rest result))) input-type)
|
|
||||||
(and src?
|
|
||||||
(make-src-lst (position-token-start-pos (car (res-rest result)))
|
|
||||||
(position-token-end-pos (car (res-rest result))))))]
|
|
||||||
[(res? result)
|
|
||||||
(fail-type->message (res-msg result))]
|
|
||||||
[(lazy-opts? result)
|
|
||||||
#;(printf "lazy-opts ~a\n" result)
|
|
||||||
(let* ([finished? (lambda (o)
|
|
||||||
(cond [(res? o)
|
|
||||||
(and (not (null? (res-a o)))
|
|
||||||
(null? (res-rest o)))]
|
|
||||||
[(repeat-res? o)
|
|
||||||
(eq? (repeat-res-stop o) 'out-of-input)]
|
|
||||||
[else #f]))]
|
|
||||||
[possible-errors
|
|
||||||
(lambda (matches)
|
|
||||||
(map (lambda (r)
|
|
||||||
(or (and (res? r) (res-possible-error r))
|
|
||||||
(and (repeat-res? r) (repeat-res-stop r))))
|
|
||||||
(filter (lambda (r)
|
|
||||||
(or (and (res? r) (res-possible-error r))
|
|
||||||
(and (repeat-res? r) (fail-type? (repeat-res-stop r)))))
|
|
||||||
matches)))]
|
|
||||||
[result-a
|
|
||||||
(lambda (res)
|
|
||||||
(cond
|
|
||||||
[(res? res) (res-a res)]
|
|
||||||
[(and (repeat-res? res)
|
|
||||||
(res? (repeat-res-a res)))
|
|
||||||
(res-a (repeat-res-a res))]
|
|
||||||
[else
|
|
||||||
(error 'parser-internal-errorcl (format "~a" res))]))])
|
|
||||||
(let loop ([matched (lazy-opts-matches result)])
|
|
||||||
(cond
|
|
||||||
[(and (pair? matched) (finished? (car matched))) (result-a (car matched))]
|
|
||||||
[(pair? matched) (loop (cdr matched))]
|
|
||||||
[(and matched (finished? matched)) (result-a matched)]
|
|
||||||
[(or (null? matched) matched) (loop (next-opt result))]
|
|
||||||
[else
|
|
||||||
(let ([p-errors (possible-errors (lazy-opts-matches result))])
|
|
||||||
(cond
|
|
||||||
[(pair? p-errors)
|
|
||||||
(let ([fails (cons (lazy-opts-errors result) p-errors)])
|
|
||||||
#;(printf "\nfails ~a\n\n" fails)
|
|
||||||
(fail-type->message
|
|
||||||
(make-options-fail (rank-choice (map fail-type-chance fails))
|
|
||||||
#f
|
|
||||||
(if (lazy-choice? result)
|
|
||||||
(lazy-choice-name result) "program")
|
|
||||||
(rank-choice (map fail-type-used fails))
|
|
||||||
(rank-choice (map fail-type-may-use fails))
|
|
||||||
fails)))]
|
|
||||||
[(null? p-errors)
|
|
||||||
(fail-type->message (lazy-opts-errors result))]))])))]
|
|
||||||
[(or (choice-res? result) (pair? result))
|
|
||||||
#;(printf "choice-res or pair? ~a\n" result)
|
|
||||||
(let* ([options (if (choice-res? result) (choice-res-matches result) result)]
|
|
||||||
[finished-options (filter (lambda (o)
|
|
||||||
(cond [(res? o)
|
|
||||||
(and (not (null? (res-a o)))
|
|
||||||
(null? (res-rest o)))]
|
|
||||||
[(repeat-res? o)
|
|
||||||
(eq? (repeat-res-stop o) 'out-of-input)]))
|
|
||||||
options)]
|
|
||||||
[possible-repeat-errors
|
|
||||||
(filter (lambda (r) (and (repeat-res? r)
|
|
||||||
(fail-type? (repeat-res-stop r))))
|
|
||||||
options)]
|
|
||||||
[possible-errors
|
|
||||||
(filter res-possible-error
|
|
||||||
(map (lambda (a) (if (repeat-res? a) (repeat-res-a a) a))
|
|
||||||
options))])
|
|
||||||
#;(printf "length finished-options ~a\n" finished-options)
|
|
||||||
(cond
|
|
||||||
[(not (null? finished-options))
|
|
||||||
#;(printf "finished an option\n")
|
|
||||||
(let ([first-fo (car finished-options)])
|
|
||||||
(car (cond
|
|
||||||
[(res? first-fo) (res-a first-fo)]
|
|
||||||
[(and (repeat-res? first-fo)
|
|
||||||
(res? (repeat-res-a first-fo)))
|
|
||||||
(res-a (repeat-res-a first-fo))]
|
|
||||||
[else
|
|
||||||
(error 'parser-internal-errorcp
|
|
||||||
(format "~a" first-fo))])))]
|
|
||||||
#;[(not (null? possible-repeat-errors))
|
|
||||||
(printf "possible-repeat error\n")
|
|
||||||
(fail-type->message
|
|
||||||
(car (repeat-res-stop
|
|
||||||
(sort-repeats possible-repeat-errors))))]
|
|
||||||
[(and (choice-res? result) (fail-type? (choice-res-errors result)))
|
|
||||||
#;(printf "choice res and choice res errors \n")
|
|
||||||
(cond
|
|
||||||
[(and (null? possible-repeat-errors)
|
|
||||||
(null? possible-errors)) (fail-type->message (choice-res-errors result))]
|
|
||||||
[(or #;(not (null? possible-repeat-errors))
|
|
||||||
(not (null? possible-errors)))
|
|
||||||
(let ([fails (cons (choice-res-errors result)
|
|
||||||
(map res-possible-error possible-errors))])
|
|
||||||
(fail-type->message
|
|
||||||
(make-options-fail (rank-choice (map fail-type-chance fails))
|
|
||||||
#f
|
|
||||||
(choice-res-name result)
|
|
||||||
(rank-choice (map fail-type-used fails))
|
|
||||||
(rank-choice (map fail-type-may-use fails))
|
|
||||||
fails)))])]
|
|
||||||
[(not (null? possible-errors))
|
|
||||||
;(printf "choice or pair fail\n")
|
|
||||||
(fail-type->message
|
|
||||||
(res-possible-error (car (sort-used possible-errors))))]
|
|
||||||
[else
|
|
||||||
#;(printf "result ~a\n" result)
|
|
||||||
(let ([used-sort (sort-used options)])
|
|
||||||
(if (and (choice-res? result)
|
|
||||||
(choice-res-errors result))
|
|
||||||
(fail-type->message (choice-res-errors result))
|
|
||||||
(make-err
|
|
||||||
(format "Found additional content after ~a, beginning with '~a'."
|
|
||||||
(res-msg (car used-sort))
|
|
||||||
(input->output-name (car (res-rest (car used-sort)))))
|
|
||||||
(and src?
|
|
||||||
(make-src-lst (position-token-start-pos
|
|
||||||
(car (res-rest (car used-sort))))
|
|
||||||
(position-token-end-pos
|
|
||||||
(car (res-rest (car used-sort)))))))))]))]
|
|
||||||
[(and (repeat-res? result) (eq? 'out-of-input (repeat-res-stop result)))
|
|
||||||
(res-a (repeat-res-a result))]
|
|
||||||
[(and (repeat-res? result) (fail-type? (repeat-res-stop result)))
|
|
||||||
;(printf "repeat-fail\n")
|
|
||||||
(fail-type->message (repeat-res-stop result))]
|
|
||||||
[else (error 'parser (format "Internal error: received unexpected input ~a"
|
|
||||||
result))])])
|
|
||||||
(cond
|
|
||||||
[(err? out)
|
|
||||||
(make-err (err-msg out)
|
|
||||||
(if (err-src out)
|
|
||||||
(list file
|
|
||||||
(first (err-src out))
|
|
||||||
(second (err-src out))
|
|
||||||
(third (err-src out))
|
|
||||||
(fourth (err-src out)))
|
|
||||||
(list file 1 0 1 0)))]
|
|
||||||
[else out]))))
|
|
||||||
)
|
|
||||||
|
|
||||||
#;(define-unit rank-defaults@
|
|
||||||
(import)
|
|
||||||
(export ranking-parameters^)
|
|
||||||
(define (rank-choice choices) (apply max choices))
|
|
||||||
(define-values
|
|
||||||
(rank-misspell rank-caps rank-class rank-wrong rank-end)
|
|
||||||
(values 4/5 9/10 2/5 1/5 2/5)))
|
|
||||||
|
|
||||||
(define-unit rank-defaults@
|
|
||||||
(import)
|
|
||||||
(export ranking-parameters^)
|
|
||||||
(define (rank-choice choices) (apply max choices))
|
|
||||||
(define-values
|
|
||||||
(rank-misspell rank-caps rank-class rank-wrong rank-end rank-repeat)
|
|
||||||
(values 16/71 18/71 8/71 4/71 8/71 17/71)))
|
|
||||||
|
|
||||||
|
|
||||||
(define-unit out-struct@
|
|
||||||
(import)
|
|
||||||
(export out^)
|
|
||||||
(define-struct err (msg src) #:mutable))
|
|
||||||
|
|
||||||
(define-compound-unit/infer combinator-parser@
|
|
||||||
(import error-format-parameters^ language-format-parameters^ language-dictionary^)
|
|
||||||
(export combinator-parser-forms^ parser^ out^)
|
|
||||||
(link out-struct@ main-parser@ rank-defaults@ error-formatting@ combinators@))
|
|
||||||
|
|
||||||
(define-unit/new-import-export combinator-parser-tools@
|
|
||||||
(import error-format-parameters^ language-format-parameters^ language-dictionary^)
|
|
||||||
(export combinator-parser^ err^)
|
|
||||||
((combinator-parser-forms^ parser^ out^) combinator-parser@ error-format-parameters^ language-format-parameters^
|
|
||||||
language-dictionary^))
|
|
||||||
|
|
||||||
)
|
|
||||||
|
|
@ -1,932 +0,0 @@
|
||||||
(module combinator scheme/base
|
|
||||||
|
|
||||||
(require scheme/unit
|
|
||||||
scheme/list
|
|
||||||
(only-in (lib "etc.ss") opt-lambda))
|
|
||||||
|
|
||||||
(require "structs.scm"
|
|
||||||
"parser-sigs.ss"
|
|
||||||
parser-tools/lex)
|
|
||||||
|
|
||||||
(provide (all-defined-out))
|
|
||||||
|
|
||||||
(define-unit combinators@
|
|
||||||
(import error-format-parameters^ ranking-parameters^ language-dictionary^)
|
|
||||||
(export combinator-parser-forms^)
|
|
||||||
|
|
||||||
(define return-name "dummy")
|
|
||||||
(define terminal-occurs "unique-eq")
|
|
||||||
|
|
||||||
(define (make-weak-map) (make-weak-hasheq))
|
|
||||||
|
|
||||||
(define (weak-map-put! m k v)
|
|
||||||
(hash-set! m k (make-ephemeron k (box v))))
|
|
||||||
|
|
||||||
(define weak-map-get
|
|
||||||
(opt-lambda (m k [def-v (lambda () (error 'weak-map-get "value unset"))])
|
|
||||||
(let ([v (hash-ref m k #f)])
|
|
||||||
(if v
|
|
||||||
(let ([v (ephemeron-value v)])
|
|
||||||
(if v
|
|
||||||
(unbox v)
|
|
||||||
def-v))
|
|
||||||
def-v))))
|
|
||||||
|
|
||||||
;terminal: ('a -> bool 'a -> 'b string) -> ( (list 'a) -> res )
|
|
||||||
(define terminal
|
|
||||||
(opt-lambda (pred build name [spell? #f] [case? #f] [class? #f])
|
|
||||||
(let* ([memo-table (make-weak-map)]
|
|
||||||
[fail-str (string-append "failed " name)]
|
|
||||||
[t-name (if src? (lambda (t) (token-name (position-token-token t))) token-name)]
|
|
||||||
[t-val (if src? (lambda (t) (token-value (position-token-token t))) token-value)]
|
|
||||||
[spell? (or spell?
|
|
||||||
(lambda (token)
|
|
||||||
(if (t-val token) (misspelled name (t-val token)) 0)))]
|
|
||||||
[case? (or case?
|
|
||||||
(lambda (token)
|
|
||||||
(and (t-val token) (misscap name (t-val token)))))]
|
|
||||||
[class? (or class? (lambda (token) (missclass name (t-name token))))]
|
|
||||||
[make-fail
|
|
||||||
(lambda (c n k i u)
|
|
||||||
(make-terminal-fail c (if (and src? i)
|
|
||||||
(make-src-lst (position-token-start-pos i)
|
|
||||||
(position-token-end-pos i))
|
|
||||||
null)
|
|
||||||
n 0 u k (if src? (position-token-token i) i)))]
|
|
||||||
[value (lambda (t) (or (t-val t) name))]
|
|
||||||
[builder
|
|
||||||
(if src?
|
|
||||||
(lambda (token) (build (position-token-token token)
|
|
||||||
(position-token-start-pos token)
|
|
||||||
(position-token-end-pos token)))
|
|
||||||
build)])
|
|
||||||
|
|
||||||
(opt-lambda (input [last-src (list 1 0 1 0)] [alts 1])
|
|
||||||
#;(printf "terminal ~a\n" name)
|
|
||||||
#;(cond
|
|
||||||
[(eq? input return-name) (printf "name requested\n")]
|
|
||||||
[(null? input) (printf "null input\n")]
|
|
||||||
[else
|
|
||||||
(let ([token (position-token-token (car input))])
|
|
||||||
(printf "Token given ~a, match? ~a\n" token (pred token)))])
|
|
||||||
(cond
|
|
||||||
[(eq? input return-name) name]
|
|
||||||
[(eq? input terminal-occurs) (list (make-occurs name 1))]
|
|
||||||
[(weak-map-get memo-table input #f) (weak-map-get memo-table input)]
|
|
||||||
[else
|
|
||||||
(let ([result
|
|
||||||
(cond
|
|
||||||
[(null? input)
|
|
||||||
(fail-res null (make-terminal-fail rank-end last-src name 0 0 'end #f))]
|
|
||||||
[else
|
|
||||||
(let* ([curr-input (car input)]
|
|
||||||
[token (if src? (position-token-token curr-input) curr-input)])
|
|
||||||
(cond
|
|
||||||
[(pred token)
|
|
||||||
(make-res (list (builder curr-input))
|
|
||||||
(cdr input) name
|
|
||||||
(value curr-input) 1 #f curr-input)]
|
|
||||||
[else
|
|
||||||
#;(printf "Incorrect input for ~a : ~a miscase? ~a misspell? ~a \n" name
|
|
||||||
(cond
|
|
||||||
[(token-value token) (token-value token)]
|
|
||||||
[else (token-name token)])
|
|
||||||
(case? curr-input)
|
|
||||||
(spell? curr-input))
|
|
||||||
(fail-res (cdr input)
|
|
||||||
(let-values ([(chance kind may-use)
|
|
||||||
(cond
|
|
||||||
[(case? curr-input) (values rank-caps 'misscase 1)]
|
|
||||||
[(> (spell? curr-input) 3/5)
|
|
||||||
(values (* rank-misspell
|
|
||||||
(spell? curr-input)) 'misspell 1)]
|
|
||||||
[(class? curr-input) (values rank-class 'missclass 1)]
|
|
||||||
[else (values rank-wrong 'wrong 0)])])
|
|
||||||
(make-fail chance name kind curr-input may-use)))]))])])
|
|
||||||
(weak-map-put! memo-table input result)
|
|
||||||
result)])))))
|
|
||||||
|
|
||||||
;seq: ( (list ((list 'a) -> res)) ((list 'b) -> 'c) string -> ((list 'a) -> result)
|
|
||||||
(define seq
|
|
||||||
(opt-lambda (sub-list build name [id-position 0])
|
|
||||||
(let* ([sequence-length (length sub-list)]
|
|
||||||
[memo-table (make-weak-map)]
|
|
||||||
[terminal-counts #f]
|
|
||||||
[prev (lambda (x)
|
|
||||||
(cond [(eq? x return-name) "default previous"]
|
|
||||||
[else (fail-res null null)]))]
|
|
||||||
[builder
|
|
||||||
(lambda (r)
|
|
||||||
(cond
|
|
||||||
[(res? r)
|
|
||||||
(make-res (list (build (res-a r)))
|
|
||||||
(res-rest r)
|
|
||||||
name (res-id r) (res-used r)
|
|
||||||
(res-possible-error r)
|
|
||||||
(res-first-tok r))]
|
|
||||||
[(and (repeat-res? r) (res? repeat-res-a r))
|
|
||||||
(make-res (list (build (res-a (repeat-res-a r))))
|
|
||||||
(res-rest (repeat-res-a r))
|
|
||||||
name (res-id (repeat-res-a r))
|
|
||||||
(res-used (repeat-res-a r))
|
|
||||||
(repeat-res-stop r)
|
|
||||||
(res-first-tok (repeat-res-a r)))]
|
|
||||||
[else (error 'parser-internal-error1 (format "~a" r))]))]
|
|
||||||
[my-error (sequence-error-gen name sequence-length)]
|
|
||||||
[my-walker (seq-walker id-position name my-error)])
|
|
||||||
(opt-lambda (input [last-src (list 1 0 1 0)] [alts 1])
|
|
||||||
#;(unless (eq? input return-name) (printf "seq ~a\n" name))
|
|
||||||
(cond
|
|
||||||
[(eq? input return-name) name]
|
|
||||||
[(eq? input terminal-occurs)
|
|
||||||
(or terminal-counts
|
|
||||||
(begin
|
|
||||||
(set! terminal-counts 'counting)
|
|
||||||
(set! terminal-counts
|
|
||||||
(consolidate-count (map (lambda (symbol) (symbol terminal-occurs)) sub-list)))
|
|
||||||
terminal-counts))]
|
|
||||||
[(weak-map-get memo-table input #f)
|
|
||||||
(weak-map-get memo-table input)]
|
|
||||||
[(null? sub-list)
|
|
||||||
(builder (make-res null input name #f 0 #f #f))]
|
|
||||||
[else
|
|
||||||
(let* ([pre-build-ans (my-walker sub-list input prev #f #f #f null 0 alts last-src)]
|
|
||||||
[ans
|
|
||||||
(cond
|
|
||||||
[(and (res? pre-build-ans) (res-a pre-build-ans)) (builder pre-build-ans)]
|
|
||||||
[(and (pair? pre-build-ans) (null? (cdr pre-build-ans))) (builder (car pre-build-ans))]
|
|
||||||
[(pair? pre-build-ans) (map builder pre-build-ans)]
|
|
||||||
[else pre-build-ans])])
|
|
||||||
(weak-map-put! memo-table input ans)
|
|
||||||
#;(printf "sequence ~a returning \n" name)
|
|
||||||
#;(printf "answer is ~a \n" ans)
|
|
||||||
ans)])))))
|
|
||||||
|
|
||||||
;seq-walker: int string error-gen -> [(list parser) (list alpha) parser result (U bool string) (list string) int int -> result
|
|
||||||
(define (seq-walker id-position seq-name build-error)
|
|
||||||
(letrec ([next-res
|
|
||||||
(lambda (a id used tok rst)
|
|
||||||
(cond
|
|
||||||
[(res? rst)
|
|
||||||
(make-res (append a (res-a rst)) (res-rest rst)
|
|
||||||
seq-name (or id (res-id rst))
|
|
||||||
(+ used (res-used rst)) (res-possible-error rst) tok)]
|
|
||||||
[(and (repeat-res? rst) (res? (repeat-res-a rst)))
|
|
||||||
(make-res (append a (res-a (repeat-res-a rst)))
|
|
||||||
(res-rest (repeat-res-a rst)) seq-name
|
|
||||||
(or id (res-id (repeat-res-a rst)))
|
|
||||||
(+ used (res-used (repeat-res-a rst)))
|
|
||||||
(repeat-res-stop rst) tok)]
|
|
||||||
[else (error 'parser-internal-error2 (format "~a" rst))]
|
|
||||||
))]
|
|
||||||
[walker
|
|
||||||
(lambda (subs input previous? look-back look-back-ref curr-id seen used alts last-src)
|
|
||||||
(let* ([next-preds (cdr subs)]
|
|
||||||
[curr-pred (car subs)]
|
|
||||||
[id-spot? (= id-position (add1 (length seen)))]
|
|
||||||
[next-call
|
|
||||||
(lambda (old-result curr curr-ref curr-name new-id tok alts)
|
|
||||||
(cond
|
|
||||||
[(res? old-result)
|
|
||||||
(let* ([old-answer (res-a old-result)]
|
|
||||||
[rest (res-rest old-result)]
|
|
||||||
[old-used (res-used old-result)]
|
|
||||||
[rsts (walker next-preds rest curr-pred curr curr-ref
|
|
||||||
(or new-id curr-id) (cons curr-name seen)
|
|
||||||
(+ old-used used) alts
|
|
||||||
(if (and src? (res-first-tok old-result))
|
|
||||||
(make-src-lst (position-token-start-pos (res-first-tok old-result))
|
|
||||||
(position-token-end-pos (res-first-tok old-result)))
|
|
||||||
last-src))])
|
|
||||||
#;(printf "next-call ~a ~a: ~a ~a ~a ~a\n"
|
|
||||||
seq-name (length seen) old-result (res? rsts)
|
|
||||||
(and (res? rsts) (res-a rsts))
|
|
||||||
(and (res? rsts) (choice-fail? (res-possible-error rsts))))
|
|
||||||
(cond
|
|
||||||
[(and (res? rsts) (res-a rsts))
|
|
||||||
(next-res old-answer new-id old-used tok rsts)]
|
|
||||||
[(res? rsts) (fail-res rest (res-msg rsts))]
|
|
||||||
[(and (lazy-opts? rsts) (null? (lazy-opts-thunks rsts)))
|
|
||||||
(make-lazy-opts
|
|
||||||
(map (lambda (rst) (next-res old-answer new-id old-used tok rst))
|
|
||||||
(lazy-opts-matches rsts))
|
|
||||||
(make-options-fail 0 #f #f 0 0 null) null)]
|
|
||||||
[(and (lazy-opts? rsts) (not (lazy-choice? rsts)))
|
|
||||||
(make-lazy-opts
|
|
||||||
(map (lambda (rst) (next-res old-answer new-id old-used tok rst))
|
|
||||||
(lazy-opts-matches rsts))
|
|
||||||
(lazy-opts-errors rsts)
|
|
||||||
(map (lambda (thunk)
|
|
||||||
(lambda ()
|
|
||||||
(let ([ans (next-opt rsts)])
|
|
||||||
(and ans (next-res old-answer new-id old-used tok ans)))))
|
|
||||||
(lazy-opts-thunks rsts)))]
|
|
||||||
[(lazy-choice? rsts)
|
|
||||||
(make-lazy-choice
|
|
||||||
(map (lambda (rst) (next-res old-answer new-id old-used tok rst))
|
|
||||||
(lazy-opts-matches rsts))
|
|
||||||
(lazy-opts-errors rsts)
|
|
||||||
(map (lambda (thunk)
|
|
||||||
(lambda ()
|
|
||||||
(let ([ans (next-opt rsts)])
|
|
||||||
(and ans (next-res old-answer new-id old-used tok ans)))))
|
|
||||||
(lazy-opts-thunks rsts))
|
|
||||||
(lazy-choice-name rsts))]
|
|
||||||
[(pair? rsts)
|
|
||||||
(map (lambda (rst) (next-res old-answer new-id old-used tok rst))
|
|
||||||
(flatten (correct-list rsts)))]
|
|
||||||
[(choice-res? rsts)
|
|
||||||
#;(printf "next call, tail-end is choice ~a\n" rsts)
|
|
||||||
(map (lambda (rst) (next-res old-answer new-id old-used tok
|
|
||||||
(update-possible-fail rst rsts)))
|
|
||||||
(flatten (correct-list (choice-res-matches rsts))))]
|
|
||||||
[(repeat-res? rsts)
|
|
||||||
(next-res old-answer new-id old-used tok rsts)]
|
|
||||||
[else (error 'parser-internal-error3 (format "~a" rsts))]))]
|
|
||||||
[else (error 'parser-internal-error11 (format "~a" old-result))]))])
|
|
||||||
(cond
|
|
||||||
[(null? subs) (error 'end-of-subs)]
|
|
||||||
[(null? next-preds)
|
|
||||||
#;(printf "seq-walker called: last case, ~a case of ~a \n"
|
|
||||||
seq-name (curr-pred return-name))
|
|
||||||
(build-error (curr-pred input last-src)
|
|
||||||
(lambda () (previous? input))
|
|
||||||
(previous? return-name) #f
|
|
||||||
look-back look-back-ref used curr-id seen alts last-src)]
|
|
||||||
[else
|
|
||||||
#;(printf "seq-walker called: else case, ~a case of ~a ~ath case \n"
|
|
||||||
seq-name (curr-pred return-name) (length seen))
|
|
||||||
(let ([fst (curr-pred input last-src)])
|
|
||||||
(cond
|
|
||||||
[(res? fst)
|
|
||||||
#;(printf "res case ~a ~a\n" seq-name (length seen))
|
|
||||||
(cond
|
|
||||||
[(res-a fst) (next-call fst fst fst (res-msg fst)
|
|
||||||
(and id-spot? (res-id fst))
|
|
||||||
(res-first-tok fst) alts)]
|
|
||||||
[else
|
|
||||||
#;(printf "error situation ~a ~a\n" seq-name (length seen))
|
|
||||||
(build-error fst (lambda () (previous? input))
|
|
||||||
(previous? return-name)
|
|
||||||
(car next-preds) look-back look-back-ref used curr-id
|
|
||||||
seen alts last-src)])]
|
|
||||||
[(repeat-res? fst)
|
|
||||||
#;(printf "repeat-res: ~a ~a\n" seq-name (length seen))
|
|
||||||
#;(printf "res? ~a\n" (res? (repeat-res-a fst)))
|
|
||||||
(next-call (repeat-res-a fst) fst fst
|
|
||||||
(res-msg (repeat-res-a fst)) #f
|
|
||||||
(res-first-tok (repeat-res-a fst)) alts)]
|
|
||||||
[(lazy-opts? fst)
|
|
||||||
#;(printf "lazy res: ~a ~a ~a\n" fst seq-name (length seen))
|
|
||||||
(let* ([opt-r (make-lazy-opts null
|
|
||||||
(make-options-fail 0 last-src seq-name 0 0 null)
|
|
||||||
null)]
|
|
||||||
[name (if (lazy-choice? fst) (lazy-choice-name fst) seq-name)]
|
|
||||||
[next-c (lambda (res)
|
|
||||||
(cond
|
|
||||||
[(res? res)
|
|
||||||
#;(printf "lazy-choice-res, res ~a ~a\n" seq-name (length seen))
|
|
||||||
(next-call res fst res name (and id-spot? (res-id res))
|
|
||||||
(res-first-tok res) alts)]
|
|
||||||
[(repeat-res? res)
|
|
||||||
#;(printf "lazy- choice-res, repeat-res ~a ~a ~a\n"
|
|
||||||
(res? (repeat-res-a res)) seq-name (length seen))
|
|
||||||
(next-call (repeat-res-a res) res (repeat-res-a res)
|
|
||||||
(res-msg (repeat-res-a res)) #f
|
|
||||||
(res-first-tok (repeat-res-a res))
|
|
||||||
alts)]
|
|
||||||
[else (error 'parser-internal-errora (format "~a" res))]))]
|
|
||||||
[parsed-options (map (lambda (res) (lambda () (next-c res)))
|
|
||||||
(lazy-opts-matches fst))]
|
|
||||||
[unparsed-options
|
|
||||||
(map
|
|
||||||
(lambda (thunked)
|
|
||||||
(lambda ()
|
|
||||||
(let ([res (next-opt fst)])
|
|
||||||
(if res
|
|
||||||
(next-c res)
|
|
||||||
(begin (set-lazy-opts-thunks! opt-r null) #f)))))
|
|
||||||
(lazy-opts-thunks fst))])
|
|
||||||
(set-lazy-opts-thunks! opt-r (append parsed-options unparsed-options))
|
|
||||||
(if (next-opt opt-r)
|
|
||||||
opt-r
|
|
||||||
(fail-res input (lazy-opts-errors opt-r))))
|
|
||||||
]
|
|
||||||
[(or (choice-res? fst) (pair? fst))
|
|
||||||
#;(printf "choice-res: ~a ~a ~a\n" fst seq-name (length seen))
|
|
||||||
(let*-values
|
|
||||||
([(lst name curr)
|
|
||||||
(cond
|
|
||||||
[(choice-res? fst)
|
|
||||||
(values (choice-res-matches fst)
|
|
||||||
(lambda (_) (choice-res-name fst))
|
|
||||||
(lambda (_) fst))]
|
|
||||||
[else (values fst res-msg (lambda (x) x))])]
|
|
||||||
[(new-alts) (+ alts (length lst))]
|
|
||||||
[(rsts)
|
|
||||||
(map (lambda (res)
|
|
||||||
(cond
|
|
||||||
[(res? res)
|
|
||||||
#;(printf "choice-res, res ~a ~a\n" seq-name (length seen))
|
|
||||||
(next-call res (curr res) res (name res)
|
|
||||||
(and id-spot? (res-id res))
|
|
||||||
(res-first-tok res) new-alts)]
|
|
||||||
[(repeat-res? res)
|
|
||||||
#;(printf "choice-res, repeat-res ~a ~a ~a\n"
|
|
||||||
(res? (repeat-res-a res)) seq-name (length seen))
|
|
||||||
(next-call (repeat-res-a res) res (repeat-res-a res)
|
|
||||||
(res-msg (repeat-res-a res)) #f
|
|
||||||
(res-first-tok (repeat-res-a res))
|
|
||||||
new-alts)]
|
|
||||||
[else (error 'parser-internal-error4 (format "~a" res))]))
|
|
||||||
(flatten lst))]
|
|
||||||
[(correct-rsts) (flatten (correct-list rsts))])
|
|
||||||
#;(printf "case ~a ~a, choice case: intermediate results are ~a\n"
|
|
||||||
seq-name (length seen) lst)
|
|
||||||
(cond
|
|
||||||
[(and (null? correct-rsts) (or (not (lazy-choice? fst))
|
|
||||||
(null? (lazy-opts-thunks fst))))
|
|
||||||
#;(printf "correct-rsts null for ~a ~a \n" seq-name (length seen))
|
|
||||||
(let ([fails
|
|
||||||
(map
|
|
||||||
(lambda (rst)
|
|
||||||
(res-msg
|
|
||||||
(build-error rst (lambda () (previous? input)) (previous? return-name)
|
|
||||||
(car next-preds) look-back look-back-ref used curr-id seen alts last-src)))
|
|
||||||
rsts)])
|
|
||||||
(fail-res input
|
|
||||||
(make-options-fail
|
|
||||||
(rank-choice (map fail-type-chance fails))
|
|
||||||
(if (equal? last-src (list 1 0 1 0))
|
|
||||||
(map fail-type-src fails)
|
|
||||||
last-src)
|
|
||||||
seq-name
|
|
||||||
(rank-choice (map fail-type-used fails))
|
|
||||||
(rank-choice (map fail-type-may-use fails)) fails)))]
|
|
||||||
[(and (null? correct-rsts) (lazy-choice? fst) (not (null? (lazy-opts-thunks fst))))
|
|
||||||
(let loop ([next-res (next-opt fst)])
|
|
||||||
(when next-res (loop (next-opt fst))))]
|
|
||||||
[else correct-rsts]))]
|
|
||||||
[else (error 'here3 (format "~a" fst))]))])))])
|
|
||||||
walker))
|
|
||||||
|
|
||||||
;get-fail-info: fail-type -> (values symbol 'a 'b)
|
|
||||||
(define (get-fail-info fail)
|
|
||||||
(cond
|
|
||||||
[(terminal-fail? fail)
|
|
||||||
(values (terminal-fail-kind fail)
|
|
||||||
(fail-type-name fail)
|
|
||||||
(terminal-fail-found fail))]
|
|
||||||
[(sequence-fail? fail)
|
|
||||||
(values 'sub-seq (sequence-fail-expected fail) fail)]
|
|
||||||
[(choice-fail? fail) (values 'choice null fail)]
|
|
||||||
[(options-fail? fail) (values 'options null fail)]
|
|
||||||
[else (error 'parser-internal-error5 (format "~a" fail))]))
|
|
||||||
|
|
||||||
;update-src: symbol src-list src-list token -> src-list
|
|
||||||
(define (update-src error-kind src prev-src tok)
|
|
||||||
(and src?
|
|
||||||
(case error-kind
|
|
||||||
[(choice options) prev-src]
|
|
||||||
[(sub-seq misscase misspell end) src]
|
|
||||||
[(missclass wrong)
|
|
||||||
(if tok
|
|
||||||
(update-src-start src (position-token-start-pos tok))
|
|
||||||
src)])))
|
|
||||||
|
|
||||||
;build-options-fail: name (list-of fail-type) -> fail-type
|
|
||||||
(define (build-options-fail name fails)
|
|
||||||
(make-options-fail (rank-choice (map fail-type-chance fails))
|
|
||||||
#f
|
|
||||||
name
|
|
||||||
(rank-choice (map fail-type-used fails))
|
|
||||||
(rank-choice (map fail-type-may-use fails))
|
|
||||||
fails))
|
|
||||||
|
|
||||||
(define (add-to-choice-fails choice fail)
|
|
||||||
(let ([fails (choice-fail-messages choice)])
|
|
||||||
(make-choice-fail
|
|
||||||
(rank-choice (cons (fail-type-chance fail) (map fail-type-chance fails)))
|
|
||||||
(fail-type-src choice)
|
|
||||||
(fail-type-name choice)
|
|
||||||
(rank-choice (cons (fail-type-used fail) (map fail-type-used fails)))
|
|
||||||
(rank-choice (cons (fail-type-may-use fail) (map fail-type-may-use fails)))
|
|
||||||
(choice-fail-options choice)
|
|
||||||
(choice-fail-names choice)
|
|
||||||
(choice-fail-ended? choice)
|
|
||||||
(cons fail fails))))
|
|
||||||
|
|
||||||
;update-possible-rail result result -> result
|
|
||||||
(define (update-possible-fail res back)
|
|
||||||
#;(printf "update-possible-fail ~a, ~a\n" res back)
|
|
||||||
(cond
|
|
||||||
[(and (res? res) (not (res-possible-error res)))
|
|
||||||
(cond
|
|
||||||
[(res? back)
|
|
||||||
(make-res (res-a res) (res-rest res) (res-msg res) (res-id res) (res-used res)
|
|
||||||
(res-possible-error back) (res-first-tok res))]
|
|
||||||
[(choice-res? back)
|
|
||||||
(make-res (res-a res) (res-rest res) (res-msg res) (res-id res) (res-used res)
|
|
||||||
(choice-res-errors back) (res-first-tok res))]
|
|
||||||
[else res])]
|
|
||||||
[(choice-res? res)
|
|
||||||
(cond
|
|
||||||
[(and (choice-res? back) (choice-res-errors back) (choice-res-errors res))
|
|
||||||
(make-choice-res (choice-res-name res)
|
|
||||||
(choice-res-matches res)
|
|
||||||
(add-to-choice-fails (choice-res-errors res)
|
|
||||||
(choice-res-errors back)))]
|
|
||||||
|
|
||||||
[else res])]
|
|
||||||
[else res]))
|
|
||||||
|
|
||||||
;build-sequence-error: result boolean result string int [U #f string] [listof string] int int -> result
|
|
||||||
(define (sequence-error-gen name len)
|
|
||||||
(letrec ([repeat->res
|
|
||||||
(lambda (rpt back)
|
|
||||||
(cond
|
|
||||||
[(pair? rpt) (map (lambda (r) (repeat->res r back)) (flatten rpt))]
|
|
||||||
[(and (repeat-res? rpt) (res? (repeat-res-a rpt)))
|
|
||||||
(let ([inn (repeat-res-a rpt)]
|
|
||||||
[stop (repeat-res-stop rpt)])
|
|
||||||
#;(printf "in repeat->res for ~a\n" name)
|
|
||||||
#;(when (fail-type? stop)
|
|
||||||
(printf "stoped on ~a\n" (fail-type-name stop)))
|
|
||||||
#;(printf "stop ~a\n" stop)
|
|
||||||
#;(when (choice-res? back)
|
|
||||||
(printf "back on ~a\n" (choice-res-name back)))
|
|
||||||
#;(when (choice-res? back) (printf "choice-res-errors back ~a\n"
|
|
||||||
(choice-res-errors back)))
|
|
||||||
#;(when (and (fail-type? stop)
|
|
||||||
(choice-res? back)
|
|
||||||
(choice-res-errors back))
|
|
||||||
(printf "chances ~a > ~a -> ~a \n"
|
|
||||||
(fail-type-chance (choice-res-errors back))
|
|
||||||
(fail-type-chance stop)
|
|
||||||
(>= (fail-type-chance (choice-res-errors back))
|
|
||||||
(fail-type-chance stop))))
|
|
||||||
(cond
|
|
||||||
[(fail-type? stop)
|
|
||||||
(make-res (res-a inn) (res-rest inn) (res-msg inn) (res-id inn) (res-used inn)
|
|
||||||
stop
|
|
||||||
#;(if (and (zero? (res-used inn))
|
|
||||||
(choice-res? back) (choice-res-errors back)
|
|
||||||
(>= (fail-type-chance (choice-res-errors back))
|
|
||||||
(fail-type-chance stop)))
|
|
||||||
(build-options-fail name
|
|
||||||
(list (choice-res-errors back)
|
|
||||||
stop))
|
|
||||||
stop)
|
|
||||||
(res-first-tok inn))]
|
|
||||||
[else inn]))]
|
|
||||||
[else rpt]))]
|
|
||||||
)
|
|
||||||
(lambda (old-res prev prev-name next-pred look-back look-back-ref used id seen alts last-src)
|
|
||||||
(cond
|
|
||||||
[(and (pair? old-res) (null? (cdr old-res)) (res? (car old-res)))
|
|
||||||
(update-possible-fail (car old-res) look-back)]
|
|
||||||
[(and (pair? old-res) (null? (cdr old-res)) (repeat-res? (car old-res)))
|
|
||||||
(repeat->res (car old-res) look-back)]
|
|
||||||
[(or (and (res? old-res) (res-a old-res)) (choice-res? old-res) (lazy-opts? old-res))
|
|
||||||
(update-possible-fail old-res look-back)]
|
|
||||||
[(repeat-res? old-res)
|
|
||||||
#;(printf "finished on repeat-res for ~a res \n" name #;old-res)
|
|
||||||
(repeat->res old-res look-back)]
|
|
||||||
[(pair? old-res)
|
|
||||||
#;(printf "finished on pairs of res for ~a\n" name #;old-res)
|
|
||||||
(map (lambda (r) (repeat->res r look-back)) (flatten old-res))]
|
|
||||||
[else
|
|
||||||
#;(printf "There was an error for ~a\n" name)
|
|
||||||
#;(printf "length seen ~a length rest ~a\n" (length seen) (length (res-rest old-res)))
|
|
||||||
(fail-res (res-rest old-res)
|
|
||||||
(let*-values ([(fail) (res-msg old-res)]
|
|
||||||
[(possible-fail)
|
|
||||||
(cond
|
|
||||||
[(and (repeat-res? look-back)
|
|
||||||
(fail-type? (repeat-res-stop look-back))
|
|
||||||
(>= (fail-type-chance (repeat-res-stop look-back))
|
|
||||||
(fail-type-chance fail)))
|
|
||||||
(repeat-res-stop look-back)]
|
|
||||||
[(and (choice-res? look-back)
|
|
||||||
(choice-res-errors look-back)
|
|
||||||
(>= (fail-type-chance (choice-res-errors look-back))
|
|
||||||
(fail-type-chance fail)))
|
|
||||||
(choice-res-errors look-back)]
|
|
||||||
[(and (res? look-back)
|
|
||||||
(fail-type? (res-possible-error look-back))
|
|
||||||
(>= (fail-type-chance (res-possible-error look-back))
|
|
||||||
(fail-type-chance fail)))
|
|
||||||
(res-possible-error look-back)]
|
|
||||||
[else #f])]
|
|
||||||
[(next-ok?)
|
|
||||||
(and (= (fail-type-may-use fail) 1)
|
|
||||||
(not (null? (res-rest old-res)))
|
|
||||||
next-pred
|
|
||||||
(next-pred (cdr (res-rest old-res))))]
|
|
||||||
[(next-used)
|
|
||||||
(if (and next-ok? (res? next-ok?) (res-a next-ok?))
|
|
||||||
(res-used next-ok?)
|
|
||||||
0)]
|
|
||||||
[(kind expected found) (get-fail-info fail)]
|
|
||||||
[(new-src) (update-src kind
|
|
||||||
(fail-type-src fail)
|
|
||||||
last-src
|
|
||||||
(res-first-tok old-res))]
|
|
||||||
[(seen-len) (length seen)]
|
|
||||||
[(updated-len) (+ (- used seen-len) len)])
|
|
||||||
#;(printf "sequence ~a failed.\n seen ~a\n" name (reverse seen))
|
|
||||||
#;(when (repeat-res? look-back)
|
|
||||||
(printf "look-back repeat-res ~a : ~a vs ~a : ~a > ~a\n"
|
|
||||||
(fail-type? (repeat-res-stop look-back))
|
|
||||||
(and (fail-type? (repeat-res-stop look-back)) (fail-type-name (repeat-res-stop look-back)))
|
|
||||||
(fail-type-name (res-msg old-res))
|
|
||||||
(and (fail-type? (repeat-res-stop look-back)) (fail-type-chance (repeat-res-stop look-back)))
|
|
||||||
(fail-type-chance (res-msg old-res))))
|
|
||||||
#;(when (choice-res? look-back)
|
|
||||||
(printf "look-back choice: ~a vs ~a : ~a > ~a\n"
|
|
||||||
(choice-res-name look-back)
|
|
||||||
(fail-type-name (res-msg old-res))
|
|
||||||
(and (choice-res-errors look-back)
|
|
||||||
(fail-type-chance (choice-res-errors look-back)))
|
|
||||||
(fail-type-chance (res-msg old-res)))
|
|
||||||
(printf "look-back choice and useds: ~a vs ~a -- ~a \n"
|
|
||||||
used (and (res? look-back-ref) (res-used look-back-ref))
|
|
||||||
(and (choice-res-errors look-back)
|
|
||||||
(fail-type-used (choice-res-errors look-back)))))
|
|
||||||
#;(when (pair? look-back)
|
|
||||||
(printf "look-back is a pair\n"))
|
|
||||||
#;(when (res? look-back)
|
|
||||||
(printf "look-back res ~a : ~a vs ~a : ~a > ~a\n"
|
|
||||||
(fail-type? (res-possible-error look-back))
|
|
||||||
(and (fail-type? (res-possible-error look-back)) (fail-type-name (res-possible-error look-back)))
|
|
||||||
(fail-type-name (res-msg old-res))
|
|
||||||
(and (fail-type? (res-possible-error look-back)) (fail-type-chance (res-possible-error look-back)))
|
|
||||||
(fail-type-chance (res-msg old-res)))
|
|
||||||
(printf "lookback ~a\n" (res-possible-error look-back)))
|
|
||||||
(let* ([seq-fail-maker
|
|
||||||
(lambda (fail used)
|
|
||||||
(let-values ([(kind expected found) (get-fail-info fail)])
|
|
||||||
(make-sequence-fail
|
|
||||||
(compute-chance len seen-len used alts
|
|
||||||
(fail-type-may-use fail)
|
|
||||||
(fail-type-chance fail))
|
|
||||||
(fail-type-src fail)
|
|
||||||
name used
|
|
||||||
(+ used (fail-type-may-use fail) next-used)
|
|
||||||
id kind (reverse seen) expected found
|
|
||||||
prev
|
|
||||||
prev-name)))]
|
|
||||||
[seq-fail (seq-fail-maker fail used)]
|
|
||||||
[pos-fail
|
|
||||||
(and possible-fail
|
|
||||||
(seq-fail-maker possible-fail
|
|
||||||
(if (and (choice-res? look-back)
|
|
||||||
(res? look-back-ref))
|
|
||||||
(- used (res-used look-back-ref)) used)))]
|
|
||||||
[opt-fails (list seq-fail pos-fail)])
|
|
||||||
#;(printf "pos-fail? ~a\n" (and pos-fail #t))
|
|
||||||
#;(printf "seq-fail ~a\n" seq-fail)
|
|
||||||
#;(when pos-fail
|
|
||||||
(printf "used ~a look-back-ref used ~a \n"
|
|
||||||
used (when (res? look-back-ref) (res-used look-back-ref)))
|
|
||||||
(printf "opt-fails ~a\n" opt-fails))
|
|
||||||
(if pos-fail
|
|
||||||
(make-options-fail (rank-choice (map fail-type-chance opt-fails))
|
|
||||||
(map fail-type-src opt-fails)
|
|
||||||
name
|
|
||||||
(rank-choice (map fail-type-used opt-fails))
|
|
||||||
(rank-choice (map fail-type-may-use opt-fails))
|
|
||||||
opt-fails)
|
|
||||||
seq-fail))))]))))
|
|
||||||
|
|
||||||
(define (compute-chance expected-length seen-length used-toks num-alts may-use sub-chance)
|
|
||||||
(let* ([revised-expectation (+ (- used-toks seen-length) expected-length)]
|
|
||||||
[possible-expectation (+ revised-expectation (max 0 (sub1 may-use)))]
|
|
||||||
#;[probability-with-sub (* (/ (+ may-use used-toks) possible-expectation) (/ 1 num-alts))]
|
|
||||||
[probability-with-sub (* (/ (add1 used-toks) revised-expectation) (/ 1 num-alts))]
|
|
||||||
[probability-without-sub (* (/ used-toks revised-expectation) (/ 1 num-alts))]
|
|
||||||
[expected-sub probability-with-sub]
|
|
||||||
[expected-no-sub probability-without-sub]
|
|
||||||
[probability (/ (* expected-sub sub-chance) (+ (* expected-sub sub-chance)
|
|
||||||
(* expected-no-sub (- 1 sub-chance))))])
|
|
||||||
|
|
||||||
#;(when (zero? used-toks)
|
|
||||||
(printf "compute-chance 0 case: ~a, ~a, ~a, ~a -> ~a\n"
|
|
||||||
sub-chance expected-length num-alts may-use
|
|
||||||
(* (/ 1 num-alts) sub-chance)))
|
|
||||||
(cond
|
|
||||||
#;[(zero? used-toks) (* (/ 1 num-alts) sub-chance)]
|
|
||||||
[(zero? used-toks) sub-chance #;probability-with-sub]
|
|
||||||
[else
|
|
||||||
#;(printf "compute-chance: args ~a ~a ~a ~a ~a ~a\n"
|
|
||||||
expected-length seen-length used-toks num-alts may-use sub-chance)
|
|
||||||
#;(printf "compute-chance: intermediate values: ~a ~a ~a ~a ~a ~a\n"
|
|
||||||
revised-expectation possible-expectation probability-with-sub probability-without-sub expected-sub expected-no-sub)
|
|
||||||
#;(printf "compute-chance answer ~a\n" probability)
|
|
||||||
probability])))
|
|
||||||
|
|
||||||
;greedy-repeat: (list 'a) -> result -> (list 'a) -> result
|
|
||||||
(define (repeat-greedy sub)
|
|
||||||
(letrec ([repeat-name (lambda () (string-append "any number of " (sub return-name)))]
|
|
||||||
[memo-table (make-weak-map)]
|
|
||||||
[inner-memo-table (make-weak-map)]
|
|
||||||
[process-rest
|
|
||||||
(lambda (curr-ans rest-ans)
|
|
||||||
(cond
|
|
||||||
[(repeat-res? rest-ans)
|
|
||||||
#;(printf "building up the repeat answer for ~a\n" repeat-name)
|
|
||||||
(cond
|
|
||||||
[(res? curr-ans)
|
|
||||||
(let* ([a (res-a curr-ans)]
|
|
||||||
[rest (repeat-res-a rest-ans)]
|
|
||||||
[repeat-build
|
|
||||||
(lambda (r)
|
|
||||||
(cond
|
|
||||||
[(res? r)
|
|
||||||
#;(printf "rest is a res for ~a, res-a is ~a \n" a repeat-name)
|
|
||||||
(make-repeat-res
|
|
||||||
(make-res (append a (res-a r)) (res-rest r) (repeat-name) #f
|
|
||||||
(+ (res-used curr-ans) (res-used r))
|
|
||||||
#f (res-first-tok r))
|
|
||||||
(repeat-res-stop rest-ans))]
|
|
||||||
[else
|
|
||||||
(error 'parser-internal-error9 (format "~a" r))]))])
|
|
||||||
(cond
|
|
||||||
[(and (pair? rest) (null? (cdr rest)))
|
|
||||||
#;(printf "rest is a one-element list for ~a\n" repeat-name)
|
|
||||||
(repeat-build (car rest))]
|
|
||||||
[(pair? rest)
|
|
||||||
#;(printf "rest is a pair for ~a ~a\n" repeat-name (length rest))
|
|
||||||
(map repeat-build (flatten rest))]
|
|
||||||
[else (repeat-build rest)]))]
|
|
||||||
[else (error 'parser-internal-error12 (format "~a" curr-ans))])]
|
|
||||||
[(pair? rest-ans)
|
|
||||||
(map (lambda (r) (process-rest curr-ans r)) (flatten rest-ans))]
|
|
||||||
[else (error 'parser-internal-error10 (format "~a" rest-ans))]))]
|
|
||||||
[update-src
|
|
||||||
(lambda (input prev-src)
|
|
||||||
(cond
|
|
||||||
[(null? input) prev-src]
|
|
||||||
[src? (src-list (position-token-start-pos (car input))
|
|
||||||
(position-token-end-pos (car input)))]
|
|
||||||
[else prev-src]))])
|
|
||||||
(opt-lambda (input [start-src (list 1 0 1 0)] [alts 1])
|
|
||||||
(cond
|
|
||||||
[(eq? input return-name) (repeat-name)]
|
|
||||||
[(eq? input terminal-occurs) (sub terminal-occurs)]
|
|
||||||
[(weak-map-get memo-table input #f)(weak-map-get memo-table input)]
|
|
||||||
[else
|
|
||||||
(let ([ans
|
|
||||||
(let loop ([curr-input input] [curr-src start-src])
|
|
||||||
#;(printf "length of curr-input for ~a ~a\n" repeat-name (length curr-input))
|
|
||||||
#;(printf "curr-input ~a\n" (map position-token-token curr-input))
|
|
||||||
(cond
|
|
||||||
[(weak-map-get inner-memo-table curr-input #f)(weak-map-get inner-memo-table curr-input)]
|
|
||||||
[(null? curr-input)
|
|
||||||
#;(printf "out of input for ~a\n" (repeat-name))
|
|
||||||
(make-repeat-res (make-res null null (repeat-name) "" 0 #f #f) 'out-of-input)]
|
|
||||||
[else
|
|
||||||
(let ([this-res (sub curr-input curr-src)])
|
|
||||||
#;(printf "Repeat of ~a called it's repeated entity \n" (repeat-name))
|
|
||||||
(cond
|
|
||||||
[(and (res? this-res) (res-a this-res))
|
|
||||||
#;(printf "loop again case for ~a\n" (repeat-name))
|
|
||||||
(process-rest this-res
|
|
||||||
(loop (res-rest this-res)
|
|
||||||
(update-src (res-rest this-res) curr-src)))]
|
|
||||||
[(res? this-res)
|
|
||||||
#;(printf "fail for error case of ~a: ~a ~a\n"
|
|
||||||
repeat-name
|
|
||||||
(cond
|
|
||||||
[(choice-fail? (res-msg this-res)) 'choice]
|
|
||||||
[(sequence-fail? (res-msg this-res)) 'seq]
|
|
||||||
[(options-fail? (res-msg this-res)) 'options]
|
|
||||||
[else 'terminal])
|
|
||||||
(fail-type-chance (res-msg this-res)))
|
|
||||||
(let ([fail (make-repeat-res (make-res null curr-input (repeat-name) "" 0 #f #f)
|
|
||||||
(res-msg this-res))])
|
|
||||||
(weak-map-put! inner-memo-table curr-input fail)
|
|
||||||
fail)]
|
|
||||||
[(repeat-res? this-res)
|
|
||||||
#;(printf "repeat-res case of ~a\n" repeat-name)
|
|
||||||
(process-rest (repeat-res-a this-res)
|
|
||||||
(res-rest (repeat-res-a this-res)))]
|
|
||||||
[(lazy-opts? this-res)
|
|
||||||
(let ([process (lambda (res)
|
|
||||||
(cond [(res? res)
|
|
||||||
(process-rest res (loop (res-rest res) (update-src (res-rest res) curr-src)))]
|
|
||||||
[(repeat-res? res)
|
|
||||||
(process-rest (repeat-res-a res) (res-rest (repeat-res-a res)))]
|
|
||||||
[else (error 'repeat-greedy-loop (format "Internal error, given ~a" res))]))])
|
|
||||||
(update-lazy-opts this-res
|
|
||||||
(map process (lazy-opts-matches this-res))
|
|
||||||
(map (lambda (t)
|
|
||||||
(lambda ()
|
|
||||||
(let ([next-res (next-opt this-res)])
|
|
||||||
(and next-res (process next-res)))))
|
|
||||||
(lazy-opts-thunks this-res))))]
|
|
||||||
[(or (choice-res? this-res) (pair? this-res))
|
|
||||||
(let ([list-of-answer
|
|
||||||
(if (choice-res? this-res) (choice-res-matches this-res) (flatten this-res))])
|
|
||||||
#;(printf "repeat call of ~a, choice-res ~a\n"
|
|
||||||
repeat-name
|
|
||||||
(and (choice-res? this-res)
|
|
||||||
(length list-of-answer)))
|
|
||||||
(cond
|
|
||||||
[(null? (cdr list-of-answer))
|
|
||||||
(process-rest (car list-of-answer)
|
|
||||||
(loop (res-rest (car list-of-answer))
|
|
||||||
(update-src (res-rest (car list-of-answer))
|
|
||||||
curr-src)))]
|
|
||||||
[else
|
|
||||||
(map (lambda (match)
|
|
||||||
#;(printf "calling repeat loop again ~a, res-rest match ~a\n"
|
|
||||||
(repeat-name) (length (res-rest match)))
|
|
||||||
(process-rest match
|
|
||||||
(loop (res-rest match)
|
|
||||||
(update-src (res-rest match) curr-src))))
|
|
||||||
list-of-answer)]))]
|
|
||||||
[else (error 'internal-parser-error8 (format "~a" this-res))]))]))])
|
|
||||||
(weak-map-put! memo-table input ans)
|
|
||||||
#;(printf "repeat of ~a ended with ans \n" repeat-name #;ans)
|
|
||||||
ans)]))))
|
|
||||||
|
|
||||||
;choice: [list [[list 'a ] -> result]] name -> result
|
|
||||||
(define (choice opt-list name)
|
|
||||||
(let ([memo-table (make-weak-map)]
|
|
||||||
[terminal-counts #f]
|
|
||||||
[num-choices (length opt-list)]
|
|
||||||
[choice-names (lambda () (map (lambda (o) (o return-name)) opt-list))])
|
|
||||||
(opt-lambda (input [last-src (list 0 0 0 0)] [alts 1])
|
|
||||||
#;(unless (eq? input return-name) (printf "choice ~a\n" name))
|
|
||||||
#;(printf "possible options are ~a\n" (choice-names))
|
|
||||||
(let ([sub-opts (sub1 (+ alts num-choices))])
|
|
||||||
(cond
|
|
||||||
[(eq? input return-name) name]
|
|
||||||
[(eq? input terminal-occurs)
|
|
||||||
(or terminal-counts
|
|
||||||
(begin
|
|
||||||
(set! terminal-counts 'counting)
|
|
||||||
(set! terminal-counts
|
|
||||||
(consolidate-count (map (lambda (symbol) (symbol terminal-occurs)) opt-list)))
|
|
||||||
terminal-counts))]
|
|
||||||
[(weak-map-get memo-table input #f) (weak-map-get memo-table input)]
|
|
||||||
[else
|
|
||||||
#;(printf "choice ~a\n" name)
|
|
||||||
#;(printf "possible options are ~a\n" (choice-names))
|
|
||||||
(let*-values
|
|
||||||
([(options) (map (lambda (term) (term input last-src sub-opts)) opt-list)]
|
|
||||||
#;[a (printf "choice-options ~a \n ~a \n\n\n" choice-names options)]
|
|
||||||
[(fails) (map (lambda (x)
|
|
||||||
(cond
|
|
||||||
[(res? x) (res-msg x)]
|
|
||||||
[(repeat-res? x) (res-msg (repeat-res-a x))]
|
|
||||||
[(choice-res? x) (choice-res-errors x)]
|
|
||||||
[else (error 'here-non-res x)]))
|
|
||||||
(flatten options))]
|
|
||||||
[(corrects errors) (split-list options)]
|
|
||||||
[(fail-builder)
|
|
||||||
(lambda (fails)
|
|
||||||
(if (null? fails)
|
|
||||||
#f
|
|
||||||
(make-choice-fail (rank-choice (map fail-type-chance fails))
|
|
||||||
(if (or (null? input)
|
|
||||||
(not (position-token? (car input))))
|
|
||||||
last-src
|
|
||||||
(update-src-end
|
|
||||||
last-src
|
|
||||||
(position-token-end-pos (car input))))
|
|
||||||
name
|
|
||||||
(rank-choice (map fail-type-used fails))
|
|
||||||
(rank-choice (map fail-type-may-use fails))
|
|
||||||
num-choices (choice-names)
|
|
||||||
(null? input)
|
|
||||||
fails)))]
|
|
||||||
[(ans)
|
|
||||||
(cond
|
|
||||||
[(null? corrects) (fail-res input (fail-builder fails))]
|
|
||||||
[else (make-choice-res name corrects (fail-builder errors))])])
|
|
||||||
#;(printf "choice ~a is returning options were ~a \n" name (choice-names))
|
|
||||||
#;(printf "corrects were ~a\n" corrects)
|
|
||||||
#;(printf "errors were ~a\n" errors)
|
|
||||||
(weak-map-put! memo-table input ans) ans)])))))
|
|
||||||
|
|
||||||
;choice: [list [[list 'a ] -> result]] name -> result
|
|
||||||
(define (choice2 opt-list name)
|
|
||||||
(let ([memo-table (make-weak-map)]
|
|
||||||
[num-choices (length opt-list)]
|
|
||||||
[choice-names (lambda () (map (lambda (o) (o return-name)) opt-list))])
|
|
||||||
(opt-lambda (input [last-src (list 0 0 0 0)] [alts 1])
|
|
||||||
#;(unless (eq? input return-name) (printf "choice ~a\n" name))
|
|
||||||
#;(printf "possible options are ~a\n" choice-names)
|
|
||||||
(let ([sub-opts (sub1 (+ alts num-choices))])
|
|
||||||
(cond
|
|
||||||
[(weak-map-get memo-table input #f) (weak-map-get memo-table input)]
|
|
||||||
[(eq? input return-name) name]
|
|
||||||
[else
|
|
||||||
(let* ([options (map (lambda (term) (lambda () (term input last-src sub-opts))) opt-list)]
|
|
||||||
[initial-fail (make-choice-fail 0
|
|
||||||
(if (or (null? input) (not (position-token? (car input))))
|
|
||||||
last-src
|
|
||||||
(update-src-end last-src
|
|
||||||
(position-token-end-pos (car input))))
|
|
||||||
name
|
|
||||||
0
|
|
||||||
0
|
|
||||||
num-choices
|
|
||||||
(choice-names)
|
|
||||||
(null? input)
|
|
||||||
null)]
|
|
||||||
[initial-ans (make-lazy-choice null initial-fail options name)]
|
|
||||||
[ans
|
|
||||||
(if (next-opt initial-ans)
|
|
||||||
initial-ans
|
|
||||||
(fail-res input (lazy-opts-errors initial-ans)))])
|
|
||||||
#;(printf "choice ~a is returning options were ~a, answer is ~a \n" name (choice-names) ans)
|
|
||||||
(weak-map-put! memo-table input ans) ans)])))))
|
|
||||||
|
|
||||||
(define (flatten lst)
|
|
||||||
(cond
|
|
||||||
[(pair? lst)
|
|
||||||
(cond
|
|
||||||
[(pair? (car lst))
|
|
||||||
(append (flatten (car lst))
|
|
||||||
(flatten (cdr lst)))]
|
|
||||||
[else (cons (car lst) (flatten (cdr lst)))])]
|
|
||||||
[else null]))
|
|
||||||
|
|
||||||
;correct-list: (list result) -> (list result)
|
|
||||||
(define (correct-list subs)
|
|
||||||
(cond
|
|
||||||
[(pair? subs)
|
|
||||||
(cond
|
|
||||||
[(and (res? (car subs)) (res-a (car subs)))
|
|
||||||
(cons (car subs) (correct-list (cdr subs)))]
|
|
||||||
[(choice-res? (car subs))
|
|
||||||
(append (choice-res-matches (car subs)) (correct-list (cdr subs)))]
|
|
||||||
[(repeat-res? (car subs))
|
|
||||||
(cons (repeat-res-a (car subs)) (correct-list (cdr subs)))]
|
|
||||||
[(pair? (car subs))
|
|
||||||
(append (car subs) (correct-list (cdr subs)))]
|
|
||||||
[else (correct-list (cdr subs))])]
|
|
||||||
[(null? subs) null]
|
|
||||||
[else (error 'parser-internal-error6 (format "~a" subs))]))
|
|
||||||
|
|
||||||
(define (split-list subs)
|
|
||||||
(let loop ([in subs] [correct null] [incorrect null])
|
|
||||||
(cond
|
|
||||||
[(pair? in)
|
|
||||||
(cond
|
|
||||||
[(and (res? (car in)) (res-a (car in)))
|
|
||||||
(loop (cdr in) (cons (car in) correct) incorrect)]
|
|
||||||
[(choice-res? (car in))
|
|
||||||
(loop (cdr in)
|
|
||||||
(append (choice-res-matches (car in)) correct)
|
|
||||||
(if (choice-res-errors (car in))
|
|
||||||
(cons (choice-res-errors (car in)) incorrect)
|
|
||||||
incorrect))]
|
|
||||||
[(repeat-res? (car in))
|
|
||||||
(loop (cdr in)
|
|
||||||
(cons (repeat-res-a (car in)) correct)
|
|
||||||
incorrect)]
|
|
||||||
[(pair? (car in))
|
|
||||||
(loop (cdr in) (append (car in) correct) incorrect)]
|
|
||||||
[(res? (car in))
|
|
||||||
(loop (cdr in) correct (cons (res-msg (car in)) incorrect))]
|
|
||||||
[else (error 'split-list (car in))])]
|
|
||||||
[(null? in)
|
|
||||||
(values (flatten correct) (flatten incorrect))])))
|
|
||||||
|
|
||||||
(define (src-list src-s src-e)
|
|
||||||
(list (position-line src-s)
|
|
||||||
(position-col src-s)
|
|
||||||
(position-offset src-s)
|
|
||||||
(- (position-offset src-s)
|
|
||||||
(position-offset src-e))))
|
|
||||||
|
|
||||||
(define (update-src-start src new-start)
|
|
||||||
(list (position-line new-start)
|
|
||||||
(position-col new-start)
|
|
||||||
(position-offset new-start)
|
|
||||||
(+ (- (third src)
|
|
||||||
(position-offset new-start))
|
|
||||||
(fourth src))))
|
|
||||||
|
|
||||||
(define (update-src-end src new-end)
|
|
||||||
(when (null? src) (error 'update-src-end))
|
|
||||||
(list (max (first src) 1)
|
|
||||||
(second src)
|
|
||||||
(max (third src) 1)
|
|
||||||
(- (position-offset new-end) (third src))))
|
|
||||||
|
|
||||||
(define (repeat op)
|
|
||||||
(letrec ([name (lambda () (string-append "any number of " (op return-name)))]
|
|
||||||
[r* (opt-lambda (x [s (list 0 1 0 1)] [o 1])
|
|
||||||
((choice (list #;op
|
|
||||||
(seq (list op r*) (lambda (list-args) list-args) (name))
|
|
||||||
(seq null (lambda (x) null) "epsilon"))
|
|
||||||
(name)) x s o))])
|
|
||||||
r*))
|
|
||||||
|
|
||||||
)
|
|
||||||
)
|
|
||||||
|
|
@ -1,353 +0,0 @@
|
||||||
(module errors scheme/base
|
|
||||||
|
|
||||||
(require "structs.scm" "parser-sigs.ss")
|
|
||||||
|
|
||||||
(require scheme/unit)
|
|
||||||
|
|
||||||
(provide (all-defined-out))
|
|
||||||
|
|
||||||
(define-unit error-formatting@
|
|
||||||
(import error-format-parameters^ language-format-parameters^ out^)
|
|
||||||
(export (rename error^ (public-fail-type->message fail-type->message)))
|
|
||||||
|
|
||||||
;public-fail-type->message : fail-type -> err
|
|
||||||
(define (public-fail-type->message fail)
|
|
||||||
(fail-type->message fail null))
|
|
||||||
|
|
||||||
;fail-type->message: fail-type (listof err) -> err
|
|
||||||
(define (fail-type->message fail-type message-to-date)
|
|
||||||
(let* ([name (fail-type-name fail-type)]
|
|
||||||
[a (a/an name)]
|
|
||||||
[msg (lambda (m)
|
|
||||||
(make-err m
|
|
||||||
(if (and (list? (fail-type-src fail-type))
|
|
||||||
(list? (car (fail-type-src fail-type))))
|
|
||||||
(car (fail-type-src fail-type))
|
|
||||||
(fail-type-src fail-type))))])
|
|
||||||
#;(printf "fail-type->message ~a\n" fail-type)
|
|
||||||
(cond
|
|
||||||
[(terminal-fail? fail-type)
|
|
||||||
(collapse-message
|
|
||||||
(add-to-message
|
|
||||||
(msg
|
|
||||||
(case (terminal-fail-kind fail-type)
|
|
||||||
[(end) (format "Expected to find ~a ~a, but ~a ended prematurely."
|
|
||||||
a name input-type)]
|
|
||||||
[(wrong) (format "Expected to find ~a ~a, but instead found ~a."
|
|
||||||
a name (input->output-name (terminal-fail-found fail-type)))]
|
|
||||||
[(misscase) (format "Expected to find ~a ~a, found ~a which may be miscapitalized."
|
|
||||||
a name (input->output-name (terminal-fail-found fail-type)))]
|
|
||||||
[(misspell) (format "Expected to find ~a ~a, found ~a which may be misspelled."
|
|
||||||
a name (input->output-name (terminal-fail-found fail-type)))]
|
|
||||||
[(missclass) (format "Found ~a instead of ~a ~a, a ~a cannot be used as ~a ~a."
|
|
||||||
(input->output-name (terminal-fail-found fail-type)) a name class-type a name)]))
|
|
||||||
name #f message-to-date))]
|
|
||||||
[(sequence-fail? fail-type)
|
|
||||||
#;(printf "sequence-fail case: kind is ~a\n" (sequence-fail-kind fail-type))
|
|
||||||
(let* ([curr-id (sequence-fail-id fail-type)]
|
|
||||||
[id-name
|
|
||||||
(if curr-id (string-append name " " (sequence-fail-id fail-type)) name)]
|
|
||||||
[expected (sequence-fail-expected fail-type)]
|
|
||||||
[a2 (a/an expected)]
|
|
||||||
[show-sequence (sequence-fail-correct fail-type)])
|
|
||||||
(case (sequence-fail-kind fail-type)
|
|
||||||
[(end)
|
|
||||||
(collapse-message
|
|
||||||
(add-to-message
|
|
||||||
(msg (format "Expected ~a to contain ~a ~a to complete the ~a. \nFound ~a before ~a ended."
|
|
||||||
input-type a2 expected id-name (format-seen show-sequence) input-type))
|
|
||||||
name curr-id message-to-date))]
|
|
||||||
[(wrong)
|
|
||||||
(collapse-message
|
|
||||||
(add-to-message
|
|
||||||
(msg
|
|
||||||
(let* ([poss-repeat ((sequence-fail-repeat? fail-type))]
|
|
||||||
[repeat? (and (res? poss-repeat) (res-a poss-repeat) (res-msg poss-repeat))])
|
|
||||||
(cond
|
|
||||||
[repeat?
|
|
||||||
(format "Found a repitition of ~a; the required number are present. Expected ~a ~a next."
|
|
||||||
(sequence-fail-last-seen fail-type) a2 expected)]
|
|
||||||
[(null? show-sequence)
|
|
||||||
(format "Expected ~a ~a to begin this ~a, instead found ~a."
|
|
||||||
a2 expected id-name (input->output-name (sequence-fail-found fail-type)))]
|
|
||||||
[else
|
|
||||||
(format "Expected ~a ~a to continue this ~a. Instead, found ~a after ~a."
|
|
||||||
a2 expected id-name (input->output-name (sequence-fail-found fail-type))
|
|
||||||
(format-seen show-sequence))])))
|
|
||||||
name curr-id message-to-date))]
|
|
||||||
[(misscase)
|
|
||||||
(collapse-message
|
|
||||||
(add-to-message
|
|
||||||
(msg (format "Expected to find ~a ~a to continue this ~a, found ~a which may be miscapitalized."
|
|
||||||
a2 expected id-name (input->output-name (sequence-fail-found fail-type))))
|
|
||||||
name curr-id message-to-date))]
|
|
||||||
[(misspell)
|
|
||||||
(collapse-message
|
|
||||||
(add-to-message
|
|
||||||
(msg (format "Expected to find ~a ~a to continue this ~a, found ~a which may be misspelled."
|
|
||||||
a2 expected id-name (input->output-name (sequence-fail-found fail-type))))
|
|
||||||
name curr-id message-to-date))]
|
|
||||||
[(missclass)
|
|
||||||
(collapse-message
|
|
||||||
(add-to-message
|
|
||||||
(msg (format "Found ~a instead of ~a ~a, a ~a cannot be used as ~a ~a."
|
|
||||||
(input->output-name (sequence-fail-found fail-type)) a2 expected class-type a2 expected))
|
|
||||||
name curr-id message-to-date))]
|
|
||||||
[(sub-seq choice)
|
|
||||||
(fail-type->message (sequence-fail-found fail-type)
|
|
||||||
(add-to-message (msg (format "An error occurred in ~a.\n" id-name))
|
|
||||||
name (sequence-fail-id fail-type) message-to-date))]
|
|
||||||
[(options)
|
|
||||||
(let ([sorted-opts (sort (options-fail-opts (sequence-fail-found fail-type))
|
|
||||||
(lambda (a b) (>= (fail-type-chance a) (fail-type-chance b))))])
|
|
||||||
(if (null? show-sequence)
|
|
||||||
(fail-type->message (sequence-fail-found fail-type) #;(car sorted-opts)
|
|
||||||
(add-to-message (msg (format "This ~a did not begin as expected." id-name))
|
|
||||||
name (sequence-fail-id fail-type) message-to-date))
|
|
||||||
(fail-type->message (sequence-fail-found fail-type) #;(car sorted-opts)
|
|
||||||
(add-to-message
|
|
||||||
(msg (format "There is an error in this ~a after ~a, the program resembles a(n) ~a here.\n"
|
|
||||||
id-name (car (reverse show-sequence))
|
|
||||||
(fail-type-name (car sorted-opts))))
|
|
||||||
name (sequence-fail-id fail-type) message-to-date))))]))]
|
|
||||||
[(options-fail? fail-type)
|
|
||||||
#;(printf "selecting for options on ~a\n" name)
|
|
||||||
(let* ([winners (select-errors (options-fail-opts fail-type))]
|
|
||||||
[top-names (map fail-type-name winners)]
|
|
||||||
[non-dup-tops (remove-dups top-names name)]
|
|
||||||
[top-name (car top-names)])
|
|
||||||
(cond
|
|
||||||
[(and (> (length winners) 1)
|
|
||||||
(> (length non-dup-tops) 1)
|
|
||||||
(> (length winners) max-choice-depth))
|
|
||||||
(collapse-message
|
|
||||||
(add-to-message
|
|
||||||
(msg (format "An error occurred in this ~a. Program resembles these: ~a.\n"
|
|
||||||
name (nice-list non-dup-tops)))
|
|
||||||
name #f message-to-date))]
|
|
||||||
[(and (> (length winners) 1)
|
|
||||||
(<= (length winners) max-choice-depth))
|
|
||||||
(let ([messages (map (lambda (f) (fail-type->message f null)) winners)])
|
|
||||||
(cond
|
|
||||||
[(identical-messages? messages)
|
|
||||||
(collapse-message
|
|
||||||
(add-to-message (car messages) name #f message-to-date))]
|
|
||||||
[else
|
|
||||||
(let ([msg (cond
|
|
||||||
[(apply equal? (map err-src messages)) (lambda (m) (make-err m (err-src (car messages))))]
|
|
||||||
[else msg])])
|
|
||||||
(collapse-message
|
|
||||||
(add-to-message
|
|
||||||
(msg (format "An error occurred in the ~a. Possible errors were: \n ~a"
|
|
||||||
name
|
|
||||||
(alternate-error-list (map err-msg messages))))
|
|
||||||
name #f message-to-date)))]))]
|
|
||||||
[else
|
|
||||||
(fail-type->message
|
|
||||||
(car winners)
|
|
||||||
(add-to-message
|
|
||||||
(msg
|
|
||||||
(format "There is an error in this ~a~a.\n"
|
|
||||||
name
|
|
||||||
(if (equal? top-name name) ""
|
|
||||||
(format ", program resembles ~a ~a" (a/an top-name) top-name))))
|
|
||||||
name #f message-to-date))]))]
|
|
||||||
[(choice-fail? fail-type)
|
|
||||||
#;(printf "selecting for ~a\n message-to-date ~a\n" name message-to-date)
|
|
||||||
(let* ([winners (select-errors (choice-fail-messages fail-type))]
|
|
||||||
[top-names (map fail-type-name winners)]
|
|
||||||
[top-name (car top-names)]
|
|
||||||
[no-dup-names (remove-dups (choice-fail-names fail-type) name)])
|
|
||||||
(cond
|
|
||||||
[(and (choice-fail-ended? fail-type)
|
|
||||||
(> (length winners) 1))
|
|
||||||
(collapse-message
|
|
||||||
(add-to-message
|
|
||||||
(msg (format "Expected a ~a, possible options include ~a." name
|
|
||||||
(nice-list (first-n max-choice-depth no-dup-names))))
|
|
||||||
name #f message-to-date))]
|
|
||||||
[(and (<= (choice-fail-options fail-type) max-choice-depth)
|
|
||||||
(> (length no-dup-names) 1)
|
|
||||||
(> (length winners) 1)
|
|
||||||
(equal? top-names no-dup-names))
|
|
||||||
(collapse-message
|
|
||||||
(add-to-message
|
|
||||||
(msg (format "An error occurred in this ~a; expected ~a instead."
|
|
||||||
name (nice-list no-dup-names)))
|
|
||||||
name #f message-to-date))]
|
|
||||||
[(and (<= (choice-fail-options fail-type) max-choice-depth)
|
|
||||||
(> (length no-dup-names) 1)
|
|
||||||
(> (length winners) 1))
|
|
||||||
(let ([messages (map (lambda (f) (fail-type->message f null)) winners)])
|
|
||||||
(cond
|
|
||||||
[(identical-messages? messages)
|
|
||||||
(collapse-message
|
|
||||||
(add-to-message (car messages) #f #f
|
|
||||||
(add-to-message
|
|
||||||
(msg (format "An error occurred in this ~a, expected ~a instead."
|
|
||||||
name (nice-list no-dup-names)))
|
|
||||||
name #f message-to-date)))]
|
|
||||||
[else
|
|
||||||
(collapse-message
|
|
||||||
(add-to-message
|
|
||||||
(msg (format "An error occurred in this ~a; expected ~a instead. Possible errors were:\n~a"
|
|
||||||
name (nice-list no-dup-names)
|
|
||||||
(alternate-error-list (map err-msg messages))))
|
|
||||||
name #f message-to-date))]))]
|
|
||||||
[(and (> (length no-dup-names) max-choice-depth)
|
|
||||||
(> (length winners) 1))
|
|
||||||
(collapse-message
|
|
||||||
(add-to-message
|
|
||||||
(msg (format "An error occurred in this ~a. Possible options include ~a.\n"
|
|
||||||
name (nice-list
|
|
||||||
(first-n max-choice-depth no-dup-names))))
|
|
||||||
name #f message-to-date))]
|
|
||||||
[else
|
|
||||||
(fail-type->message
|
|
||||||
(car winners)
|
|
||||||
(add-to-message
|
|
||||||
(msg (format "An error occurred in this ~a~a.~a\n"
|
|
||||||
name
|
|
||||||
(if (equal? name top-name) "" (format ", it is possible you intended ~a ~a here"
|
|
||||||
(a/an top-name) top-name))
|
|
||||||
(if show-options " To see all options click here." "")))
|
|
||||||
name #f message-to-date))]))])))
|
|
||||||
|
|
||||||
(define (chance-used a) (* (fail-type-chance a) (fail-type-used a)))
|
|
||||||
(define (chance-may-use a) (* (fail-type-chance a) (fail-type-may-use a)))
|
|
||||||
(define (chance a) (fail-type-chance a))
|
|
||||||
(define (composite a)
|
|
||||||
(/ (+ (chance-used a) (chance-may-use a) (chance a)) 3))
|
|
||||||
|
|
||||||
(define (narrow-opts rank options)
|
|
||||||
(get-ties (sort options (lambda (a b) (> (rank a) (rank b)))) rank))
|
|
||||||
|
|
||||||
(define (select-errors opts-list)
|
|
||||||
(let* ([composite-winners
|
|
||||||
(narrow-opts composite opts-list)]
|
|
||||||
|
|
||||||
[chance-used-winners
|
|
||||||
(narrow-opts chance-used composite-winners)]
|
|
||||||
|
|
||||||
[chance-may-winners
|
|
||||||
(narrow-opts chance-may-use chance-used-winners)]
|
|
||||||
|
|
||||||
[winners (narrow-opts chance chance-may-winners)])
|
|
||||||
#;(printf "all options: ~a\n" opts-list)
|
|
||||||
#;(printf "~a ~a ~a ~a ~a\n"
|
|
||||||
(map fail-type-name opts-list)
|
|
||||||
(map fail-type-chance opts-list)
|
|
||||||
(map fail-type-used opts-list)
|
|
||||||
(map fail-type-may-use opts-list)
|
|
||||||
(map composite opts-list))
|
|
||||||
#;(printf "composite round: ~a ~a \n"
|
|
||||||
(map fail-type-name composite-winners)
|
|
||||||
(map composite composite-winners))
|
|
||||||
#;(printf "final sorting: ~a\n" (map fail-type-name winners))
|
|
||||||
winners))
|
|
||||||
|
|
||||||
(define (first-n n lst)
|
|
||||||
(if (<= (length lst) n)
|
|
||||||
lst
|
|
||||||
(let loop ([count 0] [l lst])
|
|
||||||
(cond
|
|
||||||
[(>= count n) null]
|
|
||||||
[else (cons (car l) (loop (add1 count) (cdr l)))]))))
|
|
||||||
|
|
||||||
(define (get-ties lst evaluate)
|
|
||||||
(if (> (length lst) 1)
|
|
||||||
(letrec ([getter
|
|
||||||
(lambda (sub)
|
|
||||||
(cond
|
|
||||||
[(null? sub) null]
|
|
||||||
[(>= (- (evaluate (car lst)) (evaluate (car sub))) .0001) null]
|
|
||||||
[else (cons (car sub) (getter (cdr sub)))]))])
|
|
||||||
(cons (car lst) (getter (cdr lst))))
|
|
||||||
lst))
|
|
||||||
|
|
||||||
(define (a/an next-string)
|
|
||||||
(if (string? next-string)
|
|
||||||
(if (member (substring next-string 0 1) `("a" "e" "i" "o" "u"))
|
|
||||||
"an" "a")
|
|
||||||
"a"))
|
|
||||||
|
|
||||||
(define (format-seen l)
|
|
||||||
(if (null? l)
|
|
||||||
""
|
|
||||||
(string-append "'"
|
|
||||||
(car l)
|
|
||||||
(apply string-append
|
|
||||||
(map (lambda (i) (string-append " " i)) (cdr l)))
|
|
||||||
"'")))
|
|
||||||
|
|
||||||
(define (nice-list l)
|
|
||||||
(letrec ([formatter
|
|
||||||
(lambda (l)
|
|
||||||
(cond
|
|
||||||
[(null? l) ""]
|
|
||||||
[(null? (cdr l)) (string-append "or " (car l))]
|
|
||||||
[else (string-append (car l) ", " (formatter (cdr l)))]))])
|
|
||||||
(cond
|
|
||||||
[(null? l) (error 'internal-error "nice-list in combinator-parser/errors.scm received null list")]
|
|
||||||
[(null? (cdr l)) (car l)]
|
|
||||||
[(null? (cddr l)) (string-append (car l) " or " (cadr l))]
|
|
||||||
[else (formatter l)])))
|
|
||||||
|
|
||||||
(define (alternate-error-list l)
|
|
||||||
(cond
|
|
||||||
[(null? l) ""]
|
|
||||||
[else
|
|
||||||
(let ([msg (if (equal? #\newline (string-ref (car l) (sub1 (string-length (car l)))))
|
|
||||||
(substring (car l) 0 (sub1 (string-length (car l))))
|
|
||||||
(car l))])
|
|
||||||
(string-append (format "~a~a\n" #\tab msg)
|
|
||||||
(alternate-error-list (cdr l))))]))
|
|
||||||
|
|
||||||
(define (downcase string)
|
|
||||||
(string-append (string-downcase (substring string 0 1))
|
|
||||||
(substring string 1 (string-length string))))
|
|
||||||
|
|
||||||
(define (identical-messages? msgs)
|
|
||||||
(andmap (lambda (err) (equal? (err-msg (car msgs))
|
|
||||||
(err-msg err)))
|
|
||||||
(cdr msgs)))
|
|
||||||
|
|
||||||
(define (remove-dups l n)
|
|
||||||
(cond
|
|
||||||
[(null? l) null]
|
|
||||||
[(equal? (car l) n)
|
|
||||||
(remove-dups (cdr l) n)]
|
|
||||||
[(member (car l) (cdr l))
|
|
||||||
(remove-dups (cdr l) n)]
|
|
||||||
[else (cons (car l) (remove-dups (cdr l) n))]))
|
|
||||||
|
|
||||||
(define-struct ms (who id? say))
|
|
||||||
|
|
||||||
;add-to-message: err string bool (list err) -> (list err)
|
|
||||||
(define (add-to-message msg name id? rest)
|
|
||||||
(let ([next (make-ms name id? msg)]
|
|
||||||
[curr-len (length rest)])
|
|
||||||
(cond
|
|
||||||
[(null? rest) (list next)]
|
|
||||||
[(equal? (ms-who (car rest)) name) (cons next (cdr rest))]
|
|
||||||
[(and id? (ms-id? (car rest)) (< curr-len max-depth)) (cons next rest)]
|
|
||||||
[(and id? (ms-id? (car rest))) (cons next (first-n (sub1 max-depth) rest))]
|
|
||||||
[id? (add-to-message msg name id? (cdr rest))]
|
|
||||||
[(< (length rest) max-depth) (cons next rest)]
|
|
||||||
[else (cons next (first-n (sub1 max-depth) rest))])))
|
|
||||||
|
|
||||||
;combine-message: (list ms) -> err
|
|
||||||
(define (collapse-message messages)
|
|
||||||
(let loop ([end-msg (ms-say (car messages))]
|
|
||||||
[messages (cdr messages)])
|
|
||||||
(cond
|
|
||||||
[(null? messages) end-msg]
|
|
||||||
[else
|
|
||||||
(loop
|
|
||||||
(make-err (string-append (err-msg (ms-say (car messages)))
|
|
||||||
(err-msg end-msg))
|
|
||||||
(err-src end-msg))
|
|
||||||
(cdr messages))])))
|
|
||||||
|
|
||||||
)
|
|
||||||
)
|
|
||||||
|
|
@ -1,199 +0,0 @@
|
||||||
(module parser-sigs scheme
|
|
||||||
|
|
||||||
(require (only-in mzlib/etc opt-lambda)) ; Required for expansion
|
|
||||||
(require parser-tools/lex
|
|
||||||
mzlib/string)
|
|
||||||
|
|
||||||
(provide (all-defined-out))
|
|
||||||
|
|
||||||
(define-signature-form (terminals stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ group (elt ...))
|
|
||||||
(and (identifier? #'group)
|
|
||||||
(andmap identifier? (syntax->list #'(elt ...))))
|
|
||||||
(syntax->list #`(elt ...
|
|
||||||
#,@(map (lambda (e)
|
|
||||||
(datum->syntax e
|
|
||||||
(string->symbol
|
|
||||||
(format "token-~a" (syntax-e e)))))
|
|
||||||
(syntax->list #'(elt ...)))))]))
|
|
||||||
|
|
||||||
(define-signature-form (recurs stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ id ...)
|
|
||||||
(andmap identifier? (syntax->list #'(id ...)))
|
|
||||||
(syntax->list #`(id ...
|
|
||||||
#,@(map (lambda (e) #`(define-syntaxes
|
|
||||||
(#,(datum->syntax e (string->symbol (format "~a@" (syntax-e e)))))
|
|
||||||
(values (syntax-id-rules () [_ (opt-lambda (x [s (list 0 1 0 1)] [o 1]) (#,e x s o))]))))
|
|
||||||
(syntax->list #'(id ...)))))]))
|
|
||||||
|
|
||||||
(define-signature language-dictionary^ (misspelled misscap missclass))
|
|
||||||
|
|
||||||
(define-signature combinator-parser-forms^
|
|
||||||
(terminal choice seq repeat repeat-greedy
|
|
||||||
(define-syntaxes (define-simple-terminals)
|
|
||||||
(values
|
|
||||||
(lambda (stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
((_ group elts)
|
|
||||||
(let ([name-string-thunks
|
|
||||||
(let loop ([elt-list (syntax elts)])
|
|
||||||
(syntax-case elt-list (lambda)
|
|
||||||
[() null]
|
|
||||||
[(id . rest)
|
|
||||||
(identifier? (syntax id))
|
|
||||||
(cons (list (syntax id)
|
|
||||||
(syntax (symbol->string (quote id)))
|
|
||||||
`(lambda (x . args) x))
|
|
||||||
(loop (syntax rest)))]
|
|
||||||
[((id name) . rest)
|
|
||||||
(and (identifier? (syntax id)) (string? (syntax-e (syntax name))))
|
|
||||||
(cons (list (syntax id)
|
|
||||||
(syntax name)
|
|
||||||
`(lambda (x . args) x))
|
|
||||||
(loop (syntax rest)))]
|
|
||||||
[((id thunk) . rest)
|
|
||||||
(and (identifier? (syntax id)) (identifier? (syntax thunk)))
|
|
||||||
(cons (list (syntax id)
|
|
||||||
(syntax (symbol->string (quote id)))
|
|
||||||
(syntax thunk))
|
|
||||||
(loop (syntax rest)))]
|
|
||||||
[((id (lambda x body ...)) . rest)
|
|
||||||
(identifier? (syntax id))
|
|
||||||
(cons (list (syntax id)
|
|
||||||
(syntax (symbol->string (quote id)))
|
|
||||||
(syntax (lambda x body ...)))
|
|
||||||
(loop (syntax rest)))]
|
|
||||||
[((id name thunk) . rest)
|
|
||||||
(and (identifier? (syntax id)) (string? (syntax-e (syntax name))))
|
|
||||||
(cons (list (syntax id)
|
|
||||||
(syntax name)
|
|
||||||
(syntax thunk))
|
|
||||||
(loop (syntax rest)))]))])
|
|
||||||
(with-syntax ([(id ...) (map car name-string-thunks)]
|
|
||||||
[(name ...) (map cadr name-string-thunks)]
|
|
||||||
[(thunk ...) (map caddr name-string-thunks)])
|
|
||||||
(syntax
|
|
||||||
(begin
|
|
||||||
(define-empty-tokens group (id ...))
|
|
||||||
(define id
|
|
||||||
(terminal
|
|
||||||
(lambda (token) (eq? (token-name token) (quote id)))
|
|
||||||
thunk
|
|
||||||
name)) ...)))))))))
|
|
||||||
|
|
||||||
(define-syntaxes (define-terminals)
|
|
||||||
(values
|
|
||||||
(lambda (stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ group elts)
|
|
||||||
(identifier? (syntax group))
|
|
||||||
(let ([name-string-thunks
|
|
||||||
(let loop ([elt-list (syntax elts)])
|
|
||||||
(syntax-case elt-list (lambda)
|
|
||||||
[() null]
|
|
||||||
[((id (lambda (arg1 ...) body ...)) . rest)
|
|
||||||
(identifier? (syntax id))
|
|
||||||
(cons (list (syntax id)
|
|
||||||
(syntax (symbol->string (quote id)))
|
|
||||||
(syntax (lambda (arg1 ...) body ...)))
|
|
||||||
(loop (syntax rest)))]
|
|
||||||
[((id thunk) . rest)
|
|
||||||
(and (identifier? (syntax id)) (identifier? (syntax thunk)))
|
|
||||||
(cons (list (syntax id)
|
|
||||||
(syntax (symbol->string (quote id)))
|
|
||||||
(syntax thunk))
|
|
||||||
(loop (syntax rest)))]
|
|
||||||
[((id name thunk) . rest)
|
|
||||||
(cons (list (syntax id)
|
|
||||||
(syntax name)
|
|
||||||
(syntax thunk))
|
|
||||||
(loop (syntax rest)))]))])
|
|
||||||
(with-syntax ([(id ...) (map car name-string-thunks)]
|
|
||||||
[(name ...) (map cadr name-string-thunks)]
|
|
||||||
[(thunk ...) (map caddr name-string-thunks)])
|
|
||||||
(syntax
|
|
||||||
(begin
|
|
||||||
(define-tokens group (id ...))
|
|
||||||
(define id
|
|
||||||
(terminal
|
|
||||||
(lambda (token) (eq? (token-name token) (quote id)))
|
|
||||||
(lambda (x . args)
|
|
||||||
(if (null? args)
|
|
||||||
(thunk (token-value x))
|
|
||||||
(thunk (token-value x) (car args) (cadr args))))
|
|
||||||
name
|
|
||||||
(lambda (token) 0)
|
|
||||||
(lambda (token) #f))) ...))))]))))
|
|
||||||
|
|
||||||
(define-syntaxes (sequence choose ^)
|
|
||||||
(let ([insert-name
|
|
||||||
(lambda (stx name)
|
|
||||||
(let loop ([term stx]
|
|
||||||
[pos 0]
|
|
||||||
[id-pos 0]
|
|
||||||
[terms null])
|
|
||||||
(syntax-case* term (sequence choose ^)
|
|
||||||
(lambda (a b) (eq? (syntax-e a) (syntax-e b)))
|
|
||||||
[((sequence a b) . rest)
|
|
||||||
(loop (syntax rest) (add1 pos) id-pos
|
|
||||||
(cons (quasisyntax (sequence a b #,name)) terms))]
|
|
||||||
[((choose a) . rest)
|
|
||||||
(loop (syntax rest) (add1 pos) id-pos
|
|
||||||
(cons (quasisyntax (choose a #,name)) terms))]
|
|
||||||
[((^ a) . rest)
|
|
||||||
(loop (syntax (a . rest))
|
|
||||||
pos (add1 pos) terms)]
|
|
||||||
[(a . rest)
|
|
||||||
(loop (syntax rest) (add1 pos) id-pos (cons (syntax a) terms))]
|
|
||||||
[() (list (reverse terms) id-pos)])))])
|
|
||||||
(values
|
|
||||||
(lambda (stx)
|
|
||||||
(syntax-case stx (^)
|
|
||||||
[(_ (term ...) proc)
|
|
||||||
(syntax
|
|
||||||
(seq (list term ...) proc (symbol->string (gensym 'seq))))]
|
|
||||||
[(_ terms proc name)
|
|
||||||
(let ([new-terms (insert-name (syntax terms) (syntax name))])
|
|
||||||
(with-syntax (((term ...) (car new-terms))
|
|
||||||
(id-pos (cadr new-terms)))
|
|
||||||
(syntax (seq (list term ...) proc name id-pos))))]))
|
|
||||||
(lambda (stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ (term ...))
|
|
||||||
(syntax
|
|
||||||
(choice (list term ...) (symbol->string (gensym 'choice))))]
|
|
||||||
[(_ terms name)
|
|
||||||
(with-syntax (((term ...) [car (insert-name (syntax terms) (syntax name))]))
|
|
||||||
(syntax
|
|
||||||
(choice (list term ...) name)))]))
|
|
||||||
(syntax-rules ()
|
|
||||||
[(_ f) f]))))
|
|
||||||
|
|
||||||
(define-syntaxes (eta)
|
|
||||||
(values (syntax-rules ()
|
|
||||||
[(_ f)
|
|
||||||
(opt-lambda (x [s (list 0 1 0 1)] [o 1]) (f x s o))])))
|
|
||||||
))
|
|
||||||
|
|
||||||
(define-signature parser^ (parser))
|
|
||||||
(define-signature out^ ((struct err (msg src))))
|
|
||||||
|
|
||||||
(define-signature language-format-parameters^ (class-type input->output-name))
|
|
||||||
|
|
||||||
(define-signature error-format-parameters^
|
|
||||||
(src? input-type show-options max-depth max-choice-depth))
|
|
||||||
|
|
||||||
(define-signature ranking-parameters^
|
|
||||||
(rank-misspell rank-caps rank-class rank-wrong rank-end rank-choice rank-repeat))
|
|
||||||
|
|
||||||
(define-signature updating-rank^
|
|
||||||
(blamed-terminal failed-last-parse))
|
|
||||||
|
|
||||||
(define-signature error^ (fail-type->message))
|
|
||||||
|
|
||||||
(define-signature combinator-parser^ extends combinator-parser-forms^ (parser))
|
|
||||||
(define-signature err^ (err? err-msg err-src))
|
|
||||||
|
|
||||||
)
|
|
||||||
|
|
@ -1,125 +0,0 @@
|
||||||
(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) #:transparent)
|
|
||||||
;(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)) #:transparent)
|
|
||||||
|
|
||||||
;result = res | choice-res | repeat-res | (listof (U res choice-res))
|
|
||||||
|
|
||||||
;(make-res parse-build (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)
|
|
||||||
|
|
||||||
;(make-count string int)
|
|
||||||
(define-struct occurs (terminal count))
|
|
||||||
|
|
||||||
(define (consolidate-count cts)
|
|
||||||
(cond
|
|
||||||
[(null? cts) cts]
|
|
||||||
[(eq? 'counting (car cts)) (consolidate-count cts)]
|
|
||||||
[(pair? (car cts)) (consolidate-count (append (car cts) (cdr cts)))]
|
|
||||||
[else
|
|
||||||
(let-values ([(front back) (augment-count (car cts) (cdr cts))])
|
|
||||||
(cons front (consolidate-count back)))]))
|
|
||||||
(define (augment-count count rst)
|
|
||||||
(cond
|
|
||||||
[(null? rst) (values count rst)]
|
|
||||||
[(eq? 'counting (car rst)) (augment-count count (cdr rst))]
|
|
||||||
[(pair? (car rst)) (augment-count count (append (car rst) (cdr rst)))]
|
|
||||||
[else
|
|
||||||
(let-values ([(current back) (augment-count count (cdr rst))])
|
|
||||||
(cond
|
|
||||||
[(equal? (occurs-terminal count) (occurs-terminal (car rst)))
|
|
||||||
(values (make-occurs (occurs-terminal count) (+ (occurs-count count)
|
|
||||||
(occurs-count current)
|
|
||||||
(occurs-count (car rst))))
|
|
||||||
back)]
|
|
||||||
[else (values current (cons (car rst) back))]))]))
|
|
||||||
|
|
||||||
|
|
||||||
;parse-build = answer | none
|
|
||||||
;(make-answer 'b)
|
|
||||||
(define-struct answer (ast))
|
|
||||||
(define-struct none ())
|
|
||||||
|
|
||||||
(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))
|
|
||||||
|
|
||||||
)
|
|
||||||
|
|
@ -543,9 +543,8 @@ mz-extras :+= (collects: "ffi/") (doc: "objc")
|
||||||
;; -------------------- preprocessor
|
;; -------------------- preprocessor
|
||||||
mz-extras :+= (package: "preprocessor/") (bin: "mzpp" "mztext")
|
mz-extras :+= (package: "preprocessor/") (bin: "mzpp" "mztext")
|
||||||
|
|
||||||
;; -------------------- tex2page & slatex
|
;; -------------------- slatex
|
||||||
plt-extras :+= (package: "tex2page")
|
plt-extras :+= (package: "slatex")
|
||||||
(package: "slatex")
|
|
||||||
(bin: "PDF SLaTeX")
|
(bin: "PDF SLaTeX")
|
||||||
(doc+src: "slatex-wrap/")
|
(doc+src: "slatex-wrap/")
|
||||||
|
|
||||||
|
|
@ -588,9 +587,6 @@ plt-extras :+= (package: "macro-debugger")
|
||||||
;; -------------------- lazy
|
;; -------------------- lazy
|
||||||
plt-extras :+= (package: "lazy")
|
plt-extras :+= (package: "lazy")
|
||||||
|
|
||||||
;; -------------------- combinator-parser
|
|
||||||
plt-extras :+= (collects: "combinator-parser")
|
|
||||||
|
|
||||||
;; -------------------- icons, images
|
;; -------------------- icons, images
|
||||||
dr-extras :+= (collects: "icons/*.{jpg|png|gif|bmp|xbm|xpm}")
|
dr-extras :+= (collects: "icons/*.{jpg|png|gif|bmp|xbm|xpm}")
|
||||||
dr-extras :+= (package: "images/")
|
dr-extras :+= (package: "images/")
|
||||||
|
|
@ -666,9 +662,6 @@ plt-extras :+= (- (+ (dll: "myssink")
|
||||||
(package: "mysterx"))
|
(package: "mysterx"))
|
||||||
(cond (not win) => (src: "")))
|
(cond (not win) => (src: "")))
|
||||||
|
|
||||||
;; -------------------- temporary tool for converting old files
|
|
||||||
plt-extras :+= (package: "test-box-recovery")
|
|
||||||
|
|
||||||
;; -------------------- redex
|
;; -------------------- redex
|
||||||
plt-extras :+= (package: "redex")
|
plt-extras :+= (package: "redex")
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -665,7 +665,6 @@ path/s is either such a string or a list of them.
|
||||||
"collects/algol60" responsible (mflatt robby)
|
"collects/algol60" responsible (mflatt robby)
|
||||||
"collects/at-exp" responsible (eli mflatt)
|
"collects/at-exp" responsible (eli mflatt)
|
||||||
"collects/browser" responsible (robby)
|
"collects/browser" responsible (robby)
|
||||||
"collects/combinator-parser" responsible (kathyg)
|
|
||||||
"collects/compiler" responsible (mflatt)
|
"collects/compiler" responsible (mflatt)
|
||||||
"collects/compiler/commands/ctool.rkt" drdr:command-line #f
|
"collects/compiler/commands/ctool.rkt" drdr:command-line #f
|
||||||
"collects/compiler/commands/exe-dir.rkt" drdr:command-line #f
|
"collects/compiler/commands/exe-dir.rkt" drdr:command-line #f
|
||||||
|
|
@ -999,7 +998,6 @@ path/s is either such a string or a list of them.
|
||||||
"collects/teachpack/balls.ss" drdr:command-line (mzc *)
|
"collects/teachpack/balls.ss" drdr:command-line (mzc *)
|
||||||
"collects/teachpack/deinprogramm" responsible (sperber)
|
"collects/teachpack/deinprogramm" responsible (sperber)
|
||||||
"collects/teachpack/htdp/graphing.ss" drdr:command-line (mzc *)
|
"collects/teachpack/htdp/graphing.ss" drdr:command-line (mzc *)
|
||||||
"collects/test-box-recovery" responsible (mflatt)
|
|
||||||
"collects/test-engine" responsible (kathyg)
|
"collects/test-engine" responsible (kathyg)
|
||||||
"collects/tests/algol60" responsible (mflatt robby)
|
"collects/tests/algol60" responsible (mflatt robby)
|
||||||
"collects/tests/compiler" responsible (jay)
|
"collects/tests/compiler" responsible (jay)
|
||||||
|
|
@ -1486,7 +1484,6 @@ path/s is either such a string or a list of them.
|
||||||
"collects/tests/xrepl/main.rkt" drdr:command-line #f
|
"collects/tests/xrepl/main.rkt" drdr:command-line #f
|
||||||
"collects/tests/zo-path.rkt" responsible (mflatt)
|
"collects/tests/zo-path.rkt" responsible (mflatt)
|
||||||
"collects/tests/zo-size.rkt" responsible (jay)
|
"collects/tests/zo-size.rkt" responsible (jay)
|
||||||
"collects/tex2page" responsible (jay)
|
|
||||||
"collects/texpict" responsible (mflatt robby)
|
"collects/texpict" responsible (mflatt robby)
|
||||||
"collects/texpict/face-demo.rkt" drdr:command-line (mzc *)
|
"collects/texpict/face-demo.rkt" drdr:command-line (mzc *)
|
||||||
"collects/trace" responsible (mflatt robby)
|
"collects/trace" responsible (mflatt robby)
|
||||||
|
|
@ -1563,7 +1560,6 @@ path/s is either such a string or a list of them.
|
||||||
"man/man1/racket.1" responsible (mflatt)
|
"man/man1/racket.1" responsible (mflatt)
|
||||||
"man/man1/raco.1" responsible (mflatt)
|
"man/man1/raco.1" responsible (mflatt)
|
||||||
"man/man1/setup-plt.1" responsible (mflatt)
|
"man/man1/setup-plt.1" responsible (mflatt)
|
||||||
"man/man1/tex2page.1" responsible (jay)
|
|
||||||
"src" responsible (mflatt)
|
"src" responsible (mflatt)
|
||||||
"src/foreign" responsible (eli)
|
"src/foreign" responsible (eli)
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,8 +0,0 @@
|
||||||
#lang setup/infotab
|
|
||||||
|
|
||||||
(define categories '(devtools))
|
|
||||||
(define required-core-version "370")
|
|
||||||
(define tools (list '("tool.rkt")))
|
|
||||||
(define tool-names (list "Test Box Recovery"))
|
|
||||||
|
|
||||||
(define scribblings '(("test-box-recovery.scrbl" () (legacy))))
|
|
||||||
|
|
@ -1,19 +0,0 @@
|
||||||
#lang scribble/doc
|
|
||||||
@(require scribble/manual
|
|
||||||
(for-label lang/htdp-beginner))
|
|
||||||
|
|
||||||
@title{Test Box Recovery Tool}
|
|
||||||
|
|
||||||
The text-box recovery tool allows DrRacket or DrScheme v370 and later to read
|
|
||||||
programs created using v360 and earlier that include test-case boxes.
|
|
||||||
|
|
||||||
When opened using this tool, test-case boxes are turned into
|
|
||||||
@racket[check-expect] forms.
|
|
||||||
|
|
||||||
Test boxes plain-text tests and expected results are converted to
|
|
||||||
plain-text @racket[check-expect] forms.
|
|
||||||
|
|
||||||
If either the test or expected-result expression contains non-text
|
|
||||||
(e.g., an image), the converted form is a comment box containing a
|
|
||||||
@racket[check-expect] form. The box should be easy to remove using the
|
|
||||||
@menuitem["Racket" "Uncomment"] menu item in DrRacket.
|
|
||||||
|
|
@ -1,108 +0,0 @@
|
||||||
|
|
||||||
(module tool mzscheme
|
|
||||||
(require drscheme/tool
|
|
||||||
mred
|
|
||||||
mzlib/class
|
|
||||||
mzlib/unit
|
|
||||||
framework)
|
|
||||||
|
|
||||||
(provide tool@)
|
|
||||||
|
|
||||||
(define tool@
|
|
||||||
(unit
|
|
||||||
(import drscheme:tool^)
|
|
||||||
(export drscheme:tool-exports^)
|
|
||||||
|
|
||||||
(define test-box-recovery-snipclass%
|
|
||||||
(class snip-class%
|
|
||||||
|
|
||||||
(inherit reading-version)
|
|
||||||
|
|
||||||
(define/private (strings? e)
|
|
||||||
(not (send e find-next-non-string-snip #f)))
|
|
||||||
|
|
||||||
(define/private (extract-text e)
|
|
||||||
(regexp-replace* #rx"\r\n" (send e get-flattened-text) " "))
|
|
||||||
|
|
||||||
(define (make-string-snip s)
|
|
||||||
(make-object string-snip% s))
|
|
||||||
|
|
||||||
(define (make-comment-box . elems)
|
|
||||||
(let* ([s (new comment-box:snip%)]
|
|
||||||
[e (send s get-editor)])
|
|
||||||
(for-each (lambda (elem)
|
|
||||||
(cond
|
|
||||||
[(string? elem) (send e insert elem)]
|
|
||||||
[(elem . is-a? . text%)
|
|
||||||
(let loop ()
|
|
||||||
(let ([s (send elem find-first-snip)])
|
|
||||||
(when s
|
|
||||||
(send elem release-snip s)
|
|
||||||
(send e insert s)
|
|
||||||
(loop))))]
|
|
||||||
[else (void)]))
|
|
||||||
elems)
|
|
||||||
s))
|
|
||||||
|
|
||||||
(define/override (read f)
|
|
||||||
(let ([enabled?-box (box 0)]
|
|
||||||
[collapsed?-box (box 0)]
|
|
||||||
[error-box?-box (box 0)]
|
|
||||||
[to-test (new text%)]
|
|
||||||
[expected (new text%)]
|
|
||||||
[predicate (new text%)]
|
|
||||||
[should-raise (new text%)]
|
|
||||||
[error-message (new text%)])
|
|
||||||
(let ([vers (reading-version f)])
|
|
||||||
(case vers
|
|
||||||
[(1)
|
|
||||||
;; Discard comment:
|
|
||||||
(send (new text%) read-from-file f)
|
|
||||||
(send* to-test (erase) (read-from-file f))
|
|
||||||
(send* expected (erase) (read-from-file f))
|
|
||||||
;; Nothing else is in the stream in version 1,
|
|
||||||
;; so leave the defaults
|
|
||||||
]
|
|
||||||
[(2)
|
|
||||||
(send* to-test (erase) (read-from-file f))
|
|
||||||
(send* expected (erase) (read-from-file f))
|
|
||||||
(send* predicate (erase) (read-from-file f))
|
|
||||||
(send* should-raise (erase) (read-from-file f))
|
|
||||||
(send* error-message (erase) (read-from-file f))
|
|
||||||
(send f get enabled?-box)
|
|
||||||
(send f get collapsed?-box)
|
|
||||||
(send f get error-box?-box)]))
|
|
||||||
(if (zero? (unbox error-box?-box))
|
|
||||||
(if (and (strings? to-test)
|
|
||||||
(strings? expected))
|
|
||||||
(make-string-snip
|
|
||||||
(format "(check-expect ~a ~a)"
|
|
||||||
(extract-text to-test)
|
|
||||||
(extract-text expected)))
|
|
||||||
(make-comment-box "(check-expect "
|
|
||||||
to-test
|
|
||||||
" "
|
|
||||||
expected
|
|
||||||
")"))
|
|
||||||
(if (strings? to-test)
|
|
||||||
(make-string-snip
|
|
||||||
(format "(check-error ~a ~s)"
|
|
||||||
(extract-text to-test)
|
|
||||||
(extract-text error-message)))
|
|
||||||
(make-comment-box "(check-error "
|
|
||||||
to-test
|
|
||||||
" "
|
|
||||||
(extract-text error-message)
|
|
||||||
")")))))
|
|
||||||
|
|
||||||
(super-new)))
|
|
||||||
|
|
||||||
(define (phase1)
|
|
||||||
(let ([sc (new test-box-recovery-snipclass%)])
|
|
||||||
(send sc set-classname "test-case-box%")
|
|
||||||
(send sc set-version 2)
|
|
||||||
(send (get-the-snip-class-list) add sc)))
|
|
||||||
|
|
||||||
(define (phase2)
|
|
||||||
(void)))))
|
|
||||||
|
|
||||||
|
|
@ -1,4 +0,0 @@
|
||||||
#lang setup/infotab
|
|
||||||
|
|
||||||
(define mzscheme-launcher-libraries (list "start.rkt"))
|
|
||||||
(define mzscheme-launcher-names (list "tex2page"))
|
|
||||||
|
|
@ -1,4 +0,0 @@
|
||||||
#lang scheme/base
|
|
||||||
|
|
||||||
(require "tex2page.rkt")
|
|
||||||
(provide (all-from-out "tex2page.rkt"))
|
|
||||||
|
|
@ -1,12 +0,0 @@
|
||||||
(module start mzscheme
|
|
||||||
(require "tex2page.rkt"
|
|
||||||
mzlib/cmdline)
|
|
||||||
|
|
||||||
(command-line
|
|
||||||
"tex2page"
|
|
||||||
(current-command-line-arguments)
|
|
||||||
[once-each
|
|
||||||
[("--version") "Reports long help and version information"
|
|
||||||
(tex2page "--version")]]
|
|
||||||
[args file "Processes each <file>"
|
|
||||||
(map tex2page file)]))
|
|
||||||
File diff suppressed because one or more lines are too long
|
|
@ -1,12 +0,0 @@
|
||||||
(module tex2page mzscheme
|
|
||||||
(require mzlib/etc)
|
|
||||||
(provide tex2page)
|
|
||||||
(define
|
|
||||||
tex2page
|
|
||||||
(lambda (f)
|
|
||||||
(parameterize
|
|
||||||
((current-namespace (make-namespace)))
|
|
||||||
(namespace-require
|
|
||||||
`(file ,(path->string (build-path (this-expression-source-directory)
|
|
||||||
"tex2page-aux.rkt"))))
|
|
||||||
((namespace-variable-value 'tex2page) f)))))
|
|
||||||
|
|
@ -1,9 +0,0 @@
|
||||||
% tex2page.sty
|
|
||||||
% Dorai Sitaram
|
|
||||||
|
|
||||||
% Loading this file in a LaTeX document
|
|
||||||
% gives it all the macros of tex2page.tex,
|
|
||||||
% but via a more LaTeX-convenient filename.
|
|
||||||
|
|
||||||
\input{tex2page}
|
|
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,174 +0,0 @@
|
||||||
.TH TEX2PAGE 1 "2007-02-21" \"last change
|
|
||||||
.SH NAME
|
|
||||||
|
|
||||||
tex2page \- makes Web pages from LaTeX and plain-TeX documents
|
|
||||||
|
|
||||||
.SH SYNOPSIS
|
|
||||||
|
|
||||||
tex2page --help
|
|
||||||
tex2page --version
|
|
||||||
tex2page <pathname>
|
|
||||||
|
|
||||||
.SH DESCRIPTION
|
|
||||||
|
|
||||||
The command
|
|
||||||
|
|
||||||
tex2page <pathname>
|
|
||||||
|
|
||||||
converts the TeX source file <pathname> to the HTML file
|
|
||||||
<jobname>.html, where <jobname> is the basename of <pathname>.
|
|
||||||
Some auxiliary HTML files and some image files may also be
|
|
||||||
created.
|
|
||||||
|
|
||||||
The argument <pathname> can be a full or relative pathname. If
|
|
||||||
the latter, it is reckoned relative to the current directory.
|
|
||||||
The extension may be omitted if it is .tex.
|
|
||||||
|
|
||||||
In order to resolve cross-references, it may be necessary to
|
|
||||||
invoke tex2page a couple of times. The log displayed on the
|
|
||||||
console will inform you if such is the case. This log is also
|
|
||||||
saved in the file <jobname>.hlog.
|
|
||||||
|
|
||||||
If tex2page is called with the option `--help', it prints a help
|
|
||||||
message and exits.
|
|
||||||
|
|
||||||
If tex2page is called with the option `--version', it prints
|
|
||||||
version information and exits.
|
|
||||||
|
|
||||||
If tex2page is called without an argument, or if the argument is
|
|
||||||
neither a valid option nor an existing file, then tex2page prints
|
|
||||||
a brief help message and exits. If you repeatedly (i.e., five or
|
|
||||||
more times) call it faultily despite its helpful advice, tex2page
|
|
||||||
will visibly lose its patience.
|
|
||||||
|
|
||||||
The complete documentation for tex2page is included in the
|
|
||||||
tex2page distribution, and may also be viewed on the Web at
|
|
||||||
|
|
||||||
http://www.ccs.neu.edu/~dorai/tex2page/tex2page-doc.html
|
|
||||||
|
|
||||||
.SH SEARCH PATH FOR TeX FILES
|
|
||||||
|
|
||||||
tex2page uses the same search path as TeX to search for
|
|
||||||
\einput and \eopenin files. The default search path is
|
|
||||||
implementation-dependent but can be changed by setting the
|
|
||||||
environment variable TEXINPUTS to a list of colon-separated
|
|
||||||
directories. (If you wish to merely prepend your list to the
|
|
||||||
default list, end your list with a colon.)
|
|
||||||
|
|
||||||
Add two trailing forward slashes to any directory in TEXINPUTS
|
|
||||||
that you want to recursively search all subdirectories of.
|
|
||||||
|
|
||||||
If the environment variable TIIPINPUTS is set, tex2page will
|
|
||||||
use the TIIPINPUTS value as its search path instead of
|
|
||||||
TEXINPUTS. TIIPINPUTS does not support the double-slash
|
|
||||||
mechanism of TEXINPUTS.
|
|
||||||
|
|
||||||
.SH EDITING ON ERROR
|
|
||||||
|
|
||||||
If tex2page encounters a fatal error in the document, it
|
|
||||||
displays the prompt
|
|
||||||
|
|
||||||
Type e to edit file at point of error; x to quit
|
|
||||||
?
|
|
||||||
|
|
||||||
If you type x, tex2page immediately exits.
|
|
||||||
|
|
||||||
If however you type e, a text editor is fired up, showing the
|
|
||||||
offending file -- which may or may not be the main input file --
|
|
||||||
at the line containing the error. The particular editor chosen
|
|
||||||
and the arguments with which it is called depends on the
|
|
||||||
environment variables TEXEDIT or EDITOR.
|
|
||||||
|
|
||||||
If the environment variable TEXEDIT is set, tex2page uses its
|
|
||||||
string value as the editor call to use. A possible value for
|
|
||||||
TEXEDIT is "vim +%d %s". This calls the editor vim with %s
|
|
||||||
replaced by the offending file's name, and %d replaced by the
|
|
||||||
number of the offending line.
|
|
||||||
|
|
||||||
If TEXEDIT is not set, the value of the environment variable
|
|
||||||
EDITOR is chosen as the editor. Unlike TEXEDIT
|
|
||||||
which contains the editor call as a template, EDITOR contains
|
|
||||||
simply the editor's name. If EDITOR is also not set, vi is
|
|
||||||
chosen as the editor.
|
|
||||||
|
|
||||||
The editor specified in EDITOR is called with the arguments
|
|
||||||
" +<n> <f>", where <f> is the offending file's name and <n> is the
|
|
||||||
offending line number. It is not possible to alter the way the
|
|
||||||
file and line arguments are supplied, but fortunately this style
|
|
||||||
is accepted by vi, emacs, and all their clones. If you use an
|
|
||||||
editor that requires a different argument style, use TEXEDIT.
|
|
||||||
|
|
||||||
.SH DIRECTORY FOR HTML PAGES
|
|
||||||
|
|
||||||
By default, tex2page generates its output HTML files in the
|
|
||||||
current directory. You can specify a different directory by
|
|
||||||
naming it in one of the following files:
|
|
||||||
|
|
||||||
<jobname>.hdir in the current directory, or
|
|
||||||
.tex2page.hdir in the current directory, or
|
|
||||||
.tex2page.hdir in your home directory;
|
|
||||||
|
|
||||||
where <jobname> is the basename of the input document. The
|
|
||||||
first of these three files that exists overrides the rest.
|
|
||||||
|
|
||||||
The name in the .hdir file can be, or contain, the TeX
|
|
||||||
control-sequence \ejobname, which expands to <jobname>, the
|
|
||||||
basename of the input document.
|
|
||||||
|
|
||||||
.SH DOCUMENT-SPECIFIC MACROS
|
|
||||||
|
|
||||||
Before processing a TeX source file whose basename is
|
|
||||||
<jobname>, tex2page will automatically load the file
|
|
||||||
<jobname>.t2p, if it exists. <jobname>.t2p is a good place
|
|
||||||
to put macros that are specific to the HTML version of the
|
|
||||||
document.
|
|
||||||
|
|
||||||
.SH GENERAL MACROS
|
|
||||||
|
|
||||||
tex2page recognizes some commands that are not supplied in
|
|
||||||
the LaTeX or plain-TeX formats -- typically these are
|
|
||||||
commands that add value to the HTML output. In order to keep
|
|
||||||
an input document that uses these extra commands processable
|
|
||||||
by TeX, working TeX definitions are provided in the TeX macro
|
|
||||||
file tex2page.tex and the LaTeX macro package file
|
|
||||||
tex2page.sty. Copy these macro files from the tex2page
|
|
||||||
distribution to a directory in your TEXINPUTS.
|
|
||||||
|
|
||||||
Plain-TeX documents can use
|
|
||||||
|
|
||||||
\einput tex2page
|
|
||||||
|
|
||||||
while LaTeX documents can use
|
|
||||||
|
|
||||||
\eusepackage{tex2page}
|
|
||||||
|
|
||||||
.SH SYSTEM REQUIREMENTS
|
|
||||||
|
|
||||||
tex2page runs on Scheme or Common Lisp. It may also make use
|
|
||||||
of the following programs: BibTeX, MakeIndex, Ghostscript,
|
|
||||||
Dvips, MetaPost, and the NetPBM library.
|
|
||||||
|
|
||||||
Out of the box, tex2page runs in Racket, but the distribution
|
|
||||||
includes configuration information to allow tex2page to run on
|
|
||||||
a variety of Scheme and Common Lisp implementations. See file
|
|
||||||
INSTALL.
|
|
||||||
|
|
||||||
.SH BUGS
|
|
||||||
|
|
||||||
Email to dorai @ ccs.neu.edu.
|
|
||||||
|
|
||||||
.SH SEE ALSO
|
|
||||||
|
|
||||||
tex(1), latex(1), mzscheme(1), bibtex(1), makeindex(1L),
|
|
||||||
mpost(1).
|
|
||||||
|
|
||||||
.SH COPYRIGHT
|
|
||||||
|
|
||||||
Copyright 1997-2012 by Dorai Sitaram.
|
|
||||||
|
|
||||||
Permission to distribute and use this work for any purpose is
|
|
||||||
hereby granted provided this copyright notice is included in
|
|
||||||
the copy. This work is provided as is, with no warranty of any
|
|
||||||
kind.
|
|
||||||
|
|
||||||
.nx
|
|
||||||
Loading…
Reference in New Issue
Block a user