├── gls ├── ref-dyn-patterns.pdf ├── info.rkt ├── main.rkt ├── util-macros.rkt ├── utils.rkt ├── callable-macros.rkt ├── gls.scrbl ├── callables.rkt ├── types.rkt └── test.rkt ├── info.rkt ├── LICENSE └── README.md /gls/ref-dyn-patterns.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Kalimehtar/gls/HEAD/gls/ref-dyn-patterns.pdf -------------------------------------------------------------------------------- /gls/info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | (define name "GLS") 3 | (define scribblings '(("gls.scrbl" () (library)))) 4 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | (define version "0.9") 3 | (define collection 'multi) 4 | (define deps '("base" "srfi-lite-lib" "rackunit-lib" "scribble-lib" "racket-doc")) -------------------------------------------------------------------------------- /gls/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "types.rkt" "callable-macros.rkt" "callables.rkt") 3 | 4 | (provide add-method 5 | replace-method 6 | call-next-method 7 | add-around-method 8 | add-before-method 9 | add-after-method 10 | defgeneric 11 | method 12 | subtype! 13 | and? 14 | or? 15 | compose? 16 | negate? 17 | ==? 18 | *return-value*) 19 | 20 | (subtype! complex? number?) 21 | (subtype! real? complex?) 22 | (subtype! rational? real?) 23 | (subtype! integer? rational?) 24 | (subtype! byte? integer?) 25 | (subtype! null? list?) -------------------------------------------------------------------------------- /gls/util-macros.rkt: -------------------------------------------------------------------------------- 1 | ;; util-macros.scm 2 | #lang racket/base 3 | (provide revlstcps) 4 | ;; reverse list continuation passing style 5 | (define-syntax revlstcps 6 | (syntax-rules () 7 | ((revlstcps (?car . ?cdr) ?out ?next . ?more) 8 | (revlstcps ?cdr (?car . ?out) ?next . ?more)) 9 | ((revlstcps () ?out ?next . ?more) 10 | (?next ?out . ?more)))) 11 | 12 | ;; and convert to a Scheme list (rather than list of tokens) 13 | ;(define-syntax revlstlstcps 14 | ; (syntax-rules () 15 | ; ((revlstlstcps (?car . ?cdr) ?out ?next . ?more) 16 | ; (revlstlstcps ?cdr (?car . ?out) ?next . ?more)) 17 | ; ((revlstlstcps () (?out ...) ?next . ?more) 18 | ; (?next (list ?out ...) . ?more)))) 19 | 20 | ;; eof 21 | -------------------------------------------------------------------------------- /gls/utils.rkt: -------------------------------------------------------------------------------- 1 | ;; Some generally useful functions, IMHO. YMMV. 2 | #lang racket/base 3 | 4 | (provide recur-write-proc dbg assert) 5 | 6 | (define (recur-write-proc mode) 7 | (case mode 8 | [(#t) write] 9 | [(#f) display] 10 | [else (lambda (p port) (print p port mode))])) 11 | 12 | (define (assert test . args) 13 | (if (not test) 14 | (apply error args) 15 | (void))) 16 | 17 | (define *dbg-tags* '()) 18 | 19 | (define (dbg . rest) (void)) 20 | ; (lambda (tag format-string . format-args) 21 | ; (if (memq tag *dbg-tags*) 22 | ; (let ([out (λ (str . args) (display (apply format str args)))]) 23 | ; (out "[dbg:~a:" tag) 24 | ; (apply out format-string format-args) 25 | ; (out ":~a:dbg]~%" tag)) 26 | ; (void)))) 27 | 28 | ;; eof 29 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2014 Kalimehtar 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | gls 2 | === 3 | 4 | GLS - Generic Little (Object, Type, Anything, ...) System 5 | 6 | It provides multiple dispatch for Racket. 7 | 8 | Differences from Swindle: 9 | 10 | - Doesn't force you to change all. GLS is a small collection with a dozen of 11 | functions in API. It only adds generic functions. 12 | 13 | - It based upon types, not classes. You may dispatch you function on any 14 | predicate you may imagine: `exact-integer?`, `(real-in 0 10)`, 15 | `(and? stream? (not/c stream-empty?))`, ... 16 | 17 | GLS is based on Greg Sullivan's GLOS, that was witten for 19 | scheme48. It has the same API, but without implemetation of own object system 20 | (glos-records). So GLS is not "generic little object system", but simply 21 | "generic little system". But I added support for racket/class: you may use 22 | class instead of type predicate and GLS correctly supports subtypes 23 | (subclasses). 24 | 25 | Sorry for bad documentation: for API look into main.rkt, for examples of use 26 | -- test.rkt. 27 | 28 | Some description of GLOS is in the paper ref-dyn-patterns. 30 | 31 | Also, slides in proglangsandsofteng work 32 | through some examples using GLOS. 33 | -------------------------------------------------------------------------------- /gls/callable-macros.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | ;; callable-macros.scm 3 | (require "types.rkt" "callables.rkt" "util-macros.rkt") 4 | (provide defgeneric method) 5 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 6 | ;;; 7 | ;;; CALLABLE-RECORDS 8 | ;;; 9 | 10 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 11 | ;;; 12 | ;;; GENERIC 13 | ;;; 14 | (define-syntax defgeneric 15 | (syntax-rules () 16 | ((defgeneric ?name ?method ...) 17 | (define ?name (make-named-generic '?name ?method ...))))) 18 | 19 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 20 | ;;; 21 | ;;; METHOD 22 | 23 | (define-syntax method 24 | (syntax-rules (=>) 25 | ;; handle result spec., if any 26 | ((method ?argspec => ?resspec ?body ...) ; handle result spec 27 | (method-getargs ?argspec (?body ...) ?resspec #f () ())) 28 | ((method ?argspec ?body ...) ; default result spec is 29 | (method-getargs ?argspec (?body ...) #t #f () ())))) 30 | 31 | ;; not for export 32 | ;; (method-getargs argspecs body result restspec args types) 33 | ;; collect args and types 34 | (define-syntax method-getargs 35 | (syntax-rules (:rest) 36 | ;; handle rest spec, if any 37 | ((method-getargs (:rest (?rest-var ?rest-type)) 38 | ?body ?result ?rest ?args ?types) 39 | (revlstcps ?types () 40 | method-finish ?body ?result (?rest-var ?rest-type) ?args)) 41 | ;; rest var. with no specializer: 42 | ((method-getargs (:rest ?rest-var) ?body ?result ?rest ?args ?types) 43 | (revlstcps ?types () 44 | method-finish ?body ?result (?rest-var #t) ?args)) 45 | ;; arg. with a specializer: 46 | ((method-getargs ((?var1 ?type1) ?var2 ...) ?body ?result 47 | ?rest (?arg ...) (?type ...)) 48 | (method-getargs (?var2 ...) ?body ?result ?rest (?var1 ?arg ...) 49 | (?type1 ?type ...))) 50 | ;; arg with no specializer - defaults to 51 | ((method-getargs (?var1 ?var2 ...) ?body ?result ?rest (?arg ...) (?type ...)) 52 | (method-getargs (?var2 ...) ?body ?result ?rest (?var1 ?arg ...) 53 | (#t ?type ...))) 54 | ;; done with arg.s, no rest 55 | ((method-getargs () ?body ?result ?rest ?args ?types) 56 | (revlstcps ?types () 57 | method-finish ?body ?result ?rest ?args)) 58 | )) 59 | 60 | ;; not exported 61 | ;; (method-finish body result rest/f args types) 62 | (define-syntax method-finish 63 | (syntax-rules () 64 | ;; no rest 65 | ((method-finish (?type ...) ?body ?result #f ?args) 66 | (make-method (make-signature-type #f ?type ...) 67 | ?result 68 | (gen-method-lambda ?args () ?body) 69 | #f)) 70 | ;; types rest 71 | ((method-finish (?type ...) ?body ?result (?rest-var ?rest-type) ?args) 72 | (make-method (make-signature-type ?rest-type ?type ...) 73 | ?result 74 | (gen-method-lambda ?args ?rest-var ?body) 75 | #f)))) 76 | 77 | ;; not exported 78 | ;; reverse the argument list and add rest var, if any 79 | ;; (gen-method-lambda args list body) 80 | (define-syntax gen-method-lambda 81 | (syntax-rules () 82 | ((gen-method-lambda (arg1 arg2 ...) l body) 83 | (gen-method-lambda (arg2 ...) (arg1 . l) body)) 84 | ((gen-method-lambda () l (body ...)) 85 | (lambda l body ...)))) 86 | 87 | ;; eof 88 | -------------------------------------------------------------------------------- /gls/gls.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @(require (for-label racket gls) gls (prefix-in gls: gls/types) scribble/eval) 4 | 5 | @title{GLS: Generic Little System} 6 | @author{@(author+email "Roman Klochkov" "kalimehtar@mail.ru")} 7 | 8 | @defmodule[gls] 9 | 10 | @section{Introduction. Purpose of the library} 11 | 12 | This library allows to make generics on arbitrary predicates. Generic is a function, 13 | that called with different function bodies, depending upon its argument types, and these 14 | bodies may be changed at any time. Classic implementation is 15 | @(hyperlink "https://wikipedia.org/wiki/CLOS" "CLOS"). 16 | 17 | @racket[gls] differs from CLOS (and Swindle): it allows not only classes as dispatching condititons, but 18 | any possible predicates. For example, classic 19 | @(hyperlink "https://en.wikipedia.org/wiki/Circle-ellipse_problem" "circle-ellipse problem") 20 | with @racket[gls] may be solved as 21 | 22 | @(interaction 23 | (require gls) 24 | (struct ellipse (h v) #:mutable) 25 | (define circle? (and? ellipse? (λ (e) (= (ellipse-h e) (ellipse-v e))))) 26 | (define (circle r) (ellipse r r)) 27 | (defgeneric circle-radius 28 | (method ([c circle?]) 29 | (ellipse-h c))) 30 | (defgeneric name 31 | (method ([c circle?]) 32 | "Circle") 33 | (method ([c ellipse?]) 34 | "Ellipse")) 35 | (define c (circle 10)) 36 | (name c) 37 | (circle-radius c) 38 | (set-ellipse-v! c 20) 39 | (name c) 40 | (circle-radius c)) 41 | 42 | So @racket[_c] is a circle only when both axis are equal. 43 | 44 | @section{Base syntax} 45 | 46 | Type may be either predicate (function with one argument, returning @racket[boolean?]), @racket[class?] or 47 | @racket[boolean?]. Type #t means `any type`. Type #f means `type without values`. For @racket[class?] -- 48 | type values -- instances of the class. And for a predicate type values --- all values, on which predicate 49 | returns #t. 50 | 51 | If you use predicates, that defines subtypes, you should explicitly set one type to by 52 | subtype of another type. 53 | 54 | @defproc[(subtype! [subtype gls:predicate?] [supertype gls:predicate?]) void?]{ 55 | Sets @racket[_subtype] to be subtype of @racket[_supertype] for dispatching. 56 | So, if a generic has a method with @racket[_subtype] argument and 57 | a method with @racket[_supertype] argument and both are acceptable for some values, 58 | then the method with @racket[_subtype] argument will be executed. 59 | 60 | Beware, that @racket[subtype!] sets subtypes on values of predicates, not predicate bodies. 61 | So don't put (lambda ...) in it. @racket[lambda] on each call make new procedure 62 | even when called with the same body.} 63 | 64 | @defform*[((method (arg ...) body ...+) 65 | (method (arg ...) => result body ...+)) 66 | #:grammar ([arg 67 | arg-name 68 | (arg-name arg-type)]) 69 | #:contracts ([arg-type gls:type?] 70 | [result gls:type?])]{ 71 | Produces a method for GLS. Method may be used as a procedure, in that case no typecheck is performed. 72 | When used in generic, type of the arguments is used to select correct method. Result type is not used 73 | during dispatching, but is checked on the generic result.} 74 | 75 | @defform[(defgeneric name method ...)]{Defines generic with given name and methods.} 76 | 77 | @(interaction 78 | (require gls) 79 | (define (=1 x) (equal? x 1)) 80 | (code:comment "We cannot do (subtype! (λ (x) (equal? x)) integer?)," ) 81 | (code:comment "because (λ (x) (equal? x)) in") 82 | (code:comment "`subtype!` and in `method` will be different") 83 | (subtype! =1 integer?) 84 | (define default (method ([n =1]) 1)) 85 | (defgeneric fact 86 | default 87 | (method ([n integer?]) 88 | (* (fact (- n 1)) n))) 89 | 90 | (fact 5)) 91 | 92 | @section{Dynamic change methods} 93 | 94 | @defproc[(add-method [generic gls:generic?] [method gls:method?]) any] 95 | 96 | @defproc[(remove-method [generic gls:generic?] [method gls:method?]) any] 97 | 98 | @defproc[(replace-method [generic gls:generic?] [method gls:method?]) any] 99 | 100 | @section{Augmenting methods} 101 | 102 | @defproc[(add-before-method [generic gls:generic?] [method gls:method?]) any] 103 | 104 | @defproc[(remove-before-method [generic gls:generic?] [method gls:method?]) any] 105 | 106 | @defproc[(replace-before-method [generic gls:generic?] [method gls:method?]) any] 107 | 108 | @defproc[(add-after-method [generic gls:generic?] [method gls:method?]) any] 109 | 110 | @defproc[(remove-after-method [generic gls:generic?] [method gls:method?]) any] 111 | 112 | @defproc[(replace-after-method [generic gls:generic?] [method gls:method?]) any] 113 | 114 | @defproc[(add-around-method [generic gls:generic?] [method gls:method?]) any] 115 | 116 | @defproc[(remove-around-method [generic gls:generic?] [method gls:method?]) any] 117 | 118 | @defproc[(replace-around-method [generic gls:generic?] [method gls:method?]) any] 119 | 120 | @section{Combinators} 121 | 122 | @defproc[(and? [type gls:type?] ...) gls:type?] 123 | 124 | @defproc[(or? [type gls:type?] ...) gls:type?] 125 | 126 | @defproc[(compose? [type gls:type?] ...) gls:predicate?] 127 | 128 | @defproc[(==? [value any/c]) gls:predicate?] 129 | 130 | @defproc[(negate? [type gls:type?]) gls:type?] 131 | -------------------------------------------------------------------------------- /gls/callables.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "utils.rkt" 4 | "types.rkt" 5 | racket/function) 6 | (provide make-generic 7 | make-named-generic 8 | add-method 9 | replace-method 10 | call-next-method 11 | add-around-method 12 | add-before-method 13 | add-after-method 14 | *return-value* 15 | standard-method-selector) 16 | ;; callables.scm 17 | ;; Definitions of methods, generics, signatures, and the functions that call them. 18 | 19 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 20 | ;;; 21 | ;;; GENERIC FUNCTIONS 22 | 23 | 24 | (define (make-generic . methods) 25 | (apply make-named-generic "anon" methods)) 26 | 27 | (define (make-named-generic name . methods) 28 | (define gf (really-make-generic name 29 | methods 30 | primary-composer 31 | standard-add-method-check)) 32 | (for ([m (in-list methods)]) 33 | (set-method-generic/f! m gf)) 34 | gf) 35 | 36 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 37 | ;;; 38 | ;;; CALL CONTEXT (reflective interface to dynamic state) 39 | ;;; 40 | 41 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 42 | ;;; 43 | ;;; METHOD COMPOSITION 44 | ;;; 45 | 46 | ;; Choose a single most applicable method, and leave the rest for next-ms 47 | ;; Throw exception if not a single most applicable method. 48 | (define (primary-composer generic app-ms vals) 49 | (if (null? app-ms) 50 | (error 'primary-composer "No applicable method, generic=~a, vals=~a" generic vals) 51 | (let ((mams (standard-method-selector app-ms vals))) 52 | (unless (null? (cdr mams)) 53 | (error 'primary-composer "Ambiguous: ~a on values ~a" mams vals)) 54 | ;; here we know mams is a list of length 1 55 | (call-context 56 | generic 57 | mams ; generic, chain 58 | (remove (car mams) app-ms) ; next 59 | #f 60 | vals ; callable, argvals 61 | (λ () (apply (car mams) vals)))))) ; executor 62 | 63 | (define (sorted-methods app-ms) 64 | (sort app-ms 65 | (λ (m1 m2) 66 | (subtype? (method-args-type m1) 67 | (method-args-type m2))))) 68 | 69 | ;; chain in increasing order 70 | (define (before-composer generic app-ms vals) 71 | (chain-composer generic (reverse (sorted-methods app-ms)) vals)) 72 | 73 | ;; chain in decreasing order 74 | (define (after-composer generic app-ms vals) 75 | (chain-composer generic (sorted-methods app-ms) vals)) 76 | 77 | ;; Composer for a generic with before, after, around, and primary 78 | ;; generic functions. 79 | ;; Note that currently, this is identical to after-composer (!) 80 | ;; but needs to be a separate object because it's used as the tag 81 | ;; to decide if a generic has been "two-leveled". 82 | (define (method-combination-composer . args) 83 | (apply after-composer args)) 84 | 85 | ; TO DO: *** Concern: next-method from last before method should go to primary *** 86 | 87 | (define *return-value* (make-parameter #f)) 88 | 89 | ;; simply execute the applicable methods in order 90 | ;; Note that the fluid variable *return-value* 91 | ;; is bound during execution of an method, if any. 92 | (define (chain-composer generic app-ms vals) 93 | (call-context 94 | generic app-ms ; generic, chain 95 | '() #f vals ; next, callable, args 96 | (lambda () ; executor 97 | (foldl (λ (m-todo return-val) 98 | (if (eq? (method-args-type m-todo)) 99 | (parameterize ([*return-value* return-val]) 100 | (apply m-todo vals) 101 | return-val) 102 | (apply m-todo vals))) 103 | #f 104 | app-ms)))) 105 | 106 | (define (call-next-method) 107 | (define the-context (*call-context*)) 108 | (cond 109 | ;; if we're in the midst of a chain, call next method in chain 110 | ;; ** for now, that means recompose to a new effective fn. ** 111 | [(memq (call-context-callable the-context) 112 | (call-context-chain the-context)) 113 | => (λ (chain-rest) 114 | ;; recompose effective function 115 | (define new-context 116 | ((generic-composer (call-context-generic the-context)) 117 | (call-context-generic the-context) 118 | ;; using rest of chain and all next methods 119 | (append (cdr chain-rest) 120 | (call-context-next the-context)) 121 | (call-context-argvals the-context))) 122 | (parameterize ([*call-context* new-context]) 123 | ((call-context-executor new-context))))] 124 | [else 125 | (error "call-next-method called while not in a chain")])) 126 | 127 | ;; Returns most applicable methods (more than one if ambiguous). 128 | (define (standard-method-selector app-meths vals) 129 | ;; Find most applicable (leaving all others unsorted). 130 | ;; -- uses only the methods' signatures -- not the actual arg.s. 131 | (foldl 132 | ;; mams holds candidates for mam (all elts mutually ambiguous) 133 | (λ (m mams) 134 | (define m-type (method-args-type m)) 135 | ;; Cannot have situation where both m is <= some method m' in mams 136 | ;; AND m is >= some other function m'' in mams -- that would imply that 137 | ;; m' and m'' are comparable and therefore not mutually ambiguous. 138 | ;; Also, better not have case that arg-types(m) = arg-types(m') as that would 139 | ;; be duplicate methods problem. 140 | (cond 141 | ;; if m >= any m' in mams, m is not a mam candidate 142 | [(for/or ([type (in-list (map method-args-type mams))]) 143 | (subtype? type m-type)) 144 | mams] 145 | ;; if m < any m' in mams, replace all such m' with m 146 | [(for/or ([type (in-list (map method-args-type mams))]) 147 | (subtype? m-type type)) 148 | (cons m 149 | (filter (λ (m1) 150 | (not (subtype? 151 | m-type (method-args-type m1)))) 152 | mams))] 153 | ;; otherwise, must be incomparable with all elts of mam, so add m 154 | [else 155 | (cons m mams)])) 156 | (list (car app-meths)) 157 | (cdr app-meths))) 158 | 159 | (define (standard-method-applicable? m vals) 160 | (isa? vals (method-args-type m))) 161 | 162 | ;; errs if duplicate 163 | (define (standard-add-method-check m gf) 164 | (if (findf (λ (m1) 165 | (type-equal? (method-args-type m1) 166 | (method-args-type m))) 167 | (generic-methods gf)) 168 | (error "Adding duplicate method - use replace-method. ~a, ~a" 169 | gf m) 170 | (void))) 171 | 172 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 173 | ;; 174 | ;; METHOD COMBINATION 175 | ;; 176 | 177 | ;; before < primary < after 178 | ;; 179 | (define (const #t)) 180 | (define (and? (const #t))) 181 | (define (and? (const #t))) 182 | 183 | ;; take plain old generic, with only primary methods, and 184 | ;; replace generic-methods with 3 new "methods", before-method, after-method, 185 | ;; and primary-method. Each new method has a generic as its callable, and 186 | ;; each of these generics has a different composer fn. 187 | ;; change composer for original generic to method-combination-composer 188 | (define (make-generic-two-level! gf) 189 | ;; does this generic need to be abstracted to a two-level generic? 190 | (when (not (or (eq? (generic-composer gf) method-combination-composer) 191 | (eq? (generic-composer gf) around-composer))) 192 | ;(format #t "making generic ~a two-level~%" gf) 193 | (let* ((primary-generic 194 | ;; updates method-generic/f ptr.s to new gf 195 | (apply make-named-generic 196 | (format "primary generic for ~a" (generic-name gf)) 197 | (generic-methods gf))) 198 | (primary-method 199 | (make-method #t ; args-type, result-type 200 | primary-generic gf)) ; callable, generic/f 201 | (before-generic 202 | ;; no methods yet 203 | (really-make-generic 204 | (format "before generic for ~a" (generic-name gf)) 205 | '() before-composer ; methods, composer 206 | (const #t))) ; add-method: allow dupes 207 | (before-method 208 | (make-method #t ; args-type, result-type 209 | before-generic gf)) ; callable, generic/f 210 | (after-generic 211 | ;; no methods yet 212 | (really-make-generic 213 | (format "after generic for ~a" (generic-name gf)) 214 | '() after-composer ; methods, composer 215 | (const #t))) ; add-method: allow dupes 216 | (after-method 217 | (make-method #t ; args-type, result-type 218 | after-generic gf))) ; callable, generic/f 219 | (set-generic-methods! gf (list before-method primary-method after-method)) 220 | (set-generic-composer! gf method-combination-composer)))) 221 | 222 | (define (find-hidden-generic gf ref-fn label) 223 | (cond 224 | ((eq? (generic-composer gf) around-composer) 225 | (cond ((findf (λ (m) (eq? (method-args-type m) )) 226 | (generic-methods gf)) 227 | => (lambda (m) (find-hidden-generic (method-callable m) ref-fn label))) 228 | (else 229 | (error 'find-hidden-generic "could not find default around method, finding ~a generic" 230 | label)))) 231 | ((eq? (generic-composer gf) method-combination-composer) 232 | (method-callable (ref-fn (generic-methods gf)))) 233 | (else 234 | (if (eq? label 'primary) 235 | gf 236 | (error 'find-hidden-generic "no ~a - generic not abstracted" label))))) 237 | 238 | (define (before-generic gf) (find-hidden-generic gf car 'before)) 239 | (define (primary-generic gf) (find-hidden-generic gf cadr 'primary)) 240 | (define (after-generic gf) (find-hidden-generic gf caddr 'after)) 241 | 242 | (define (add-method gf m) 243 | (let ((primary-gf (primary-generic gf))) 244 | (when (generic-add-method-check/f primary-gf) 245 | ((generic-add-method-check/f primary-gf) m gf)) 246 | (set-method-generic/f! m primary-gf) 247 | (set-generic-methods! 248 | primary-gf (cons m (generic-methods primary-gf))))) 249 | 250 | (define (add-method* gf . ms) 251 | (for ([m (in-list ms)]) 252 | (add-method gf m))) 253 | 254 | (define (remove-method gf m) 255 | (define sig (method-args-type m)) 256 | (define primary-gf (primary-generic gf)) 257 | (cond 258 | [(findf (λ (m1) 259 | (type-equal? sig (method-args-type m1))) 260 | (generic-methods primary-gf)) 261 | => (λ (m) 262 | (set-generic-methods! 263 | primary-gf 264 | (remove m (generic-methods primary-gf))))] 265 | [else 266 | (error 'remove-primary-method "Could not find method matching ~a for generic ~a" sig gf)])) 267 | 268 | (define (replace-method gf m) 269 | (remove-method gf m) 270 | (add-method gf m)) 271 | 272 | ;; remove-method is synonym for remove-primary-method 273 | 274 | (define (add-before-method gf m) 275 | (make-generic-two-level! gf) 276 | (add-method (before-generic gf) m)) 277 | 278 | (define (remove-before-method gf m) 279 | (remove-method (before-generic gf) m)) 280 | 281 | (define (add-after-method gf m) 282 | (make-generic-two-level! gf) 283 | (add-method (after-generic gf) m)) 284 | 285 | (define (remove-after-method gf m) 286 | (remove-method (after-generic gf) m)) 287 | 288 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 289 | ;; 290 | ;; AROUND METHODS (are special) 291 | ;; 292 | 293 | ;; Choose a single most applicable method, and leave the rest for next-ms 294 | ;; Throw exception if not a single most applicable method. 295 | ;; around-composer is same as primary-composer, but needs separate identity. 296 | (define (around-composer generic app-ms vals) 297 | (if (null? app-ms) 298 | (error 'around-composer "No applicable around method, generic=~a, vals=~a" generic vals) 299 | (let ((mams (standard-method-selector app-ms vals))) 300 | (when (> (length mams) 1) 301 | (error 'around-composer "Ambiguous: ~a on values ~a" mams vals)) 302 | ;; here we know mams is a list of length 1 303 | (call-context 304 | generic mams ; generic, chain 305 | (remove (car mams) app-ms) ; next 306 | #f vals ; callable, argvals 307 | (lambda () (apply (car mams) vals)))))) ; executor 308 | 309 | (define (or? #t (const #t))) ; will be super of just 310 | 311 | ;; take a "two-level" generic and turn it into a three-level generic. 312 | (define (make-generic-arounded! gf) 313 | (make-generic-two-level! gf) 314 | (unless (eq? (generic-composer gf) around-composer) 315 | ;(displayln "making generic aroundable.") 316 | ;; default-around will call before-primary-around methods as usual 317 | (let* ((default-generic ; callable of default around method 318 | (really-make-generic 319 | (format "default around generic for ~a" (generic-name gf)) 320 | (generic-methods gf) 321 | method-combination-composer 322 | standard-add-method-check)) 323 | (default-around-method 324 | (make-method 325 | #t ; args-type, result-type 326 | default-generic gf))) ; callable, generic/f 327 | (set-generic-methods! gf (list default-around-method)) 328 | (set-generic-composer! gf around-composer)))) 329 | 330 | (define (add-around-method gf m) 331 | (make-generic-arounded! gf) 332 | (set-method-generic/f! m gf) 333 | (set-generic-methods! gf (cons m (generic-methods gf)))) 334 | 335 | ;; eof 336 | -------------------------------------------------------------------------------- /gls/types.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "utils.rkt" 3 | racket/function 4 | (prefix-in c: racket/class) 5 | racket/contract) 6 | 7 | (provide (struct-out generic) 8 | (except-out (struct-out method) method) 9 | (struct-out call-context) 10 | (struct-out signature-type) 11 | make-signature-type 12 | subtype? 13 | subtype! 14 | *call-context* 15 | isa? 16 | type-equal? 17 | and? 18 | or? 19 | negate? 20 | compose? 21 | ==? 22 | type? 23 | predicate?) 24 | 25 | (define predicate? (-> any/c boolean?)) 26 | (define type? (or/c boolean? predicate? c:class?)) 27 | 28 | (module+ test 29 | (require rackunit racket/function)) 30 | 31 | ;; TO DO: 32 | ;; * limited list typecheck caching: 33 | ;; Want to cache most specific derived list type informatio about lists. 34 | ;; When a list value passes a list-of or list-with predicate, that fact 35 | ;; should be recorded. Later, when cons, set-car, set-cdr! is done, 36 | ;; the type of the resulting list can be calculated by doing a lub with types 37 | ;; of new value(s). 38 | 39 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 40 | ;; 41 | ;; EQ TYPES 42 | ;; 43 | (struct eq-type (val) 44 | #:constructor-name ==? 45 | #:property prop:procedure 46 | (lambda (type x) 47 | (eq? x (eq-type-val type))) 48 | #:methods gen:custom-write 49 | [(define (write-proc v port mode) 50 | ((recur-write-proc mode) `(== ,(eq-type-val v)) port))]) 51 | 52 | ;(define eq-type?) 53 | 54 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 55 | ;; 56 | ;; AND TYPES 57 | ;; 58 | (struct and-type (types) 59 | #:constructor-name really-make-and-type 60 | #:property prop:procedure 61 | (lambda (type x) 62 | (for/and ([t (in-list (and-type-types type))]) 63 | (isa? x t))) 64 | #:methods gen:custom-write 65 | [(define (write-proc v port mode) 66 | ((recur-write-proc mode) `(and? ,@(and-type-types v)) port))]) 67 | 68 | ;; simple normalization of and-types: 69 | ;; (1) (and x (and y z)) => (and x y z) 70 | ;; (2) (and x y z), (subtype? x y) => (and x z) 71 | ;; (3) (and x) => x 72 | (define (make-and-type . types) 73 | ;; first get flat list of conjuncts (in reverse order) 74 | (define types1 (for/fold ([out null]) 75 | ([type (in-list types)]) 76 | (if (and-type? type) 77 | (append (reverse (and-type-types type)) out) 78 | (cons type out)))) 79 | ;; next see if can merge any conjuncts 80 | (define types2 (for/fold ([out null]) 81 | ([type (in-list types1)]) 82 | (if (or (memq type out) 83 | (for/or ([type1 types1]) 84 | (and (not (eq? type type1)) 85 | (subtype? type1 type)))) 86 | out 87 | (cons type out)))) 88 | (if (null? (cdr types2)) 89 | (car types2) 90 | (really-make-and-type types2))) 91 | 92 | (define and? make-and-type) 93 | 94 | (module+ test 95 | (check-equal? (and? byte? byte?) byte?) 96 | (check-equal? (and? (or? byte? integer?) byte?) byte?)) 97 | 98 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 99 | ;; 100 | ;; OR TYPES 101 | ;; 102 | 103 | (struct or-type (types) 104 | #:constructor-name really-make-or-type 105 | #:property prop:procedure 106 | (lambda (type x) 107 | (for/or ([t (in-list (or-type-types type))]) 108 | (isa? x t))) 109 | #:methods gen:custom-write 110 | [(define (write-proc v port mode) 111 | ((recur-write-proc mode) `(or? ,@(or-type-types v)) port))]) 112 | 113 | ;; simple normalization of or-types: 114 | ;; (1) (or x (or y z)) => (or x y z) 115 | ;; (2) (or x y z), (subtype? x y) => (or y z) 116 | ;; (3) (or x) => x 117 | (define (or? . types) 118 | ;; first get flat list of disjuncts 119 | (define types1 (for/fold ([out null]) 120 | ([type (in-list types)]) 121 | (if (or-type? type) 122 | (append (reverse (or-type-types type)) out) 123 | (cons type out)))) 124 | ;; next see if can merge any disjuncts 125 | (define types2 (for/fold ([out null]) 126 | ([type (in-list types1)]) 127 | (if (or (memq type out) 128 | (for/or ([type1 types1]) 129 | (and (not (eq? type type1)) 130 | (subtype? type type1)))) 131 | out 132 | (cons type out)))) 133 | (if (null? (cdr types2)) 134 | (car types2) 135 | (really-make-or-type types2))) 136 | 137 | (module+ test 138 | (check-equal? (or? byte? byte?) byte?) 139 | (check-equal? (or? (and? byte? integer?) byte?) byte?)) 140 | ;(define or? make-or-type) 141 | 142 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 143 | ;; 144 | ;; COMPOSE TYPES 145 | ;; 146 | 147 | (struct compose-type (types) 148 | #:property prop:procedure 149 | (lambda (type x) 150 | ((apply compose (compose-type-types type)) x)) 151 | #:methods gen:custom-write 152 | [(define (write-proc v port mode) 153 | ((recur-write-proc mode) `(compose? ,@(compose-type-types v)) port))]) 154 | 155 | (define (compose? . types) 156 | (if (cdr types) 157 | (compose-type types) 158 | (car types))) 159 | 160 | (define (compose-subtype? type1 type2) 161 | (define types1 (compose-type-types type1)) 162 | (define types2 (compose-type-types type2)) 163 | (and (equal? (cdr types1) (cdr types1)) 164 | (subtype? (car types1) (car types1)))) 165 | 166 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 167 | ;; 168 | ;; NEGATE TYPES 169 | ;; 170 | 171 | (struct negate-type (type) 172 | #:property prop:procedure 173 | (lambda (type x) 174 | (not (isa? x (negate-type-type type)))) 175 | #:methods gen:custom-write 176 | [(define (write-proc v port mode) 177 | ((recur-write-proc mode) `(negate? ,@(compose-type-types v)) port))]) 178 | 179 | (define (negate? t) 180 | (if (boolean? t) (not t) (negate-type t))) 181 | 182 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 183 | ;; 184 | ;; SIGNATURE-TYPES 185 | ;; 186 | ;; rest-type/f is element type of each remaining element. 187 | ;; - if rest-type/f is #f, must have exactly (length types) elt.s 188 | (struct signature-type (types rest-type/f) 189 | #:constructor-name really-make-signature-type 190 | #:property prop:procedure 191 | (lambda (type val) 192 | (cond [(list? val) 193 | (vals-match-signature? val type)] 194 | [(vector? val) 195 | (vals-match-signature? (vector->list val) type)] 196 | [else #f])) 197 | #:methods gen:custom-write 198 | [(define (write-proc v port mode) 199 | ((recur-write-proc mode) `(signature-type ,(signature-type-types v) ': 200 | ,(signature-type-rest-type/f v)) 201 | port))]) 202 | 203 | (define (make-signature-type rest-type/f . types) 204 | (really-make-signature-type types rest-type/f)) 205 | 206 | ;(define signature-type?) 207 | 208 | ;; *covariant* 209 | ;; true if any (list) value satisfying sig1 will also satisfy sig2 210 | (define (signature-subtype? sig1 sig2) 211 | ;; look at arg-types first 212 | (define rest1 (signature-type-rest-type/f sig1)) 213 | (define rest2 (signature-type-rest-type/f sig2)) 214 | (let loop ([arg-types1 (signature-type-types sig1)] 215 | [arg-types2 (signature-type-types sig2)]) 216 | (cond 217 | [(null? arg-types1) ; done with arg-types1 218 | (and (subtype? rest1 rest2) 219 | (or (null? arg-types2) 220 | ;; more arg-types2 (but done with arg-types1) 221 | (and rest1 222 | (for/and ([type arg-types2]) 223 | (subtype? rest1 type)))))] 224 | [(null? arg-types2) ; more arg1's than arg2's 225 | (and rest2 226 | (for/and ([type arg-types1]) 227 | (subtype? type rest2)))] 228 | [else ; more of both 229 | (and (subtype? (car arg-types1) (car arg-types2)) 230 | (loop (cdr arg-types1) (cdr arg-types2)))]))) 231 | 232 | (define (vals-match-signature? orig-vals sig) 233 | (define arg-types (signature-type-types sig)) 234 | (define rest-type/f (signature-type-rest-type/f sig)) 235 | (define len-vals (length orig-vals)) 236 | (define len-args (length arg-types)) 237 | ;; quick check 1st: 238 | (if (or (< len-vals len-args) 239 | (and (not rest-type/f) 240 | (> len-vals len-args))) 241 | #f 242 | ;; check types 243 | (let loop ([vals orig-vals] 244 | [types arg-types]) 245 | (define in-rest? (null? types)) 246 | (cond 247 | [(null? vals) #t] 248 | [(null? types) 249 | (for/and ([val vals]) 250 | (isa? val rest-type/f))] 251 | [(isa? (car vals) (car types)) 252 | (loop (cdr vals) (cdr types))] 253 | [else #f])))) 254 | 255 | ;; TO DO: make signature-equal? a method 256 | (define (signature-equal? s1 s2) 257 | ;; (method ((s1 ) (s2 )) => 258 | (and (eq? (signature-type-rest-type/f s1) 259 | (signature-type-rest-type/f s2)) 260 | (for/and ([type1 (signature-type-types s1)] 261 | [type2 (signature-type-types s2)]) 262 | (eq? type1 type2)))) 263 | 264 | ;; throw an exception if check fails 265 | ;(define (check-applicable! type args) 266 | ; (if (isa? args type) 267 | ; #t 268 | ; (error (format "ck-app!: args ~a don't satisfy method type ~a" args type)))) 269 | 270 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 271 | ;; 272 | ;; METHOD TYPES 273 | ;; 274 | (struct method-type (args-type result-type) 275 | #:constructor-name really-make-method-type 276 | #:property prop:procedure 277 | (lambda (type val) 278 | (cond [(generic? val) 279 | (for/and ([v (in-list (generic-methods val))]) 280 | (isa? v type))] 281 | [(method? val) 282 | (and 283 | ;; use contravariant comparison of arg-types: 284 | (subtype? (method-type-args-type type) 285 | (method-args-type val)) 286 | ;; and covariant comparison of result-types: 287 | (subtype? (method-result-type val) 288 | (method-type-result-type type)))] 289 | [else #f])) 290 | #:methods gen:custom-write 291 | [(define (write-proc v port mode) 292 | ((recur-write-proc mode) `(method-type ,(method-type-args-type v) -> 293 | ,(method-type-result-type v)) 294 | port))]) 295 | 296 | ;; common case 297 | (define (make-method-type rest-type/f result-type . arg-types) 298 | (really-make-method-type (really-make-signature-type arg-types rest-type/f) 299 | result-type)) 300 | 301 | (define method-type?) 302 | 303 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 304 | ;; 305 | ;; ISA? 306 | ;; 307 | ;(define-syntax (make-selector stx) 308 | ; (syntax-case stx () 309 | ; [(_ selector action mora-actions ...) 310 | ; (with-syntax ([val (datum->syntax stx 'val)] 311 | ; [type (datum->syntax stx 'type)]) 312 | ; #'(cons selector (λ (val type) action mora-actions ...)))])) 313 | 314 | (define (isa? val type) 315 | (cond 316 | [(c:class? type) (c:is-a? val type)] 317 | [(boolean? type) type] 318 | [else (type val)])) 319 | 320 | 321 | (define parents (make-hasheq)) ; type -> listOf type 322 | 323 | (define (subtype! t1 t2) 324 | (hash-set! parents 325 | t1 326 | (cons t2 (hash-ref parents t1 null)))) 327 | 328 | (define (parents-subtype? t1 t2) 329 | (define parent-list (hash-ref parents t1 null)) 330 | (or (if (memq t2 parent-list) #t #f) 331 | (for/or ([parent (in-list parent-list)]) 332 | (parents-subtype? parent t2)))) 333 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 334 | ;; 335 | ;; SUBTYPE? 336 | ;; 337 | ;; true if any instance of t1 can be used in a context requiring a t2 338 | ;; that is, true if for every value v, (isa? v t1) => (isa? v t2) 339 | ;; - note that predicate types are not comparable. 340 | (define (subtype? t1 t2) 341 | (or (cond 342 | [(eq? t1 t2) #t] 343 | [(eq? t2 #t) #t] 344 | [(eq? t1 #f) #t] 345 | ;; (and t1_1 ... t1_n) <= t2 iff 346 | ;; 1. if t2 = (and t2_1 ... t2_m), t1 <= t2_i for all t2_i. 347 | ;; 2. else some t1_i <= t2. 348 | [(and-type? t1) 349 | (if (and-type? t2) 350 | (for/and ([type (in-list (and-type-types t2))]) 351 | (subtype? t1 type)) 352 | (for/or ([type (in-list (and-type-types t1))]) 353 | (subtype? type t2)))] 354 | [(or-type? t1);; (or t1_1 ... t1_n) <= t2 iff all t1_i <= t2 355 | (for/and ([type (in-list (or-type-types t1))]) 356 | (subtype? type t2))] 357 | [(eq-type? t1);; (eq v) <= t2 iff v : t2 or t2 : eq(v) 358 | (or (isa? (eq-type-val t1) t2) 359 | (and (eq-type? t2) (equal? (eq-type-val t1) (eq-type-val t2))))] 360 | [(and-type? t2);; t1 <= (and t2_1 ... t2_n) iff t1 <= t2_i for all i 361 | (for/and ([type (in-list (and-type-types t2))]) 362 | (subtype? t1 type))] 363 | [(or-type? t2);; t1 <= (or t2_1 ... t2_n) iff t1 <= t2_i for some i 364 | (for/or ([type (in-list (or-type-types t2))]) 365 | (subtype? t1 type))] 366 | [(compose-type? t1) 367 | (and (compose-type? t2) 368 | (compose-subtype? t1 t2))] 369 | [(c:class? t2) (c:subclass? t1 t2)] 370 | [(signature-type? t1) 371 | (and 372 | (signature-type? t2) 373 | (signature-subtype? t1 t2))] ; covariant 374 | [(method-type? t1) 375 | (and (method-type? t2) 376 | ;; contravariant in the arg types 377 | (subtype? (method-type-args-type t2) (method-type-args-type t1)) 378 | ;; covariant in result types 379 | (subtype? (method-type-result-type t1) 380 | (method-type-result-type t2)))] 381 | [(and (negate-type? t1) 382 | (negate-type? t2)) 383 | (subtype? (negate-type-type t2) (negate-type-type t1))] 384 | [(parents-subtype? t1 t2)] 385 | [else #f]) 386 | (parents-subtype? t1 t2))) 387 | 388 | ;; TO DO: throw an exception on error 389 | ;; returns val on success 390 | (define (check-type! val type) 391 | (if (or 392 | (eq? type #t) 393 | (isa? val type)) 394 | val 395 | (error 'check-type "check-type! failed: ~a ~a" val type))) 396 | 397 | (define (type-equal? t1 t2) 398 | (define (type-list-equal? types1 types2) 399 | (and 400 | (= (length types1) (length types2)) 401 | (for/and ([type1 types1]) 402 | (for/or ([type2 types2]) 403 | (type-equal? type1 type2))) 404 | (for/and ([type2 types1]) 405 | (for/or ([type1 types2]) 406 | (type-equal? type1 type2))))) 407 | (or (eq? t1 t2) 408 | (and (and-type? t1) 409 | (and-type? t2) 410 | (type-list-equal? (and-type-types t1) (and-type-types t2))) 411 | (and (or-type? t1) ; disjunction 412 | (or-type? t2) 413 | (type-list-equal? (or-type-types t1) (or-type-types t2))) 414 | (and (eq-type? t1) 415 | (eq-type? t2) 416 | (equal? (eq-type-val t1) (eq-type-val t2))) 417 | (and (signature-type? t1) 418 | (signature-type? t2) 419 | (= (length (signature-type-types t1)) (length (signature-type-types t2))) 420 | (for/and ([type1 (in-list (signature-type-types t1))] 421 | [type2 (in-list (signature-type-types t2))]) 422 | (type-equal? type1 type2)) 423 | (type-equal? (signature-type-rest-type/f t1) 424 | (signature-type-rest-type/f t2))) 425 | (and (method-type? t1) 426 | (method-type? t2) 427 | (type-equal? (method-type-args-type t1) (method-type-args-type t2)) 428 | (type-equal? (method-type-result-type t1) (method-type-result-type t2))))) 429 | 430 | (module+ test 431 | (check type-equal? (and? integer? boolean?) (and? integer? boolean?)) 432 | (check type-equal? (and? integer? boolean?) (and? boolean? integer?)) 433 | (check (negate type-equal?) (and? boolean? integer?) (and? boolean?))) 434 | 435 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 436 | ;;; 437 | ;;; GENERIC FUNCTIONS 438 | 439 | (struct generic (name [methods #:mutable] [composer #:mutable] add-method-check/f) 440 | #:constructor-name really-make-generic 441 | #:property prop:procedure 442 | (lambda (real-gf . args) 443 | ;; (1) find applicable methods 444 | (let ((app-ms 445 | (filter (curryr standard-method-applicable? args) 446 | (generic-methods real-gf)))) 447 | ;; (2) compose applicable methods 448 | (let ([context 449 | ((generic-composer real-gf) real-gf app-ms args)]) 450 | ;; (3) initiate new call context 451 | (parameterize ([*call-context* context]) 452 | ((call-context-executor context)))))) 453 | #:methods gen:custom-write 454 | [(define (write-proc v port mode) 455 | ((recur-write-proc mode) `(generic ,(generic-name v)) port))]) 456 | 457 | (struct method (args-type result-type callable [generic/f #:mutable]) 458 | #:constructor-name make-method 459 | #:property prop:procedure 460 | (lambda (real-m . args) 461 | (set-call-context-callable! (*call-context*) real-m) 462 | (check-type! (apply (method-callable real-m) args) 463 | (method-result-type real-m))) 464 | #:methods gen:custom-write 465 | [(define (write-proc v port mode) 466 | ((recur-write-proc mode) `(method ,(method-args-type v) => ,(method-result-type v)) 467 | port))]) 468 | 469 | (define (standard-method-applicable? m vals) 470 | (isa? vals (method-args-type m))) 471 | 472 | (struct call-context (generic 473 | [chain #:mutable] 474 | [next #:mutable] 475 | [callable #:mutable] 476 | argvals 477 | [executor #:mutable])) 478 | 479 | (define *call-context* (make-parameter (call-context #f #f #f #f #f #f))) 480 | -------------------------------------------------------------------------------- /gls/test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "main.rkt" rackunit) 3 | 4 | (define (fact x) 5 | (defgeneric fact0 6 | (method ([n (==? 1)] [acc integer?]) 7 | acc) 8 | (method ([n integer?] [acc integer?]) 9 | (fact0 (- n 1) (* acc n)))) 10 | (fact0 x 1)) 11 | 12 | (check-equal? (fact 5) 120) 13 | 14 | (define m1 15 | (method ((i integer?)) 16 | (format "m1(~a)" i))) 17 | 18 | (define m2 19 | (method ([i integer?] [s string?]) 20 | (format "m2, i=~a, s=~a" i s))) 21 | 22 | (check-equal? (m1 2) "m1(2)") 23 | 24 | (defgeneric g1 25 | m1 26 | (method ((n number?)) 27 | (format "g1(~a)" n)) 28 | (method ((s string?)) 29 | (format "g1string?(~a)" s))) 30 | 31 | (check-equal? (g1 "hi") "g1string?(hi)") 32 | (check-equal? (g1 2) "m1(2)") 33 | (check-equal? (g1 2.1) "g1(2.1)") 34 | 35 | (add-method g1 36 | (method ((x (and? integer? even?))) 37 | (displayln (format "g1 on even int, (~a)" x)) 38 | (call-next-method))) 39 | 40 | (replace-method g1 41 | (method ((i integer?)) 42 | (displayln (format "new g1(~a)" i)) 43 | (call-next-method))) 44 | 45 | (check-equal? (g1 "hi") "g1string?(hi)") 46 | (let ([res #f]) 47 | (define output (with-output-to-string 48 | (λ () (set! res (g1 3))))) 49 | (check-equal? res "g1(3)") 50 | (check-equal? output "new g1(3)\n")) 51 | 52 | (define bm1 (method (x) 53 | (displayln (format "in bm1, got ~a" x)))) 54 | 55 | (define bm2 (method ([x integer?]) 56 | (displayln (format "in bm2 , got ~a" x)))) 57 | 58 | (add-before-method g1 bm1) 59 | (add-before-method g1 bm2) 60 | 61 | (let ([res #f]) 62 | (define output (with-output-to-string 63 | (λ () (set! res (g1 "hi"))))) 64 | (check-equal? res "g1string?(hi)") 65 | (check-equal? output "in bm1, got hi\n")) 66 | 67 | (let ([res #f]) 68 | (define output (with-output-to-string 69 | (λ () (set! res (g1 3))))) 70 | (check-equal? res "g1(3)") 71 | (check-equal? output 72 | (string-join (list "in bm1, got 3" 73 | "in bm2 , got 3" 74 | "new g1(3)" 75 | "") 76 | "\n"))) 77 | 78 | (add-after-method g1 79 | (method ((x string?)) 80 | (displayln (format "in after method on string?, retval=~a" 81 | (*return-value*))))) 82 | 83 | (check-equal? (with-output-to-string (λ () (g1 "hi"))) 84 | (string-join (list "in bm1, got hi" 85 | "in after method on string?, retval=g1string?(hi)" 86 | "") 87 | "\n")) 88 | 89 | (add-around-method g1 90 | (method ((x string?)) 91 | (displayln (format "in around method on string?, calling next method")) 92 | (let ((val (call-next-method))) 93 | (displayln (format "back in around method on string?, got ~a" val)) 94 | val))) 95 | 96 | (check-equal? (with-output-to-string (λ () (g1 "hi"))) 97 | (string-join (list "in around method on string?, calling next method" 98 | "in bm1, got hi" 99 | "in after method on string?, retval=g1string?(hi)" 100 | "back in around method on string?, got g1string?(hi)" 101 | "") 102 | "\n")) 103 | ;;;; IMPORTANT: following examples are copied from original version of GLOS 104 | ;;;; in GLS there are no defrectype, you may use racket/class classes instead 105 | 106 | #| 107 | 108 | (add-after-method 109 | g1 (method ((x string?)) 110 | (cl-format #t "in after method on string?, retval=~a~%" 111 | (fluid *return-value*)))) 112 | 113 | (g1 "hi") 114 | (g1 3) 115 | 116 | (add-after-method 117 | g1 (method (x) 118 | (cl-format #t "in after method on ~%"))) 119 | 120 | (g1 "hi") 121 | 122 | (defgeneric fact 123 | (method ((n (and? (== 1)))) 124 | 1) 125 | (method ((n )) 126 | (* n (fact (- n 1))))) 127 | 128 | ;; following gets ambiguous error 129 | (defgeneric bad-fact 130 | (method ((n (curry = 1))) 131 | 1) 132 | (method ((n )) 133 | (* n (bad-fact (- n 1))))) 134 | 135 | 136 | (add-around-method 137 | g1 138 | (method ((x )) 139 | (cl-format #t "in around method on , calling next-method~%") 140 | (call-next-method))) 141 | 142 | (add-around-method 143 | g1 144 | (method ((x )) 145 | (cl-format #t "in around method on , returning 'foo~%") 146 | 'foo)) 147 | 148 | (add-around-method 149 | g1 150 | (method ((x )) 151 | (cl-format #t "in around method on , returning 'bar~%") 152 | 'bar)) 153 | 154 | (add-around-method 155 | g1 156 | (method ((x )) 157 | (cl-format #t "in around method on , calling next method~%") 158 | (let ((val (call-next-method))) 159 | (cl-format #t "back in around method on , got ~a~%" val) 160 | val))) 161 | 162 | ;; how to do cflow with fluid bindings and around methods. 163 | ;; (cflow? foo) 164 | (defgeneric bar) 165 | (defgeneric foo 166 | (method ((x )) 167 | (cl-format #t "foo on int ~%") 168 | (bar x)) 169 | (method ((x )) 170 | (cl-format #t "foo on string ~%") 171 | (bar x))) 172 | 173 | (define *in-foo?* (make-fluid #f)) 174 | (add-around-method 175 | foo (make-method "around foo" #f 176 | (lambda args 177 | (let-fluid *in-foo?* #t 178 | (lambda () 179 | (call-next-method)))) #f)) 180 | 181 | (gfmethod (bar (x (and? (fluid *in-foo?*)))) 182 | (cl-format #t "in bar, in cflow of foo~%")) 183 | (gfmethod (bar (x )) 184 | (cl-format #t "in bar, not in cflow of foo~%")) 185 | 186 | (bar 3) 187 | (foo 3) 188 | 189 | 190 | (defrectype () 191 | ((data)) 192 | (data node-data set-node-data!)) 193 | (defrectype () 194 | ((left-child ) 195 | (right-child )) 196 | (left-child node-left-child) 197 | (right-child node-right-child)) 198 | (defrectype () 199 | ()) 200 | 201 | (define ln1 (new 'ln1)) 202 | (define ln2 (new 'ln2)) 203 | (define in1 (new 'in1 ln1 ln2)) 204 | 205 | (defgeneric walk-node 206 | (method ((n )) 207 | (cl-format #t "leaf node ~a~%" (node-data n))) 208 | (method ((n )) 209 | (cl-format #t "interior node ~a~%" (node-data n)) 210 | (walk-node (node-left-child n)) 211 | (walk-node (node-right-child n)))) 212 | 213 | (defrectype () 214 | ((head) 215 | (tail (false-or ))) 216 | (head head set-head!) 217 | (tail tail set-tail!)) 218 | (gfmethod (initialize (obj ) x (y (false-or ))) 219 | (set-by-name* obj 'head x 'tail y)) 220 | (define p1 (new 'e1 (new 'e2 (new 'e3 #f)))) 221 | 222 | (head p1) 223 | (head (tail p1)) ;; => 'e2 224 | (head (tail (tail p1))) 225 | 226 | (defrectype () 227 | ((x ) 228 | (y )) 229 | (x get-x set-x!) 230 | (y get-y set-y!)) 231 | 232 | (set! p1 (new 'x 1 'y 2)) 233 | (define p2 ((glos-record-type-constructor ))) 234 | 235 | (get-x p1) 236 | (set-x! p1 3) 237 | (get-x p1) 238 | 239 | (defrectype () 240 | ((color string? "black")) 241 | (color get-color set-color!)) 242 | 243 | (define cp1 (new 'x 4 'y 5)) 244 | (get-color cp1) 245 | (set-color! cp1 "red") 246 | (get-color cp1) 247 | 248 | (defgeneric describe 249 | (method ((o )) 250 | `(point ,(get-x o) ,(get-y o))) 251 | (method ((o )) 252 | `(colorpoint ,(get-x o) ,(get-y o) ,(get-color o)))) 253 | 254 | (describe p1) 255 | (describe cp1) 256 | 257 | (defgeneric move 258 | (method ((p ) (x ) (y )) 259 | (set-x! p x) 260 | (set-y! p y))) 261 | 262 | (add-before-method 263 | move (method ((p ) (x ) (y )) 264 | (cl-format #t "before move colorpoint (~a, ~a)~%" x y))) 265 | 266 | (add-after-method 267 | move (method ((p ) (x ) (y )) 268 | (cl-format #t "after move point (~a, ~a)~%" x y))) 269 | 270 | (move p1 2 3) 271 | (move cp1 2 3) 272 | 273 | (define cp2 (new 4 5)) 274 | 275 | (add-before-method 276 | move (method ((p (== cp2)) x y) 277 | (cl-format #t "before move == cp2~%"))) 278 | 279 | (move p1 2 3) 280 | (move cp1 1 2) 281 | (move cp2 2 2) 282 | 283 | (add-after-method 284 | move (method ((p ) (x (and? even?)) (y )) 285 | (cl-format #t "after move cp to even x~%"))) 286 | 287 | (defgeneric g2 288 | (method ((o )) 289 | (cl-format #t "g1 on number~%")) 290 | (method ((o )) 291 | (cl-format #t "g1 on integer~%") 292 | (call-next-method))) 293 | (g2 2) 294 | 295 | (defrectype () 296 | ((x ) 297 | (y 0)) 298 | (x get-x set-x!) 299 | (y get-y set-y!)) 300 | 301 | (add-after-method 302 | new 303 | (method ((class (== )) :rest rest) 304 | (cl-format #t "in after new ~%") 305 | (set-y! (fluid *return-value*) 306 | (+ 1 (get-x (fluid *return-value*)))))) 307 | 308 | (define c1 (new 2)) 309 | 310 | (get-y c1) 311 | 312 | (remove-after-method new (make-signature-type (== ))) 313 | 314 | ;; Abstract Factory pattern 315 | (defrectype () ()) 316 | (defrectype () ()) 317 | (defrectype () 318 | ((number )) 319 | (number room-number set-room-number!)) 320 | (defrectype () 321 | ((from ) 322 | (to )) 323 | (from door-from set-door-from!) 324 | (to door-to set-door-to!)) 325 | 326 | (defrectype () ()) 327 | 328 | (defgeneric make-maze-element 329 | (method ((f ) (eltType (== ))) => 330 | (new )) 331 | (method ((f ) (eltType (== )) :rest args) => 332 | (apply new args)) 333 | (method ((f ) (eltType (== )) :rest args) => 334 | (apply new args))) 335 | 336 | (define the-factory (new )) 337 | (define room1 (make-maze-element the-factory 'number 1)) 338 | (define room2 (make-maze-element the-factory 'number 2)) 339 | (define door1 (make-maze-element the-factory 'from room1 'to room2)) 340 | 341 | 342 | (make-maze-element the-factory ) ;; =$>$ an instance of $<$wall$>$ 343 | 344 | (define m1 (new )) 345 | (define w1 (new )) 346 | (define r1 (new 1)) 347 | (define r2 (new 2)) 348 | (define d1 (new r1 r2)) 349 | 350 | 351 | 352 | ;; Factory Method pattern 353 | (defrectype () ()) 354 | (defrectype () 355 | ((n )) 356 | (n get-n set-n!)) 357 | (defrectype () ()) 358 | (defrectype () ()) 359 | (gfmethod (initialize (o ) (n )) 360 | (set-n! o n)) 361 | (gfmethod (make (c (== ))) 362 | (make )) 363 | (gfmethod (make (c (== )) (n )) 364 | (make n)) 365 | 366 | (defgeneric show 367 | (method ((o )) (cl-format #t "~%")) 368 | (method ((o )) (cl-format #t " ~a~%" (get-n o))) 369 | (method ((o )) (cl-format #t "~%")) 370 | (method ((o ))(cl-format #t " ~a~%" (get-n o)))) 371 | 372 | (show (new )) 373 | (show (new 3)) 374 | 375 | ;; Composite pattern 376 | (defrectype () 377 | ((name ) 378 | (price)) 379 | (name equipment-name set-equipment-name!) 380 | (price equipment-price set-equipment-price!)) 381 | 382 | (defgeneric power) 383 | (defgeneric net-price) 384 | 385 | (defrectype () 386 | ((parts )) 387 | (parts composite-parts set-composite-parts!)) 388 | 389 | (defrectype () ()) 390 | (defrectype () ()) 391 | 392 | (gfmethod (net-price (e )) 393 | (equipment-price e)) 394 | 395 | (gfmethod (net-price (e )) 396 | (fold (lambda (item total) 397 | (+ total (net-price item))) 398 | (equipment-price e) 399 | (composite-parts e))) 400 | 401 | (defrectype () ()) 402 | 403 | (define f1 (new 'name 'floppy1 'price 2)) 404 | (define f2 (new 'name 'floppy2 'price 3)) 405 | (set! c1 (new 'name 'chassis1 'price 1 406 | 'parts (list f1 f2))) 407 | 408 | (net-price c1) 409 | 410 | 411 | ;; Decorator pattern 412 | ;; direct translation: 413 | (defrectype () ()) 414 | 415 | (defrectype () 416 | ((contents )) 417 | (contents decorator-component set-decorator-component!)) 418 | 419 | (gfmethod (initialize (obj ) (comp )) 420 | (set-decorator-component! obj comp)) 421 | 422 | (defrectype () ()) 423 | 424 | (defrectype () 425 | ((component )) 426 | (component window-contents set-window-contents!)) 427 | 428 | (defmethod (draw-border w) 429 | (cl-format #t "drawing border of width ~a~%" w)) 430 | 431 | (defmethod (draw-scroll-bar) 432 | (cl-format #t "drawing scrollbar~%")) 433 | 434 | (defgeneric draw 435 | (method ((comp )) 436 | (cl-format #t "drawing ~%")) 437 | (method ((w )) 438 | (draw (window-contents w))) 439 | (method ((c )) 440 | (cl-format #t "drawing ~%"))) 441 | 442 | (gfmethod (draw (comp )) 443 | (draw (decorator-component comp))) 444 | 445 | (defrectype () 446 | ((width )) 447 | (width border-width set-border-width!)) 448 | 449 | (gfmethod (initialize (obj ) 450 | (comp ) (width )) 451 | (initialize obj comp) 452 | (set-border-width! obj width)) 453 | 454 | (gfmethod (draw (comp )) 455 | (call-next-method) ;; eventually, draw component 456 | (draw-border (border-width comp))) 457 | 458 | (defrectype () ()) 459 | 460 | (gfmethod (draw (comp )) 461 | (call-next-method) ;; eventually, draw component 462 | (draw-scroll-bar)) 463 | 464 | (set! w1 (new )) 465 | (define tv1 (new )) 466 | (set-window-contents! 467 | w1 (new 468 | (new tv1) 3)) 469 | 470 | (draw w1) 471 | 472 | ;; Decorator pattern using method combination 473 | (defrectype () ()) 474 | (defrectype () 475 | ((contents )) 476 | (contents window-contents set-window-contents!)) 477 | (defrectype () ()) 478 | (defmethod (draw-border w) 479 | (cl-format #t "drawing border of width ~a~%" w)) 480 | 481 | (defmethod (draw-scroll-bar) 482 | (cl-format #t "drawing scrollbar~%")) 483 | (defgeneric draw 484 | (method ((comp )) 485 | (cl-format #t "drawing ~%")) 486 | (method ((w )) 487 | (draw (window-contents w))) 488 | (method ((c )) 489 | (cl-format #t "drawing ~%"))) 490 | 491 | (defrectype () 492 | ((width )) 493 | (width border-width set-border-width!)) 494 | 495 | (gfmethod (draw (comp )) 496 | (draw-border (border-width comp))) 497 | 498 | (defrectype () ()) 499 | 500 | (gfmethod (draw (comp )) 501 | (draw-scroll-bar)) 502 | 503 | (defmethod (decorate (component ) 504 | (decoration )) 505 | (add-after-method draw 506 | (method ((c (== component))) 507 | (draw decoration)))) 508 | 509 | (set! tv1 (new )) 510 | (set! w1 (new 'contents tv1)) 511 | (decorate tv1 (new )) 512 | (decorate tv1 (new 'width 4)) 513 | (draw w1) 514 | 515 | 516 | ;; Flyweight pattern - factory component 517 | (defrectype () 518 | ((char )) 519 | (char get-char set-char!)) 520 | 521 | (gfmethod (initialize (obj ) (char )) 522 | (set-char! obj char)) 523 | (let ((char-table (make-integer-table))) 524 | (gfmethod 525 | (make (class (== )) (char )) 526 | (let ((char-int (char->integer char))) 527 | (cond ((table-ref char-table char-int) => identity) 528 | (else 529 | (let ((new-char (call-next-method))) 530 | (table-set! char-table char-int new-char) 531 | new-char)))))) 532 | 533 | (set! c1 (new #\a)) 534 | (set! c2 (new #\a)) 535 | (eq? c1 c2) 536 | 537 | (defrectype () 538 | ((char )) 539 | (char get-char set-char!)) 540 | (gfmethod (initialize (obj ) (char )) 541 | (set-char! obj char)) 542 | 543 | ;; Proxy pattern 544 | 545 | (defmethod (bits-from-file (fn )) 546 | (cl-format #t "Reading bits from file ~a~%" fn) 547 | 'some-bits) 548 | 549 | (defrectype () ()) 550 | ;; is imported from elsewhere 551 | (defrectype () 552 | ((bits)) 553 | (bits image-bits set-image-bits!)) 554 | (gfmethod (initialize (obj ) (fn )) 555 | (set-image-bits! obj (bits-from-file fn))) 556 | (defgeneric draw 557 | (method ((i )) 558 | (let ((bits (image-bits i))) 559 | (cl-format #t "Drawing image bits ~a~%" bits)))) 560 | 561 | ;; following is proxy code 562 | (defrectype () 563 | ((filename ) 564 | (empty? #t)) 565 | (filename image-proxy-filename 566 | set-image-proxy-filename!) 567 | (empty? image-proxy-empty? set-image-proxy-empty?!)) 568 | ;; hijack instantiation of superclass 569 | (gfmethod (make (class (== )) :rest args) 570 | (make )) 571 | (gfmethod (initialize (obj ) (fn )) 572 | (set-image-proxy-filename! obj fn)) 573 | (add-before-method 574 | image-bits 575 | (method ((obj )) 576 | (if (image-proxy-empty? obj) 577 | (begin 578 | (set-image-bits! obj 579 | (bits-from-file (image-proxy-filename obj))) 580 | (set-image-proxy-empty?! obj #f))))) 581 | (defrectype () 582 | ((elts '())) 583 | (elts text-document-elements 584 | set-text-document-elements!)) 585 | (defgeneric insert 586 | (method ((into ) (obj )) 587 | (set-text-document-elements! 588 | into (cons obj (text-document-elements into))))) 589 | (defgeneric display 590 | (method ((obj )) 591 | (for-each (lambda (elt) (draw elt)) 592 | (text-document-elements obj)))) 593 | 594 | (define td1 (new )) 595 | (insert td1 (new "image.gif")) 596 | (display td1) ; reads and draws 597 | (display td1) ; just draws 598 | 599 | 600 | ;; Chain of Responsibility pattern 601 | 602 | (defrectype () 603 | ((text)) 604 | (text topic-text set-topic-text!)) 605 | (gfmethod (initialize (obj ) text) 606 | (set-topic-text! obj text)) 607 | (defgeneric display-topic 608 | (method ((t )) 609 | (cl-format #t "Topic: ~a~%" (topic-text t)))) 610 | 611 | (defrectype () 612 | ((topic (false-or ) #f) 613 | (next (false-or ) #f)) 614 | (topic handler-topic set-handler-topic!) 615 | (next handler-next set-handler-next!)) 616 | 617 | (defgeneric handle-help 618 | (method ((handler )) 619 | (cond 620 | ((handler-topic handler) 621 | => display-topic) 622 | ((handler-next handler) 623 | => handle-help) 624 | (else 625 | (cl-format #t "No topic found.~%"))))) 626 | 627 | ;; widgets 628 | (defrectype () 629 | ((parent (false-or ) #f)) 630 | (parent widget-parent set-widget-parent!)) 631 | ;; handle new widget with only a parent handler, not a parent widget: 632 | (gfmethod (initialize (newobj ) (parent-handler (false-or )) 633 | (topic (false-or ))) 634 | (set-handler-next! newobj parent-handler) 635 | (set-handler-topic! newobj topic)) 636 | (gfmethod (initialize (newobj ) (parent-widget (false-or )) 637 | (topic (false-or ))) 638 | (set-widget-parent! newobj parent-widget) 639 | (set-handler-next! newobj parent-widget) 640 | (set-handler-topic! newobj topic)) 641 | (defrectype