variant.hl.rkt (5574B)
1 #lang hyper-literate typed/racket/base #:no-require-lang #:no-auto-require 2 @(require scribble-enhanced/doc) 3 @doc-lib-setup 4 5 @require[racket/require 6 @for-label[(subtract-in typed/racket/base type-expander) 7 racket/list 8 syntax/parse 9 syntax/parse/experimental/template 10 (subtract-in racket/syntax phc-toolkit) 11 phc-toolkit/untyped-only 12 type-expander/expander 13 phc-toolkit 14 multi-id 15 type-expander 16 "constructor.hl.rkt" 17 "structure.hl.rkt"]] 18 19 @title[#:style manual-doc-style 20 #:tag "variant" 21 #:tag-prefix "phc-adt/variant"]{User API for variants} 22 23 @(chunks-toc-prefix 24 '("(lib phc-adt/scribblings/phc-adt-implementation.scrbl)" 25 "phc-adt/variant")) 26 27 @(table-of-contents) 28 29 @section{Introduction} 30 31 For convenience, we write a @tc[variant] form, which is a 32 thin wrapper against @tc[(U (~or constructor tagged) …)]. 33 34 @section{Implementation of @racket[variant]} 35 36 In @tc[define-variant], we only define the type (which is 37 the union of all the possible constructors. We do not bind 38 identifiers for the constructors, for two reasons: the same 39 @tc[constructor]s could appear in several variants, so we 40 would define them twice, and it is likely that a constructor 41 will have the same identifier as an existing variable or 42 function. 43 44 @chunk[<constructor-or-tagged-stx-class> 45 (begin-for-syntax 46 (define-syntax-class constructor-or-tagged 47 (pattern [constructor-name:id . (~or ([field:id C:colon type:expr] …) 48 (type:expr …))])))] 49 50 @chunk[<variant> 51 (define-type-expander (variant stx) 52 (syntax-parse stx 53 [(_ :constructor-or-tagged …) 54 (template 55 (U (?? (tagged constructor-name [field C type] …) 56 (constructor constructor-name type …)) 57 …))]))] 58 59 @section{Predicate} 60 61 @chunk[<variant?> 62 (define-syntax/parse (variant? :constructor-or-tagged …) 63 (template 64 (λ (v) (or (?? ((tagged? constructor-name field …) v) 65 (constructor? constructor-name v)) 66 …))))] 67 68 @section{@racket[define-variant]} 69 70 @chunk[<define-variant> 71 (define-syntax/parse 72 (define-variant variant-name 73 (~optkw #:debug) 74 (~maybe #:? name?) 75 (~maybe #:match variant-match) 76 (~and constructor-or-tagged :constructor-or-tagged) …) 77 (define/with-syntax default-name? (format-id #'name "~a?" #'name)) 78 (define/with-syntax default-match (format-id #'name "~a-match" #'name)) 79 (define-temp-ids "pat" ((type …) …)) 80 (define-temp-ids "match-body" (constructor-name …)) 81 (template 82 (begin 83 (define-type variant-name 84 (variant [constructor-name (?? (?@ [field C type] …) 85 (?@ type …))] 86 …)) 87 (define-syntax (?? variant-match default-match) 88 (syntax-rules (constructor-name … (?? (?@ field …)) …) 89 [(_ v 90 [(constructor-name (?? (?@ [field pat] …) 91 (pat …))) 92 . match-body] 93 …) 94 (match v 95 (?? [(tagged constructor-name [field pat] …) . match-body] 96 [(constructor constructor-name pat …) . match-body]) 97 …)])) 98 (define-multi-id (?? name? default-name?) 99 #:else 100 #'(variant? constructor-or-tagged …)))) 101 #| 102 (if (andmap (λ (t) (check-remember-all 'variant t)) 103 (syntax->list #'(tag …))) 104 (let () 105 (define/with-syntax (stx-name …) 106 (stx-map (λ (t) 107 (cdr (assoc (syntax->datum (datum->syntax #f t)) 108 tag-name→stx-name/alist))) 109 #'(tag …))) 110 (quasitemplate 111 (begin 112 (define-type name (U (constructor tag type …) …)) 113 (: (?? name? default-name?) 114 (→ Any Boolean : 115 #:+ (or (stx-name Any) …) 116 #:- (and (! (stx-name Any)) …))) 117 (define ((?? name? default-name?) x) 118 (or (Tagged-predicate? tag x) …))))) 119 (stx-map (λ (t) 120 (remember-all-errors2 (syntax/loc t #'please-recompile) 121 t)) 122 #'(tag …)))|#)] 123 124 @section{Conclusion} 125 126 @chunk[<*> 127 (require (for-syntax racket/base 128 racket/list 129 syntax/parse 130 syntax/parse/experimental/template 131 racket/syntax 132 phc-toolkit/untyped 133 type-expander/expander) 134 phc-toolkit 135 multi-id 136 type-expander 137 "constructor.hl.rkt" 138 "structure.hl.rkt") 139 140 (provide variant 141 variant? 142 define-variant) 143 144 <constructor-or-tagged-stx-class> 145 <variant> 146 <variant?> 147 <define-variant>]