Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

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
  • Loading branch information...
commit b33509bc0d1e4ea923b88cb73af433fb4ed07307 1 parent 05b8893
@takikawa takikawa authored
Showing with 2 additions and 13,647 deletions.
  1. +0 −11 collects/combinator-parser/combinator-unit.rkt
  2. +0 −133 collects/combinator-parser/doc.txt
  3. +0 −63 collects/combinator-parser/examples/combinator-example.rkt
  4. +0 −3  collects/combinator-parser/info.rkt
  5. +0 −217 collects/combinator-parser/private-combinator/combinator-parser.scm
  6. +0 −932 collects/combinator-parser/private-combinator/combinator.scm
  7. +0 −353 collects/combinator-parser/private-combinator/errors.scm
  8. +0 −199 collects/combinator-parser/private-combinator/parser-sigs.rkt
  9. +0 −125 collects/combinator-parser/private-combinator/structs.scm
  10. +2 −9 collects/meta/dist-specs.rkt
  11. +0 −4 collects/meta/props
  12. +0 −8 collects/test-box-recovery/info.rkt
  13. +0 −19 collects/test-box-recovery/test-box-recovery.scrbl
  14. +0 −108 collects/test-box-recovery/tool.rkt
  15. +0 −4 collects/tex2page/info.rkt
  16. +0 −4 collects/tex2page/main.rkt
  17. +0 −12 collects/tex2page/start.rkt
  18. +0 −10,010 collects/tex2page/tex2page-aux.rkt
  19. +0 −12 collects/tex2page/tex2page.rkt
  20. +0 −9 collects/tex2page/tex2page.sty
  21. +0 −1,238 collects/tex2page/tex2page.tex
  22. +0 −174 man/man1/tex2page.1
View
11 collects/combinator-parser/combinator-unit.rkt
@@ -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)
-
- )
View
133 collects/combinator-parser/doc.txt
@@ -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
View
63 collects/combinator-parser/examples/combinator-example.rkt
@@ -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))
- )
-
- )
View
3  collects/combinator-parser/info.rkt
@@ -1,3 +0,0 @@
-#lang setup/infotab
-
-(define compile-omit-paths '("examples"))
View
217 collects/combinator-parser/private-combinator/combinator-parser.scm
@@ -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^))
-
- )
View
932 collects/combinator-parser/private-combinator/combinator.scm
@@ -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*))
-
- )
- )
View
353 collects/combinator-parser/private-combinator/errors.scm
@@ -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))])))
-
- )
- )
View
199 collects/combinator-parser/private-combinator/parser-sigs.rkt
@@ -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))
-
- )
View
125 collects/combinator-parser/private-combinator/structs.scm
@@ -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))
-
-)
View
11 collects/meta/dist-specs.rkt
@@ -543,9 +543,8 @@ mz-extras :+= (collects: "ffi/") (doc: "objc")
;; -------------------- preprocessor
mz-extras :+= (package: "preprocessor/") (bin: "mzpp" "mztext")
-;; -------------------- tex2page & slatex
-plt-extras :+= (package: "tex2page")
- (package: "slatex")
+;; -------------------- slatex
+plt-extras :+= (package: "slatex")
(bin: "PDF SLaTeX")
(doc+src: "slatex-wrap/")
@@ -588,9 +587,6 @@ plt-extras :+= (package: "macro-debugger")
;; -------------------- lazy
plt-extras :+= (package: "lazy")
-;; -------------------- combinator-parser
-plt-extras :+= (collects: "combinator-parser")
-
;; -------------------- icons, images
dr-extras :+= (collects: "icons/*.{jpg|png|gif|bmp|xbm|xpm}")
dr-extras :+= (package: "images/")
@@ -666,9 +662,6 @@ plt-extras :+= (- (+ (dll: "myssink")
(package: "mysterx"))
(cond (not win) => (src: "")))
-;; -------------------- temporary tool for converting old files
-plt-extras :+= (package: "test-box-recovery")
-
;; -------------------- redex
plt-extras :+= (package: "redex")
View
4 collects/meta/props
@@ -665,7 +665,6 @@ path/s is either such a string or a list of them.
"collects/algol60" responsible (mflatt robby)
"collects/at-exp" responsible (eli mflatt)
"collects/browser" responsible (robby)
-"collects/combinator-parser" responsible (kathyg)
"collects/compiler" responsible (mflatt)
"collects/compiler/commands/ctool.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/deinprogramm" responsible (sperber)
"collects/teachpack/htdp/graphing.ss" drdr:command-line (mzc *)
-"collects/test-box-recovery" responsible (mflatt)
"collects/test-engine" responsible (kathyg)
"collects/tests/algol60" responsible (mflatt robby)
"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/zo-path.rkt" responsible (mflatt)
"collects/tests/zo-size.rkt" responsible (jay)
-"collects/tex2page" responsible (jay)
"collects/texpict" responsible (mflatt robby)
"collects/texpict/face-demo.rkt" drdr:command-line (mzc *)
"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/raco.1" responsible (mflatt)
"man/man1/setup-plt.1" responsible (mflatt)
-"man/man1/tex2page.1" responsible (jay)
"src" responsible (mflatt)
"src/foreign" responsible (eli)
View
8 collects/test-box-recovery/info.rkt
@@ -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))))
View
19 collects/test-box-recovery/test-box-recovery.scrbl
@@ -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.
View
108 collects/test-box-recovery/tool.rkt
@@ -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)))))
-
View
4 collects/tex2page/info.rkt
@@ -1,4 +0,0 @@
-#lang setup/infotab
-
-(define mzscheme-launcher-libraries (list "start.rkt"))
-(define mzscheme-launcher-names (list "tex2page"))
View
4 collects/tex2page/main.rkt
@@ -1,4 +0,0 @@
-#lang scheme/base
-
-(require "tex2page.rkt")
-(provide (all-from-out "tex2page.rkt"))
View
12 collects/tex2page/start.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)]))
View
10,010 collects/tex2page/tex2page-aux.rkt
0 additions, 10,010 deletions not shown
View
12 collects/tex2page/tex2page.rkt
@@ -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)))))
View
9 collects/tex2page/tex2page.sty
@@ -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}
-
View
1,238 collects/tex2page/tex2page.tex
@@ -1,1238 +0,0 @@
-% tex2page.tex
-% Dorai Sitaram
-
-% TeX files using these macros
-% can be converted by the program
-% tex2page into HTML
-
-\ifx\shipout\UnDeFiNeD\endinput\fi
-
-\message{version 2008-03-02} % last change
-
-\let\texonly\relax
-\let\endtexonly\relax
-
-<