tagged-supertype.hl.rkt (5659B)
1 #lang hyper-literate typed/racket/base #:no-require-lang #:no-auto-require 2 @(require scribble-enhanced/doc 3 scribble-math 4 racket/require 5 hyper-literate 6 (for-label (lib "phc-adt/tagged-structure-low-level.hl.rkt") 7 (lib "phc-adt/tagged.hl.rkt") 8 extensible-parser-specifications 9 racket/format 10 phc-toolkit 11 phc-toolkit/untyped-only 12 remember 13 syntax/parse 14 syntax/parse/experimental/template 15 (subtract-in typed/racket/base type-expander) 16 type-expander 17 type-expander/expander 18 multi-id)) 19 @doc-lib-setup 20 21 @title[#:style manual-doc-style 22 #:tag "tagged-supertype" 23 #:tag-prefix "phc-adt/tagged-supertype" 24 ]{Supertypes of tagged structures} 25 26 @(chunks-toc-prefix 27 '("(lib phc-adt/scribblings/phc-adt-implementation.scrbl)" 28 "phc-adt/tagged-supertype")) 29 30 31 @section{type-expander} 32 33 @chunk[<tagged-supertype> 34 (define-multi-id tagged-supertype 35 #:type-expander <tagged-supertype-type-expander> 36 #:match-expander <tagged-supertype-match-expander>)] 37 38 As a type, @racket[tagged-supertype] accepts two syntaxes. With the first 39 one, the type of each field is specified, and the second returns a parametric 40 structure: 41 42 @chunk[<tagged-supertype-type-expander-signature-types> 43 (_ name:id [field:id (~optional :colon) type:expr] …)] 44 45 @chunk[<tagged-supertype-type-expander-signature-infer> 46 (_ name (~either [field:id] field:id) …)] 47 48 The type uses the @racket[structure] type-expander, and 49 expands to the union of all structures which contain a 50 superset of the given set of fields. It uses the specified 51 type for the given fields, and defaults to @racket[Any] for the 52 other extra fields. 53 54 @chunk[<tagged-supertype-type-expander-impl-types> 55 (has-fields/type #'([field type] …))] 56 57 The second syntax builds upon the first, and produces a 58 parametric type, with a @racket[∀] type argument for each 59 specified field (other fields still falling back to 60 @racket[Any]). 61 62 @CHUNK[<tagged-supertype-type-expander-impl-infer> 63 (define-temp-ids "~a/τ" (field …)) 64 #`(∀ (field/τ …) 65 #,(has-fields/type #'([field field/τ] …)))] 66 67 The type-expander finally calls either case depending on the 68 syntax used. 69 70 @chunk[<tagged-supertype-type-expander> 71 (λ (stx) 72 (syntax-parse stx 73 [<tagged-supertype-type-expander-signature-types> 74 <tagged-supertype-type-expander-impl-types>] 75 [<tagged-supertype-type-expander-signature-infer> 76 <tagged-supertype-type-expander-impl-infer>]))] 77 78 @section{Match} 79 80 The match-expander for tagged-supertype accepts all 81 structures which contain a superset of the given set of fields: 82 83 @chunk[<tagged-supertype-match-expander> 84 (λ/syntax-parse (_ . :tagged-match-args-syntax-class) 85 (define/with-syntax ([common . (all-field …)] …) 86 (has-fields/common #'(fieldᵢ …))) 87 (define/with-syntax ((maybe-fieldᵢ …) …) 88 (if (attribute no-implicit) 89 (map (const #'()) #'(fieldᵢ …)) 90 #'((fieldᵢ) …))) 91 (define/with-syntax ((maybe-pats …) …) 92 (quasitemplate ((<maybe-pat…> …) …))) 93 #`(or (tagged name #:no-implicit-bind [all-field . maybe-pats] …) …))] 94 95 @chunk[<tagged-anytag-match> 96 (define-match-expander tagged-anytag-match 97 (λ/syntax-case ([fieldᵢ patᵢⱼ …] …) () 98 (tagged-anytag-match! #'([fieldᵢ (and patᵢⱼ …)] …))))] 99 100 Each field that was passed to @racket[tagged-supertype] 101 additionally matches against the given @racket[pat …], and 102 other fields do not use any extra pattern. 103 104 @chunk[<maybe-pat…> 105 (!cdr-assoc #:default [] 106 all-field 107 [fieldᵢ . [maybe-fieldᵢ … patᵢⱼ …]] 108 …)] 109 110 @section{Nested supertype} 111 112 The @racket[(tagged-supertype* f₁ f₂ … fₙ T)] type describes any structure 113 containing a field @racket[f₁], whose type is any structure containing a field 114 @racket[f₂] etc. The last field's type is given by @racket[T]. 115 116 @chunk[<tagged-supertype*> 117 (define-multi-id tagged-supertype* 118 #:type-expander 119 (λ (stx) 120 (error (string-append "tagged-supertype* is currently broken (needs" 121 " to ignore the tag name, since it doe not" 122 " have a tag at each step.")) 123 (syntax-parse stx 124 [(_ T:expr) 125 #`T] 126 [(_ T:expr field:id other-fields:id …) 127 #`(tagged-supertype 128 [field (tagged-supertype* T other-fields …)])])) 129 (code:comment 130 "#:match-expander <tagged-supertype-match-expander> ; TODO"))] 131 132 @section{Conclusion} 133 134 @chunk[<*> 135 (require (for-syntax racket/base 136 racket/function 137 racket/syntax 138 syntax/parse 139 syntax/parse/experimental/template 140 phc-toolkit/untyped 141 type-expander/expander) 142 phc-toolkit 143 multi-id 144 type-expander 145 "tagged-structure-low-level.hl.rkt" 146 "tagged.hl.rkt") 147 148 (provide tagged-supertype 149 tagged-supertype*) 150 151 <tagged-anytag-match> 152 <tagged-supertype> 153 <tagged-supertype*>]