1(module seqcontract mzscheme 2 (require mzlib/class) 3 (provide (protect es-contract-mixin lock-contract-mixin)) 4 5 (require-for-syntax syntax/stx 6 syntax/boundmap) 7 8 (define-syntax (sequence-contract-mixin stx) 9 (syntax-case stx (state-machine) 10 [(_ (state-machine 11 [name exp (method-name aritiess states ...) ...] ...) 12 clauses ...) 13 (and (andmap identifier? (syntax->list (syntax (name ...)))) 14 (andmap (lambda (x) (andmap identifier? (syntax->list x))) 15 (syntax->list (syntax ((method-name ...) ...)))) 16 (andmap (lambda (xs) 17 (andmap (lambda (x) (andmap identifier? (syntax->list x))) 18 (syntax->list xs))) 19 (syntax->list (syntax (((states ...) ...) ...))))) 20 (let () 21 (define state-names (syntax->list (syntax (name ...)))) 22 (define predicate-names (generate-temporaries (syntax (name ...)))) 23 24 (define state-name->predicate-name 25 (let ([mapping (make-bound-identifier-mapping)]) 26 (for-each (lambda (state-name predicate-name) 27 (bound-identifier-mapping-put! mapping state-name predicate-name)) 28 state-names 29 predicate-names) 30 (lambda (state-name) 31 (bound-identifier-mapping-get mapping state-name)))) 32 33 (define-struct state-desc (method-name arities predicate-name state-name result-predicates) (make-inspector)) 34 35 ;; -> mapping[state-name-symbol -o> state-desc] 36 (define (build-table) 37 (let ([mapping (new-mapping)]) 38 (for-each 39 (lambda (state-name-stx predicate-name-stx method-names aritiess state-namess) 40 (for-each 41 (lambda (method-name arities state-names-stx) 42 (extend-mapping/at-end 43 mapping 44 method-name 45 (make-state-desc method-name 46 arities 47 predicate-name-stx 48 state-name-stx 49 (syntax->list state-names-stx)))) 50 (syntax->list method-names) 51 (syntax->list aritiess) 52 (syntax->list state-namess))) 53 (syntax->list (syntax (name ...))) 54 predicate-names 55 (syntax->list (syntax ((method-name ...) ...))) 56 (syntax->list (syntax ((aritiess ...) ...))) 57 (syntax->list (syntax (((states ...) ...) ...)))) 58 mapping)) 59 60 (define (build-overriding-method mapping state-descs) 61 (with-syntax ([method-name (state-desc-method-name (car state-descs))] 62 [super-method-name (build-super-name (state-desc-method-name (car state-descs)))] 63 [(predicate-name ...) (map state-desc-predicate-name state-descs)] 64 [(predicate-result-name ...) 65 (generate-temporaries 66 (map state-desc-predicate-name state-descs))] 67 [(state-name ...) (map state-desc-state-name state-descs)] 68 [((result-predicate-state ...) ...) 69 (map state-desc-result-predicates state-descs)] 70 [((result-predicate-name ...) ...) 71 (map 72 (lambda (state-desc) 73 (map state-name->predicate-name 74 (state-desc-result-predicates state-desc))) 75 state-descs)]) 76 (with-syntax ([(cases ...) 77 (map (lambda (arity) 78 (with-syntax ([formals arity]) 79 (with-syntax ([call (if (identifier? arity) 80 (syntax (super-method-name . formals)) 81 (with-syntax ([(x ...) arity]) 82 (syntax (super-method-name x ...))))] 83 [args-as-list 84 (if (identifier? arity) 85 arity 86 (with-syntax ([(x ...) arity]) 87 (syntax (list x ...))))]) 88 (syntax 89 [formals 90 (let ([predicate-result-name (predicate-name)] ...) 91 (cond 92 [predicate-result-name 93 call 94 95 ;; Doesn't do post-condition checking, 96 ;; since it isn't thread safe 97 #; 98 (begin0 99 call 100 (unless (or (result-predicate-name) ...) 101 (sequence-contract-violation 102 'positive 103 "expected one of states ~s after calling ~s in state ~s" 104 '(result-predicate-state ...) 105 'method-name 106 'state-name))) 107 ] 108 ... 109 [else 110 (sequence-contract-violation 111 'negative 112 "method ~s cannot be called, except in states ~s~a" 113 'method-name 114 '(state-name ...) 115 (format-args args-as-list))]))])))) 116 (syntax->list (state-desc-arities (car state-descs))))]) 117 (syntax 118 (begin 119 (rename-super [super-method-name method-name]) 120 (define/override method-name 121 (case-lambda cases ...))))))) 122 123 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 124 ;; 125 ;; finite mapping code 126 ;; 127 128 (define (new-mapping) (make-hash-table)) 129 (define (set-mapping mapping key-stx val) 130 (hash-table-put! mapping (syntax-e key-stx) val)) 131 (define get-mapping 132 (case-lambda 133 [(mapping key-stx) (get-mapping mapping key-stx (lambda () (error 'get-mapping "ack!")))] 134 [(mapping key-stx fail) 135 (hash-table-get mapping (syntax-e key-stx) fail)])) 136 (define (extend-mapping/at-end mapping key-stx ele) 137 (set-mapping mapping key-stx 138 (append 139 (get-mapping mapping key-stx (lambda () null)) 140 (list ele)))) 141 (define (mapping-map f mapping) 142 (hash-table-map mapping f)) 143 144 ;; 145 ;; 146 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 147 148 (define (build-super-name name) 149 (datum->syntax-object 150 name 151 (string->symbol 152 (format 153 "super-~a" 154 (syntax-object->datum name))))) 155 156 (define table (build-table)) 157 (with-syntax ([(predicate-names ...) predicate-names] 158 [(overriding-method ...) (mapping-map 159 (lambda (k vs) (build-overriding-method table vs)) 160 table)]) 161 162 (syntax 163 (lambda (%) 164 (class* % () 165 (define/private predicate-names (lambda () exp)) ... 166 overriding-method ... 167 clauses ...)))))])) 168 169 (define (format-args l) 170 (cond 171 [(null? l) ""] 172 [else 173 (string-append 174 ", args " 175 (let loop ([fst (car l)] 176 [rst (cdr l)]) 177 (cond 178 [(null? rst) (format "~e" fst)] 179 [else (string-append 180 (format "~e" fst) 181 " " 182 (loop (car rst) (cdr rst)))])))])) 183 184 (define (sequence-contract-violation dir fmt . args) 185 (apply error 186 'sequence-contract-violation 187 (string-append (format "~a: " dir) fmt) 188 args)) 189 190 (define es-contract-mixin 191 (sequence-contract-mixin 192 (state-machine 193 [in-edit-sequence 194 (in-edit-sequence?) 195 (begin-edit-sequence [() (x) (x y)] in-edit-sequence) 196 (end-edit-sequence [()] in-edit-sequence out-of-edit-sequence)] 197 [out-of-edit-sequence 198 (not (in-edit-sequence?)) 199 (begin-edit-sequence [() (x) (x y)] in-edit-sequence)]) 200 201 (inherit in-edit-sequence?) 202 (super-new))) 203 204#| 205 206 (define (test t) 207 (send t begin-edit-sequence) 208 (send t end-edit-sequence) 209 (send t end-edit-sequence)) 210 211 (test (new text%)) 212 (test (new (es-contract-mixin text%))) 213 214Matthew writes: 215 216> Underscore tends to mean "internal". Many variants of 217> Insert(), for example, call the main _Insert() method. 218 219So, double check the methods to make sure that a flag check 220in an underscore method means the flag is checked in the 221non-underscore methods. 222 223At Sun, 29 Jun 2003 09:26:02 -0500, Robby Findler wrote: 224> Is there some kind of invariant or ordering on these 225> flags? That is, if a method only checks the flowLocked flag, 226> is that effectively the same as checking the flowLocked flag 227> or the writeLocked flag or something like that? 228 229Yes: readLocked => flowLocked, and flowLocked => writeLocked. 230 231Matthew 232 233 |# 234 235 ;; need to figure out 236 ;; line-start-position and friends 237 ;; (line-start-position not valid in readlock) 238 239 (define lock-contract-mixin 240 (sequence-contract-mixin 241 (state-machine 242 [unlocked 243 (and (not (locked-for-write?)) 244 (not (locked-for-flow?)) 245 (not (locked-for-read?))) 246 (set-position [(x) (x y) (x y z) (x y z p) (x y z p q) (x y z p q r)] unlocked) 247 (set-autowrap-bitmap [(bitmap)] unlocked) 248 (print-to-dc [(dc) (dc page)] unlocked) 249 (move-position [(code?) (code? extend) (code? extend kind)] unlocked) 250 (split-snip [(pos)] unlocked) 251 (set-line-spacing [(space)] unlocked) 252 (set-max-width [(width)] unlocked) 253 (set-min-width [(width)] unlocked) 254 (set-min-height [(width)] unlocked) 255 (set-max-height [(width)] unlocked) 256 (set-tabs [(tabs) (tabs tab-width) (tabs tab-width units?)] unlocked) 257 (print [() 258 (interactive?) 259 (interactive? fit-on-page?) 260 (interactive? fit-on-page? output-mode) 261 (interactive? fit-on-page? output-mode parent) 262 (interactive? fit-on-page? output-mode parent force-ps-page-bbox?) 263 (interactive? fit-on-page? output-mode parent force-ps-page-bbox? as-eps?)] 264 unlocked) 265 266 (get-text [() (x) (x y) (x y z) (x y z p)] unlocked) 267 (get-flattened-text [()] unlocked) 268 (get-character [(start)] unlocked) 269 (find-wordbreak [(start end reason)] unlocked) 270 (save-file [() (filename) (filename format) (filename format show-errors?)] unlocked) 271 (write-to-file [(stream) (stream start) (stream start end)] unlocked) 272 (find-position [(x y) (x y at-eol?) (x y at-eol? on-it?) (x y at-eol? on-it? edge-close?)] unlocked) 273 (scroll-line-location [(pos)] unlocked) 274 (num-scroll-lines [()] unlocked) 275 (find-scroll-line [(location)] unlocked) 276 (style-has-changed [(style)] unlocked) 277 278 (set-paragraph-margins [(para fl l r)] unlocked) 279 (set-paragraph-alignment [(para align)] unlocked) 280 281 (change-style [(x) (x y) (x y z) (x y z w)] unlocked) 282 (insert [(x) (x y) (x y z) (x y z p) (x y z p q)] unlocked) 283 (delete [() (start) (start end) (start end scroll-ok?)] unlocked) 284 (insert-port [(port) (port format) (port format show-errors?)] unlocked) 285 (read-from-file [(x) (x y) (x y z)] unlocked) 286 (set-style-list [(style-list)] unlocked)] 287 288 [write-lock 289 (and (locked-for-write?) 290 (not (locked-for-flow?)) 291 (not (locked-for-read?))) 292 293 (set-position [(x) (x y) (x y z) (x y z p) (x y z p q)] write-lock) 294 (set-autowrap-bitmap [(bitmap)] write-lock) 295 (print-to-dc [(dc)] write-lock) 296 (move-position [(code?) (code? extend) (code? extend kind)] write-lock) 297 (split-snip [(pos)] write-lock) 298 (set-line-spacing [(space)] write-lock) 299 (set-max-width [(width)] write-lock) 300 (set-min-width [(width)] write-lock) 301 (set-min-height [(width)] write-lock) 302 (set-max-height [(width)] write-lock) 303 (set-tabs [(tabs) (tabs tab-width) (tabs tab-width units?)] write-lock) 304 (print [() 305 (interactive?) 306 (interactive? fit-on-page?) 307 (interactive? fit-on-page? output-mode) 308 (interactive? fit-on-page? output-mode parent) 309 (interactive? fit-on-page? output-mode parent force-ps-page-bbox?)] 310 write-lock) 311 312 (get-text [() (x) (x y) (x y z) (x y z p)] write-lock) 313 (get-flattened-text [()] write-lock) 314 (get-character [(start)] write-lock) 315 (find-wordbreak [(start end reason)] write-lock) 316 (save-file [() (filename) (filename format) (filename format show-errors?)] write-lock) 317 (write-to-file [(stream) (stream start end)] write-lock) 318 (find-position [(x y) (x y at-eol? on-it? edge-close?)] write-lock) 319 (scroll-line-location [(pos)] write-lock) 320 (num-scroll-lines [()] write-lock) 321 (find-scroll-line [(location)] write-lock) 322 (style-has-changed [(style)] write-lock)] 323 324 [flow-lock 325 (and (locked-for-flow?) 326 (not (locked-for-read?))) 327 328 (get-text [() (x) (x y) (x y z) (x y z p)] flow-lock) 329 (get-flattened-text [()] flow-lock) 330 (get-character [(start)] flow-lock) 331 (find-wordbreak [(start end reason)] flow-lock) 332 (save-file [() (filename) (filename format) (filename format show-errors?)] flow-lock) 333 (write-to-file [(stream) (stream start end)] flow-lock) 334 (find-position [(x y) (x y at-eol? on-it? edge-close?)] flow-lock) 335 (scroll-line-location [(pos)] flow-lock) 336 (num-scroll-lines [()] flow-lock) 337 (find-scroll-line [(location)] flow-lock) 338 (style-has-changed [(style)] flow-lock)] 339 340 [read-lock 341 (locked-for-read?)]) 342 343 (inherit locked-for-flow? 344 locked-for-write? 345 locked-for-read?) 346 (super-new)))) 347 348 #| 349 ;; flowLocked in wx_mpriv 350 set-position ; _SetPosition 351 CheckRecalc (only if graphicMaybeInvalid aka locations-computed?) 352 set-autowrap-bitmap ; SetAutowrapBitmap 353 Redraw 354 BeginPrint 355 EndPrint 356 HasPrintPage 357 print-to-dc ; PrintToDC 358 359 ;; flowlocked in wx_media.cxx 360 move-position ; MovePosition 361 split-snip ; SplitSnip 362 set-line-spacing ; SetLineSpacing 363 set-max-width ; SetMaxWidth 364 set-min-width ; SetMinWidth 365 set-min-height ; SetMinHeight 366 set-max-height ; SetMaxHeight 367 set-tabs ; SetTabs 368 resized ; Resized ;; uses the flag, but not to abort 369 370 ;; methods that consider 371 ;; the readLocked variable, 372 ;; at the C level; they just 373 ;; return if it is set. 374 get-text ; GetText 375 get-character ; GetCharacter 376 find-wordbreak ; FindWorkbreak 377 save-file ; SaveFile 378 write-to-file ; WriteToFile 379 _FindPositionInSnip 380 find-position ; FindPosition 381 scroll-line-location ; ScrollLineLocation 382 num-scroll-lines ; NumScrollLines 383 find-scroll-line ; FindScrollLine 384 style-has-changed ; StyleHasChanged ;; maybe need to expand this to include style lists? 385 386 FindFirstVisiblePosition ;; LineStartPosition? 387 FindLastVisiblePosition 388 CheckRecalc 389 390 ;; methods that consider the writeLocked variable, 391 ;; at the C level 392 _ChangeStyle 393 _Insert 394 _Delete 395 insert-port ; InsertPort 396 read-from-file ; ReadFromFile 397 set-style-list ; SetStyleList 398 ; Recounted 399 ReallyCanEdit -- only when op != wxEDIT_COPY 400 401 ;; in wx_mpbrd.cxx 402 insert ; Insert 403 delete ; Delete 404 erase ; Erase 405 delete ; Delete ;; -- with arg 406 remove ; Remove 407 move-to ; MoveTo 408 move ; Move, also with arg 409 change-style ; _ChangeStyle 410 set-before ;SetBefore 411 set-after ;SetAfter 412 ;ReallyCanEdit -- only when op != wxEDIT_COPY 413 ;Refresh has weird code checking writeLocked -- what does < 0 mean? 414 do-paste ; DoPaste 415 paste ; Paste 416 insert-port ; InsertPort 417 insert-file ; InsertFile 418 read-from-file ; ReadFromFile 419 ; BeginEditSequence ;; -- weird flag check 420 ; EndEditSequence ;; -- weird flag check, like BeginEditSequence 421 422 |# 423