1#lang racket/base
2(require "../common/struct-star.rkt"
3         "../common/parameter-like.rkt"
4         "readtable-parameter.rkt")
5
6(provide (struct*-out read-config)
7         (struct-out read-config-state)
8         current-read-config
9         make-read-config
10         read-config-update
11         port+config->srcloc
12         reading-at
13         disable-wrapping
14         keep-comment
15         discard-comment
16         next-readtable)
17
18(struct* read-config (readtable
19                      next-readtable ; readtable to use for recursive reads
20                      for-syntax?   ; impose restrictions on graphs, fxvectors, etc?
21                      source
22                      * wrap          ; wrapper applied to each datum, intended for syntax objects
23                      read-compiled   ; for `#~`: input-port -> any/c
24                      call-with-root-namespace ; around extension callback
25                      dynamic-require ; for reader extensions: module-path sym -> any
26                      module-declared? ; for `#lang`: module-path -> any/c
27                      coerce        ; coerce for syntax or not: any boolean -> any
28                      coerce-key    ; coerce unwrapped key for hash
29                      * line
30                      * col
31                      * pos
32                      * indentations  ; stack of `indentation` records
33                      * keep-comment? ; make main dispatch return on comment
34                      parameter-override ; hash of parameter -> value
35                      parameter-cache   ; hash of parameter -> value
36                      st)) ; other shared mutable state
37
38(struct read-config-state ([accum-str #:mutable] ; string-buffer cache
39                           [graph #:mutable]))   ; #f or hash of number -> value
40
41(define-parameter-like current-read-config #f) ; for `read/recursive`
42
43(define (make-read-config
44         #:source [source #f]
45         #:for-syntax? [for-syntax? #f]
46         #:readtable [readtable (current-readtable)]
47         #:next-readtable [next-readtable readtable]
48         #:wrap [wrap #f #;(lambda (s-exp srcloc) s-exp)]
49         #:read-compiled [read-compiled #f]
50         #:call-with-root-namespace [call-with-root-namespace #f]
51         #:dynamic-require [dynamic-require #f]
52         #:module-declared? [module-declared? #f]
53         #:coerce [coerce #f]
54         #:coerce-key [coerce-key #f]
55         #:keep-comment? [keep-comment? #f])
56  (read-config readtable
57               next-readtable
58               for-syntax?
59               source
60               wrap
61               (or read-compiled
62                   (lambda (in)
63                     (error 'read "no `read-compiled` provided")))
64               (or call-with-root-namespace
65                   (lambda (thunk)
66                     (error 'read "no `call-with-root-namespace` provided")))
67               (or dynamic-require
68                   (lambda (mod-path sym failure-k)
69                     (error 'read "no `dynamic-require` provided")))
70               (or module-declared?
71                   (lambda (mod-path)
72                     (error 'read "no `module-declare?` provided")))
73               (or coerce
74                   (lambda (for-syntax? v srcloc) v))
75               (or coerce-key
76                   (lambda (for-syntax? v) v))
77               #f ; line
78               #f ; col
79               #f ; pos
80               null ; indentations
81               keep-comment?
82               #hasheq()     ; parameter-override
83               (make-hasheq) ; parameter-cache
84               (read-config-state #f    ; accum-str
85                                  #f))) ; graph
86
87(define (read-config-update config
88                            #:for-syntax? for-syntax?
89                            #:wrap wrap
90                            #:readtable readtable
91                            #:next-readtable [next-readtable (read-config-readtable config)]
92                            #:reset-graph? local-graph?
93                            #:keep-comment? keep-comment?)
94  (struct*-copy read-config config
95                [for-syntax? for-syntax?]
96                [wrap wrap]
97                [readtable readtable]
98                [next-readtable next-readtable]
99                [keep-comment? keep-comment?]
100                [st (if local-graph?
101                        (read-config-state #f #f)
102                        (read-config-st config))]
103                [parameter-override #hasheq()]
104                [parameter-cache (make-hasheq)]))
105
106(define (port+config->srcloc in config
107                             #:end-pos [given-end-pos #f])
108  (define end-pos
109    (or given-end-pos
110        (let-values ([(end-line end-col end-pos) (port-next-location in)])
111          end-pos)))
112  (srcloc (or (read-config-source config)
113              (object-name in)
114              "UNKNOWN")
115          (read-config-line config)
116          (read-config-col config)
117          (read-config-pos config)
118          (and (read-config-pos config) end-pos (max 0 (- end-pos (read-config-pos config))))))
119
120(define (reading-at config line col pos)
121  (struct*-copy read-config config
122                [line line]
123                [col col]
124                [pos pos]))
125
126(define (disable-wrapping config)
127  (struct*-copy read-config config
128                [wrap #f]))
129
130(define (keep-comment config)
131  (struct*-copy read-config config
132                [keep-comment? #t]))
133
134(define (discard-comment config)
135  (cond
136   [(not (read-config-keep-comment? config))
137    config]
138   [else
139    (struct*-copy read-config config
140                  [keep-comment? #f])]))
141
142(define (next-readtable config)
143  (cond
144   [(eq? (read-config-readtable config)
145         (read-config-next-readtable config))
146    config]
147   [else
148    (struct*-copy read-config config
149                  [readtable (read-config-next-readtable config)])]))
150