diff --git a/graph-lib/graph/__DEBUG_graph6.rkt b/graph-lib/graph/__DEBUG_graph6.rkt index 0547c185..a6c45dd4 100644 --- a/graph-lib/graph/__DEBUG_graph6.rkt +++ b/graph-lib/graph/__DEBUG_graph6.rkt @@ -6,8 +6,7 @@ "get.lp2.rkt" "../type-expander/type-expander.lp2.rkt" "../type-expander/multi-id.lp2.rkt" - "structure.lp2.rkt" ; debug - "variant.lp2.rkt" ; debug + "adt.lp2.rkt" ; debug "fold-queues.lp2.rkt"; debug "rewrite-type.lp2.rkt"; debug "meta-struct.rkt"; debug @@ -22,6 +21,8 @@ |# +(require "../lib/debug-syntax.rkt") + (define-type blob String) (define-type-expander (bubble stx) #'String) @@ -52,18 +53,20 @@ : (Listof Street) (map Street snames)]) +#| + #;(super-define-graph/rich-return - grr3 - ([City [streets : (~> m-streets)]] - [Street [sname : String]]) - [(m-cities [cnames : (Listof (Listof bubble))]) - : (Listof City) - (define (strings→city [s : (Listof blob)]) - (City (m-streets s))) - (map strings→city cnames)] - [(m-streets [snames : (Listof String)]) - : (Listof Street) - (map Street snames)]) + grr3 + ([City [streets : (~> m-streets)]] + [Street [sname : String]]) + [(m-cities [cnames : (Listof (Listof bubble))]) + : (Listof City) + (define (strings→city [s : (Listof blob)]) + (City (m-streets s))) + (map strings→city cnames)] + [(m-streets [snames : (Listof String)]) + : (Listof Street) + (map Street snames)]) #| @@ -82,4 +85,5 @@ (dg grr) (dg grra) +|# |# \ No newline at end of file diff --git a/graph-lib/graph/__DEBUG_variant.rkt b/graph-lib/graph/__DEBUG_variant.rkt index a1568104..5defdb4d 100644 --- a/graph-lib/graph/__DEBUG_variant.rkt +++ b/graph-lib/graph/__DEBUG_variant.rkt @@ -21,7 +21,7 @@ (constructor dh1 Number String)) (constructor dh1 2 "y")) - (define-private-tagged txyz #:? txyz? + (define-tagged txyz #:private #:? txyz? [a Number] [b String]) @@ -32,7 +32,7 @@ (begin (module main typed/racket (require (for-syntax racket/list) - "variant.lp2.rkt") + "adt.lp2.rkt") ) (require 'main) @@ -43,6 +43,6 @@ "../lib/low.rkt" "../type-expander/type-expander.lp2.rkt" typed/rackunit - "variant.lp2.rkt") + "adt.lp2.rkt") ))] \ No newline at end of file diff --git a/graph-lib/graph/adt.lp2.rkt b/graph-lib/graph/adt.lp2.rkt index ffe6df25..4f4e3122 100644 --- a/graph-lib/graph/adt.lp2.rkt +++ b/graph-lib/graph/adt.lp2.rkt @@ -10,21 +10,33 @@ We define variants (tagged unions), with the following constraints: -@itemlist[ - @item{Unions are anonymous: two different unions can contain the same tag, and - there's no way to distinguish these two occurrences of the tag} - @item{Callers can require an uninterned tag which inherits the interned tag, so - that @racket[(constructor #:uninterned tag Number)] is a subtype of - @racket[(constructor #:uninterned tag Number)], but not the reverse} - @item{The tag can be followed by zero or more “fields”} - @item{An instance of a variant only @racket[match]es with its constructor and - the same number of fields, with exact matching on the tag for uninterned - tags}] +@; TODO: put a short usage example here -See @url{https://github.com/andmkent/datatype/} for an existing module providing -Algebraic Data Types. The main difference with our library is that a given tag -(i.e. constructor) cannot be shared by multiple unions, as can be seen in the -example below where the second @tc[define-datatype] throws an error: +@itemlist[ + @item{Unions are anonymous: two different unions can + contain the same tag, and there's no way to distinguish + these two occurrences of the tag} + @item{Users can define an uninterned tag, i.e. one which + will not match against other uses of the same tag name. A + constructor using this uninterned tag is a subtype of the + constructor using the interned one, but not the reverse. + This means that + @racket[(constructor #:uninterned tag Number)] is a + subtype of @racket[(constructor tag Number)], but not the + opposite. This allows testing if a constructor instance + was created by the rightful owner, or by some other code + which happens to use the same name.} + @item{The tag can be followed by zero or more “fields”} + @item{An instance of a variant only @racket[match]es with + its constructor and the same number of fields, with exact + matching on the tag for uninterned tags}] + +See @url{https://github.com/andmkent/datatype/} for an +existing module providing Algebraic Data Types. The main +difference is that unlike our library, a given constructor +name cannot be shared by multiple unions, as can be seen in +the example below where the second @tc[define-datatype] +throws an error: @chunk[ (require datatype) @@ -43,7 +55,7 @@ example below where the second @tc[define-datatype] throws an error: @section{Constructors, tagged, variants and structures} We first define @tc[structure] and @tc[constructor], the -primitives allowing us to build instance, match against them +primitives allowing us to build instances, match against them and express the type itself. @chunk[ @@ -51,7 +63,7 @@ and express the type itself. (require "constructor.lp2.rkt")] We then define @tc[tagged], which is a shorthand for -manipulating constructors which single value is a promise +manipulating constructors whose single value is a promise for a structure. @chunk[ @@ -66,7 +78,7 @@ thin wrapper against @tc[(U (~or constructor tagged) …)]. The @tc[define-tagged] and @tc[define-constructor] forms also allow the @tc[#:uninterned] and @tc[#:private] keywords, to create uninterned constructors and tagged -structures as described in @secref{ADT|introduction}. +structures as described in the @secref{ADT|introduction}. @chunk[ (require "define-adt.lp2.rkt")] @@ -77,31 +89,39 @@ operate on @tc[tagged] structures. We also wrap the plain structure, using a common tag for all plain structures. This allows us to rely on the invariant that @tc[uniform-get] always operates on data with the same shape (a constructor -which single value is a promise for a structure)@note{This +whose single value is a promise for a structure)@note{This avoids the risk of combinatorial explosion for the intput type of @racket[uniform-get], when accessing a deeply nested - field: allowing + field: allowing @racket[(U structure (constructor structure) (constructor (Promise structure)))] - would result in a type of size @${n⁴}, with ${n} then depth + would result in a type of size @${n⁴}, with @${n} the depth of the accessed field.} @chunk[ - (void)] @;(require "uniform-get.lp2.rkt") + (require "uniform-get.lp2.rkt")] @chunk[<*> - (void) - #;(begin + (begin (module main typed/racket (provide constructor define-constructor + ConstructorTop + ConstructorTop? + constructor? + constructor-values tagged define-tagged variant define-variant - (rename-out [wrapped-structure structure]) + (rename-out + [wrapped-structure structure] + [wrapped-structure-supertype structure-supertype] + [structure plain-structure] + [structure-supertype plain-structure-supertype] + [define-structure define-plain-structure]) uniform-get)) (require 'main) diff --git a/graph-lib/graph/constructor.lp2.rkt b/graph-lib/graph/constructor.lp2.rkt index eabeadcd..af242c01 100644 --- a/graph-lib/graph/constructor.lp2.rkt +++ b/graph-lib/graph/constructor.lp2.rkt @@ -12,7 +12,7 @@ This file defines @tc[constructor], a form which allows tagging values, so that two otherwise identical values can be distinguished by the constructors used to wrapp them. -@section[#:tag "variant|supertype"]{The @racket[ConstructorTop] supertype} +@section[#:tag "constructor|supertype"]{The @racket[ConstructorTop] supertype} We define variants as instances of subtypes of the @tc[Tagged] structure: @@ -43,12 +43,31 @@ For this, we use the @tc[remember] library: We pre-declare here in this file all the remembered constructors: +@CHUNK[ + (define-syntax (declare-constructor-struct stx) + (syntax-case stx () + [(_ name) + #`(struct (T) + name + #,(syntax-local-introduce #'ConstructorTop) + () + #:transparent)]))] + +@CHUNK[ + (define-syntax (declare-uninterned-constructor-struct stx) + (syntax-parse stx + [(_ name) + (define/syntax-parse ((~maybe no-with-struct)) #'()) + (with-constructor-name→stx-name + (parent no-with-struct #'name #'please-recompile stx) + #'(struct (T) + name + parent + () + #:transparent))]))] + @CHUNK[ - (struct (T) - constructor-name/struct - #,(syntax-local-introduce #'ConstructorTop) - () - #:transparent) + (declare-constructor-struct constructor-name/struct) …] We define an associative list which maps the constructor @@ -214,7 +233,9 @@ instance: stx) (template ((λ #:∀ (T …) ([arg : T] …) - : (constructor constructor-name T …) + : (constructor constructor-name + (?? (?@ #:with-struct with-struct)) + T …) (stx-name (?? arg₀ (list argᵢ …)))) value …))))] @@ -238,13 +259,18 @@ instance: (rename-out [ConstructorTop-values constructor-values])) + + - ) + + + (module+ private + (provide declare-constructor-struct))) (require 'main) (provide (all-from-out 'main)) diff --git a/graph-lib/graph/define-adt.lp2.rkt b/graph-lib/graph/define-adt.lp2.rkt index 86f4ad4c..c8ff3398 100644 --- a/graph-lib/graph/define-adt.lp2.rkt +++ b/graph-lib/graph/define-adt.lp2.rkt @@ -9,20 +9,60 @@ @section{Introduction} +@section{@racket[uninterned] and @racket[private]} + +We wish to be able to declare tags and constructors only +visible to the creator, unlike the default ones which can be +instantiated and matched against anonymously. + +We will define two flavours. In the first case, +@tc[uninterned] constructors inherit the interned one. It +means that the interned constructor is a supertype of the +uninterned constructor (but not the converse). Two distinct +uninterned constructors with the same name are unrelated +too. The second possibility is to declare a @tc[private] +constructor, where the private constructor inherits directly +from @tc[ConstructorTop], the base structure described in +section @secref{constructor|supertype}, and is therefore +unrelated to the interned constructor (and is unrelated to +the uninterned constructor too). + +The choice to declare an uninterned or private + +@CHUNK[ + (define/syntax-parse ((~maybe with-struct declare-uninterned/private)) + (cond [(attribute uninterned) + #`(#,(syntax-local-introduce #'constructor-name) + declare-uninterned-constructor-struct)] + [(attribute private) + #`(#,(syntax-local-introduce #'constructor-name) + declare-constructor-struct)] + [else #'()]))] + +The above code binds @tc[declare-uninterned/private] to +either @tc[declare-uninterned-constructor-struct] or +@tc[declare-constructor-struct], depending on the keyword +used. The macro's expansion will use this to declare +@tc[with-struct]. + +@chunk[ + (?? (declare-uninterned/private with-struct))] + @section{@racket{define-constructor}} @chunk[ (define-syntax/parse (define-constructor constructor-name:id - (~maybe #:with-struct with-struct) + (~maybe (~optkw #:uninterned) (~optkw #:private)) (~maybe #:? name?) type …) - (define/with-syntax default-name? (format-id #'name "~a?" #'name)) (define-temp-ids "pat" (type …)) (define-temp-ids "value" (type …)) + (template (begin + (define-multi-id constructor-name #:type-expand-once (constructor constructor-name @@ -44,37 +84,220 @@ (?? (?@ #:with-struct with-struct)))))))] @chunk[ - (define-syntax/parse (define-tagged tag:id - (~maybe #:with-struct with-struct) + (define-syntax/parse (define-tagged constructor-name:id + (~maybe (~optkw #:uninterned) (~optkw #:private)) (~maybe #:? name?) [field type] …) (define/with-syntax default-name? (format-id #'name "~a?" #'name)) (define-temp-ids "pat" (type …)) (define-temp-ids "value" (type …)) + (template (begin - (define-multi-id tag + + (define-multi-id constructor-name #:type-expand-once - (tagged tag + (tagged constructor-name (?? (?@ #:with-struct with-struct)) [field type] …) #:match-expander (λ/syntax-parse (_ pat …) - #'(tagged tag + #'(tagged constructor-name (?? (?@ #:with-struct with-struct)) [field pat] …)) #:call (λ/syntax-parse (_ value …) #'(tagged #:instance - tag + constructor-name (?? (?@ #:with-struct with-struct)) - value …))) + [field value] …))) (define-multi-id (?? name? default-name?) #:else - #'(tagged? tag + #'(tagged? constructor-name (?? (?@ #:with-struct with-struct)) field …)))))] +@section{Tests} + +@chunk[ + (define-tagged tagged-s1) + (define-tagged tagged-s2 [f Fixnum] [g String]) + (define-tagged tagged-s3 [g String] [f Fixnum]) + (define-tagged tagged-s4 [f Fixnum] [g String]) + + (check-equal?: (match (ann (tagged-s1) (tagged tagged-s1)) + [(tagged-s1) #t]) + #t) + + (check-equal?: (match (ann (tagged-s2 99 "z") tagged-s2) + [(tagged-s2 f g) (cons g f)]) + '("z" . 99)) + + (let () + (check-equal?: (match (ann (tagged-s2 99 "in-let") tagged-s2) + [(tagged-s2 f g) (cons g f)]) + '("in-let" . 99))) + + (define (test-match val) + (match val + [(tagged-s2 x y) (list 'found-s2 y x)] + [(tagged-s3 x y) (list 'found-s3 y x)] + [(tagged-s4 x y) (list 'found-s4 y x)])) + + (check-equal?: + (test-match (ann (tagged-s2 2 "flob") + (tagged tagged-s2 [f Fixnum] [g String]))) + '(found-s2 "flob" 2)) + + (check-equal?: + (test-match (ann (tagged-s3 "flob" 2) + (tagged tagged-s3 [g String] [f Fixnum]))) + '(found-s3 2 "flob")) + + ;; g and f are inverted in the “ann” + (check-equal?: + (test-match (ann (tagged-s4 2 "flob") + (tagged tagged-s4 [g String] [f Fixnum]))) + '(found-s4 "flob" 2)) + + (define (test-match-verbose val) + (match val + [(tagged tagged-s2 g [f y]) (list 'found-s2 g y)] + [(tagged tagged-s3 [g y] f) (list 'found-s2 f y)] + [(tagged tagged-s4 [f y] g) (list 'found-s2 g y)])) + + (check-equal?: + (test-match (ann (tagged-s2 3 "flob") + (tagged tagged-s2 [f Fixnum] [g String]))) + '(found-s2 "flob" 3)) + + ;; g and f are inverted in the “ann” + (check-equal?: + (test-match (ann (tagged-s3 "flob" 3) + (tagged tagged-s3 [f Fixnum] [g String]))) + '(found-s3 3 "flob")) + + (check-equal?: + (test-match (ann (tagged-s4 3 "flob") + (tagged tagged-s4 [f Fixnum] [g String]))) + '(found-s4 "flob" 3)) + + (check-not-equal?: (tagged-s2 4 "flob") + (tagged-s3 "flob" 4)) + (check-not-equal?: (tagged-s2 4 "flob") + (tagged-s4 4 "flob"))] + +@chunk[ + (define-constructor c1) + (define-constructor c2 Fixnum String) + (define-constructor c3 Fixnum String) + + (check-equal?: (match (ann (c1) (constructor c1)) + [(c1) #t]) + #t) + + (check-equal?: (match (ann (c2 99 "z") c2) + [(c2 f g) (cons g f)]) + '("z" . 99)) + + (let () + (check-equal?: (match (ann (c2 99 "in-let") c2) + [(c2 f g) (cons g f)]) + '("in-let" . 99))) + + (define (test-c-match val) + (match val + [(c1) (list 'found-c1)] + [(constructor c2 x y z) (list 'found-c2-xyz z y x)] + [(c2 x y) (list 'found-c2 y x)] + [(c3 x y) (list 'found-c3 y x)])) + + (check-equal?: + (test-c-match (ann (c2 2 "flob") + (constructor c2 Fixnum String))) + '(found-c2 "flob" 2)) + + (check-equal?: + (test-c-match (ann (c3 2 "flob") + (constructor c3 Fixnum String))) + '(found-c3 "flob" 2))] + +@chunk[ + (define-syntax-rule (defp make mt) + (begin + (define-tagged txyz #:private #:? txyz? + [a Number] + [b String]) + + (define (make) (txyz 1 "b")) + + (define (mt v) + (match v + ((txyz x y) (list 'macro y x)) + (_ #f))))) + + (defp make mt) + + (define-tagged txyz #:private #:? txyz? + [a Number] + [b String]) + + (check-equal?: (match (make) + ((tagged txyz x y) (list 'out y x)) + (_ #f)) + #f) + + (check-equal?: (mt (tagged txyz [x 1] [y "b"])) + #f) + + (check-equal?: (mt (make)) + '(macro "b" 1)) + + (check-not-equal?: (make) (txyz 1 "b")) + (check-equal?: (match (make) + ((txyz x y) (list 'out y x)) + (_ #f)) + #f) + + (check-equal?: (mt (txyz 1 "b")) + #f)] + +@chunk[ + (define-syntax-rule (defpc makec mtc) + (begin + (define-constructor cxyz #:private #:? cxyz? Number String) + + (define (makec) (cxyz 1 "b")) + + (define (mtc v) + (match v + ((cxyz x y) (list 'macro y x)) + (_ #f))))) + + (defpc makec mtc) + + (define-constructor cxyz #:private #:? cxyz? Number String) + + (check-equal?: (match (makec) + ((constructor cxyz e f) (list 'out f e)) + (_ #f)) + #f) + + (check-equal?: (mtc (constructor cxyz 1 "b")) + #f) + + (check-equal?: (mtc (makec)) + '(macro "b" 1)) + + (check-not-equal?: (makec) (cxyz 1 "b")) + (check-equal?: (match (makec) + ((cxyz e f) (list 'out f e)) + (_ #f)) + #f) + + (check-equal?: (mtc (cxyz 1 "b")) + #f)] + @section{Conclusion} @chunk[<*> @@ -86,10 +309,16 @@ racket/syntax (submod "../lib/low.rkt" untyped)) (for-meta 2 racket/base) + "constructor.lp2.rkt" + (submod "constructor.lp2.rkt" main private) + "tagged.lp2.rkt" "../lib/low.rkt" "../type-expander/multi-id.lp2.rkt" "../type-expander/type-expander.lp2.rkt") + (provide define-constructor + define-tagged) + ) @@ -98,5 +327,12 @@ (module* test typed/racket (require (submod "..") + "constructor.lp2.rkt" + "tagged.lp2.rkt" "../lib/low.rkt" - "../type-expander/type-expander.lp2.rkt")))] \ No newline at end of file + "../type-expander/type-expander.lp2.rkt") + + + + + ))] \ No newline at end of file diff --git a/graph-lib/graph/get.lp2.rkt b/graph-lib/graph/get.lp2.rkt index 93a3a0f2..a2b8866b 100644 --- a/graph-lib/graph/get.lp2.rkt +++ b/graph-lib/graph/get.lp2.rkt @@ -103,14 +103,15 @@ otherwise throw an error: l)) v)] [(_ v:expr field other-fields:id …) - #'(let ([v-cache v]) + #'(get (uniform-get v field) other-fields …) + #;#'(let ([v-cache v]) (cond ))])))] @chunk[ [((make-predicate (List Symbol Any)) v-cache) - (get (structure-get (cadr v-cache) field) other-fields …)]] + (get (uniform-get v-cache field) other-fields …)]] @chunk[ [(promise? v-cache) @@ -177,9 +178,9 @@ The type for the function generated by @tc[λget] mirrors the cases from @chunk[ [(_ T:expr field:id other-fields:id …) - #'(Promise - (List Symbol - (structure-supertype [field : (has-get T other-fields …)])))]] + #'(ConstructorTop + (Promise + (plain-structure-supertype [field : (has-get T other-fields …)])))]] @chunk[ (λ (stx) @@ -203,8 +204,7 @@ The type for the function generated by @tc[λget] mirrors the cases from racket/syntax (submod "../lib/low.rkt" untyped)) "../lib/low.rkt" - "structure.lp2.rkt" - "variant.lp2.rkt" + "adt.lp2.rkt" "graph.lp2.rkt" "../type-expander/multi-id.lp2.rkt" "../type-expander/type-expander.lp2.rkt" @@ -216,7 +216,7 @@ The type for the function generated by @tc[λget] mirrors the cases from (begin-for-syntax ) - + <λget>)] diff --git a/graph-lib/graph/graph-6-rich-returns.lp2.rkt b/graph-lib/graph/graph-6-rich-returns.lp2.rkt index c9e2d47c..a1531b11 100644 --- a/graph-lib/graph/graph-6-rich-returns.lp2.rkt +++ b/graph-lib/graph/graph-6-rich-returns.lp2.rkt @@ -110,6 +110,7 @@ plain list. (define-temp-ids "~a/node-marker" (mapping …)) (define-temp-ids "~a/from-first-pass" (node …)) ;(define/with-syntax id-~> (datum->syntax #'name '~>)) + (define/with-syntax introduced-~> (datum->syntax #'name '~>)) (quasitemplate/debug debug (begin @@ -150,7 +151,7 @@ plain list. @chunk[ (tmpl-replace-in-instance - (Let ~> second-step-marker-expander field-type) + (Let (introduced-~> second-step-marker-expander) field-type) )] @chunk[ @@ -276,8 +277,7 @@ encapsulating the result types of mappings. "get.lp2.rkt" "../type-expander/type-expander.lp2.rkt" "../type-expander/multi-id.lp2.rkt" - "structure.lp2.rkt" ; debug - "variant.lp2.rkt" ; debug + "adt.lp2.rkt" ; debug "fold-queues.lp2.rkt"; debug "rewrite-type.lp2.rkt"; debug "meta-struct.rkt"; debug diff --git a/graph-lib/graph/graph.lp2.rkt b/graph-lib/graph/graph.lp2.rkt index be714687..fce9792c 100644 --- a/graph-lib/graph/graph.lp2.rkt +++ b/graph-lib/graph/graph.lp2.rkt @@ -562,15 +562,11 @@ the @tc[tmpl-replace-in-type] template metafunction from the rewrite-type library. We replace all occurrences of a @tc[node] name with a @tc[Promise] for that node's @tc[with-promises] type. -@; TODO: use a type-expander here, instead of a template metafunction. - -@; TODO: use a private-constructor here (single field, no need to use a -@; structure with define-private-tagged). @CHUNK[ - (define-private-constructor node/promise-type + (define-constructor node/promise-type #:private (Promise node/with-promises))] @CHUNK[ - (define-structure node/with-promises + (define-plain-structure node/with-promises [field ] …)] @CHUNK[ @@ -599,6 +595,7 @@ library. We replace all occurrences of a @tc[node] name with its @chunk[ (define-type field/incomplete-type )] + @chunk[ (tmpl-replace-in-type field-type [node node/placeholder-type] …)] @@ -766,11 +763,9 @@ We will be able to use this type expander in function types, for example: x) (check-equal?: (let* ([v1 (car - (structure-get (force (Tagged-value g)) - streets))] + (uniform-get g streets))] [v2 (ann (type-example v1) (gr Street))] - [v3 (structure-get (force (Tagged-value v2)) - sname)]) + [v3 (uniform-get v2 sname)]) v3) : String "Ada Street")] @@ -791,8 +786,7 @@ We will be able to use this type expander in function types, for example: "fold-queues.lp2.rkt" "rewrite-type.lp2.rkt" "../lib/low.rkt" - "structure.lp2.rkt" - "variant.lp2.rkt" + "adt.lp2.rkt" "../type-expander/type-expander.lp2.rkt" "../type-expander/multi-id.lp2.rkt" "meta-struct.rkt") @@ -815,27 +809,8 @@ not match the one from @tc[typed/racket] (module* test typed/racket (require (submod "..") (only-in "../lib/low.rkt" cars cdrs check-equal?:) - (only-in "structure.lp2.rkt" structure-get) - "../type-expander/type-expander.lp2.rkt" - typed/rackunit - ;;DEBUG: - (for-syntax syntax/parse - racket/syntax - syntax/parse/experimental/template - racket/sequence - racket/pretty - "rewrite-type.lp2.rkt" - (submod "../lib/low.rkt" untyped) - "meta-struct.rkt") - racket/splicing - "fold-queues.lp2.rkt" - "rewrite-type.lp2.rkt" - "../lib/low.rkt" - "structure.lp2.rkt" - "variant.lp2.rkt" - "../type-expander/type-expander.lp2.rkt" - "../type-expander/multi-id.lp2.rkt" - "meta-struct.rkt") + (only-in "adt.lp2.rkt" uniform-get) + "../type-expander/type-expander.lp2.rkt") (provide g) diff --git a/graph-lib/graph/remember.rkt b/graph-lib/graph/remember.rkt index eeeefe7e..670139d2 100644 --- a/graph-lib/graph/remember.rkt +++ b/graph-lib/graph/remember.rkt @@ -160,3 +160,11 @@ (constructor . Number) (constructor . String) (constructor . Number) +(constructor . c1) +(constructor . c2) +(constructor . c3) +(constructor . wrapped-structure) +(constructor . structure) +(constructor . structure) +(constructor . wstructure) +(constructor . wstructure) diff --git a/graph-lib/graph/rewrite-type.lp2.rkt b/graph-lib/graph/rewrite-type.lp2.rkt index c58b9162..03c589e4 100644 --- a/graph-lib/graph/rewrite-type.lp2.rkt +++ b/graph-lib/graph/rewrite-type.lp2.rkt @@ -519,7 +519,17 @@ functions is undefined. [((~literal quote) a) #'(inst values 'a acc-type)] [x:id - #'(inst values x acc-type)]))] + #'(inst values x acc-type)] + [_ + (raise-syntax-error 'recursive-replace-4 + (format (string-append "Syntax-parse failed\n" + " ~a\n" + " expanded to ~a") + (syntax->datum type) + (syntax->datum (expand-type type))) + `(recursive-replace-4 ,(current-replacement)) + #f + (list type))]))] @subsection{Union types} @@ -648,8 +658,6 @@ These metafunctions just extract the arguments for @tc[replace-in-type] and (only-in "../type-expander/type-expander.lp2.rkt" expand-type) "meta-struct.rkt") - "structure.lp2.rkt" - "variant.lp2.rkt" "../type-expander/multi-id.lp2.rkt" "../type-expander/type-expander.lp2.rkt" "../lib/low.rkt") @@ -683,8 +691,6 @@ These metafunctions just extract the arguments for @tc[replace-in-type] and (module* test typed/racket (require (submod "..") typed/rackunit - "structure.lp2.rkt" - "variant.lp2.rkt" "../type-expander/multi-id.lp2.rkt" "../type-expander/type-expander.lp2.rkt") diff --git a/graph-lib/graph/tagged.lp2.rkt b/graph-lib/graph/tagged.lp2.rkt index 907afa75..92104110 100644 --- a/graph-lib/graph/tagged.lp2.rkt +++ b/graph-lib/graph/tagged.lp2.rkt @@ -32,8 +32,9 @@ for a structure. . structure-type) (quasitemplate (constructor tag (?? (?@ #:with-struct with-struct)) - #,(syntax/loc #'structure-type - (structure . structure-type)))))] + (Promise + #,(syntax/loc #'structure-type + (structure . structure-type))))))] @subsection{@racket[match-expander]} @@ -42,8 +43,10 @@ for a structure. . structure-pat) (quasitemplate (constructor tag (?? (?@ #:with-struct with-struct)) - #,(syntax/loc #'structure-pat - (structure . structure-pat)))))] + (? promise? + (app force + #,(syntax/loc #'structure-pat + (structure . structure-pat)))))))] @subsection{@racket[instance creation]} @@ -62,30 +65,39 @@ for a structure. (define-temp-ids "~a/arg" (sa.field …)) (define/with-syntax c (if (attribute sa.type) - (quasitemplate - (λ ([sa.field/arg : sa.type] …) - : (constructor tag (?? (?@ #:with-struct with-struct)) - #,(syntax/loc #'fields - (structure [sa.field sa.type] …))) - (constructor tag (?? (?@ #:with-struct with-struct)) - #,(syntax/loc #'fields - (structure #:instance - [sa.field : sa.type sa.field/arg] - …))))) - (quasitemplate - (λ #:∀ (sa.field/TTemp …) ([sa.field/arg : sa.field/TTemp] …) - : (constructor tag (?? (?@ #:with-struct with-struct)) - #,(syntax/loc #'fields - (structure [sa.field sa.field/TTemp] …))) - (constructor tag (?? (?@ #:with-struct with-struct)) - #,(syntax/loc #'fields - (structure #:instance - [sa.field sa.field/arg] …))))))) + (quasitemplate ) + (quasitemplate ))) (if (attribute sa.value) #'(c sa.value …) #'c))] -@subsection{@racket[predicate]} +@CHUNK[ + (λ ([sa.field/arg : sa.type] …) + : (constructor tag (?? (?@ #:with-struct with-struct)) + (Promise + #,(syntax/loc #'fields + (structure [sa.field sa.type] …)))) + (constructor tag (?? (?@ #:with-struct with-struct)) + #,(syntax/loc #'fields + (delay + (structure #:instance + [sa.field : sa.type sa.field/arg] + …)))))] + + +@CHUNK[ + (λ #:∀ (sa.field/TTemp …) ([sa.field/arg : sa.field/TTemp] …) + : (constructor tag (?? (?@ #:with-struct with-struct)) + (Promise + #,(syntax/loc #'fields + (structure [sa.field sa.field/TTemp] …)))) + (constructor tag (?? (?@ #:with-struct with-struct)) + #,(syntax/loc #'fields + (delay + (structure #:instance + [sa.field sa.field/arg] …)))))] + +@subsection{Predicate} @CHUNK[ (define-multi-id TaggedTop? diff --git a/graph-lib/graph/uniform-get.lp2.rkt b/graph-lib/graph/uniform-get.lp2.rkt new file mode 100644 index 00000000..78b51fde --- /dev/null +++ b/graph-lib/graph/uniform-get.lp2.rkt @@ -0,0 +1,78 @@ +#lang scribble/lp2 +@(require "../lib/doc.rkt") +@doc-lib-setup + +@title[#:style manual-doc-style]{Algebaraic Data Types: @racket[uniform-get]} + +@(table-of-contents) + +@section{Introduction} + +@section{Wrapped structures} + +@chunk[ + ;; Pre-declare the tag. + (let () + (tagged #:instance wstructure) + (void)) + + (define-multi-id wrapped-structure + #:type-expander + (λ/syntax-parse (_ . rest) + #'(tagged wstructure (structure . rest))) + #:match-expander + (λ/syntax-parse (_ . rest) + #'(tagged wstructure (structure . rest))) + #:call + (λ/syntax-parse (_ . rest) + #'(tagged wstructure (structure . rest)))) + + (define-type-expander (wrapped-structure-supertype stx) + (syntax-case stx () + [(_ . rest) + #'(constructor wstructure + (Promise + (structure-supertype . rest)))]))] + +@section{@racket[uniform-get]} + +@racket[uniform-get] operates on tagged structures. It +retrieves the desired field from the structure. + +@chunk[ + (define-syntax-rule (uniform-get v field) + (structure-get (force (constructor-values v)) field))] + +@section{Conclusion} + +@chunk[<*> + (begin + (module main typed/racket + (require (for-syntax racket/list + syntax/parse + syntax/parse/experimental/template + racket/syntax + (submod "../lib/low.rkt" untyped)) + "../lib/low.rkt" + "../type-expander/multi-id.lp2.rkt" + "../type-expander/type-expander.lp2.rkt" + "constructor.lp2.rkt" + "tagged.lp2.rkt" + "structure.lp2.rkt" + "define-adt.lp2.rkt") + + (provide wrapped-structure + wrapped-structure-supertype + uniform-get) + + + ) + + (require 'main) + (provide (all-from-out 'main)) + + (module* test typed/racket + (require (submod "..") + "../lib/low.rkt" + "../type-expander/type-expander.lp2.rkt") + ))] \ No newline at end of file diff --git a/graph-lib/graph/variant.lp2.rkt b/graph-lib/graph/variant.lp2.rkt deleted file mode 100644 index 69deb195..00000000 --- a/graph-lib/graph/variant.lp2.rkt +++ /dev/null @@ -1,330 +0,0 @@ -#lang scribble/lp2 -@(require "../lib/doc.rkt") -@doc-lib-setup - -@title[#:style manual-doc-style]{Variants} - -@(table-of-contents) - -@section{@racket[tagged]} - -@section{@racket[define-tagged]} - -@chunk[ - (define-syntax/parse (define-tagged tag:id - (~maybe #:? tag?) - [field type] …) - (define/with-syntax (pat …) (generate-temporaries #'(field …))) - (define/with-syntax (value …) (generate-temporaries #'(field …))) - (define/with-syntax default-tag? (format-id #'tag "~a?" #'tag)) - (template - (begin - (define-multi-id tag - #:type-expand-once - (tagged tag [field type] …) - #:match-expander - (λ/syntax-parse (_ pat …) - #'(tagged tag [field pat] …)) - #:call - (λ/syntax-parse (_ value …) - #'(tagged tag #:instance [field value] …))) - (: (?? tag? default-tag?) (→ Any Boolean)) - (define ((?? tag? default-tag?) x) - (and (Tagged-predicate? tag x) - ((structure? field …) (Tagged-value x)))))))] - -@chunk[ - (define-tagged tagged-s1) - (define-tagged tagged-s2 [f Fixnum] [g String]) - (define-tagged tagged-s3 [g String] [f Fixnum]) - (define-tagged tagged-s4 [f Fixnum] [g String]) - - (check-equal?: (match (ann (tagged-s1) (tagged tagged-s1)) - [(tagged-s1) #t]) - #t) - - (check-equal?: (match (ann (tagged-s2 99 "z") tagged-s2) - [(tagged-s2 f g) (cons g f)]) - '("z" . 99)) - - (let () - (check-equal?: (match (ann (tagged-s2 99 "in-let") tagged-s2) - [(tagged-s2 f g) (cons g f)]) - '("in-let" . 99))) - - (define (test-match val) - (match val - [(tagged-s2 x y) (list 'found-s2 y x)] - [(tagged-s3 x y) (list 'found-s3 y x)] - [(tagged-s4 x y) (list 'found-s4 y x)])) - - (check-equal?: - (test-match (ann (tagged-s2 2 "flob") - (tagged tagged-s2 [f Fixnum] [g String]))) - '(found-s2 "flob" 2)) - - (check-equal?: - (test-match (ann (tagged-s3 "flob" 2) - (tagged tagged-s3 [g String] [f Fixnum]))) - '(found-s3 2 "flob")) - - ;; g and f are inverted in the “ann” - (check-equal?: - (test-match (ann (tagged-s4 2 "flob") - (tagged tagged-s4 [g String] [f Fixnum]))) - '(found-s4 "flob" 2)) - - (define (test-match-verbose val) - (match val - [(tagged tagged-s2 g [f y]) (list 'found-s2 g y)] - [(tagged tagged-s3 [g y] f) (list 'found-s2 f y)] - [(tagged tagged-s4 [f y] g) (list 'found-s2 g y)])) - - (check-equal?: - (test-match (ann (tagged-s2 3 "flob") - (tagged tagged-s2 [f Fixnum] [g String]))) - '(found-s2 "flob" 3)) - - ;; g and f are inverted in the “ann” - (check-equal?: - (test-match (ann (tagged-s3 "flob" 3) - (tagged tagged-s3 [f Fixnum] [g String]))) - '(found-s3 3 "flob")) - - (check-equal?: - (test-match (ann (tagged-s4 3 "flob") - (tagged tagged-s4 [f Fixnum] [g String]))) - '(found-s4 "flob" 3)) - - (check-not-equal?: (tagged-s2 4 "flob") - (tagged-s3 "flob" 4)) - (check-not-equal?: (tagged-s2 4 "flob") - (tagged-s4 4 "flob"))] - -@section{Uninterned tags} - -We wish to be able to declare tags only visible to the -creator, unlike the ones above which are visible -everywhere. - -We will define two flavours: one where uninterned tags -inherit the interned tag, os that the interned @tc[tag] is a -supertype of the uninterned @tc[tag] (but not the converse), -and a second, which we will call private tags, where the -private tag inherits directly from @tc[Tagged], the base -structure described in section @secref{variant|supertype}, -and is therefore unrelated to the interned @tc[tag] (nor to -the uninterned @tc[tag] either). - -@; TODO: this should be integrated a bit better with other function, for example -@; Tagged-predicate? (provided as Tagged?) is likely to not work on uninterned -@; tags. - -@chunk[ - (define-syntax/parse - (define-private-tagged tag:id - (~maybe #:? tag?) - . (~and structure-type - ([field (~optional (~and C :colon)) type] …))) - (define/with-syntax default-tag? (format-id #'tag "~a?" #'tag)) - (define-temp-ids "~a/struct" tag) - (define-temp-ids "~a/arg" (field …)) - (define-temp-ids "~a/pat" (field …)) - (template - (begin - (struct (T) tag/struct Tagged ()) ; Private - ;(struct (T) tag/struct interned ()) ; Uninterned - (define-multi-id tag - #:type-expand-once - (tag/struct (structure . structure-type)) - #:match-expander - (λ/syntax-parse (_ . (~and structure-pat - ((~and field/pat :expr) …))) - (quasitemplate - (and (? (make-predicate (tag/struct Any))) - (app Tagged-value - #,(syntax/loc #'structure-pat - (structure [field field/pat] …)))))) - #:call - (λ/syntax-parse (_ . (~and args ((~and field/arg :expr) …))) - (quasitemplate - (tag/struct #,(syntax/loc #'args - (structure #:instance - [field : type field/arg] …)))))) - ;; TODO: the return type is not precise enough, it should be: - ;; #:+ (tag/struct (structure Any …)) - ;; #:- (! (tag/struct (structure Any …))) - (: (?? tag? default-tag?) (→ Any Boolean : - #:+ (tag/struct Any))) - (define ((?? tag? default-tag?) x) - (and ((make-predicate (tag/struct Any)) x) - ((structure? field …) (Tagged-value x)))))))] - -@chunk[ - (define-syntax/parse - (define-private-constructor tag:id - (~maybe #:? tag?) - T:expr …) - (define/with-syntax default-tag? (format-id #'tag "~a?" #'tag)) - (define-temp-ids "~a/struct" tag) - (define-temp-ids "~a/arg" (T …)) - (define-temp-ids "~a/pat" (T …)) - (define/syntax-parse (~or ([T₀:expr arg₀ pat₀]) - ([Tᵢ:expr argᵢ patᵢ] …)) - #'([T T/arg T/pat] …)) - (template - (begin - (struct (X) tag/struct Tagged ()) ; Private - ;(struct (X) tag/struct interned ()) ; Uninterned - (define-multi-id tag - #:type-expand-once - (tag/struct (?? T₀ (List Tᵢ …))) - #:match-expander - (λ/syntax-parse (_ . (~and pats (?? ((~and pat₀ :expr)) - ((~and patᵢ :expr) …)))) - (quasitemplate - (and (? (make-predicate (tag/struct Any))) - (app Tagged-value - #,(syntax/loc #'pats - (?? pat₀ (list patᵢ …))))))) - #:call - (λ/syntax-parse (_ . (~and args (?? ((~and arg₀ :expr)) - ((~and argᵢ :expr) …)))) - (quasitemplate - (tag/struct #,(syntax/loc #'args - (?? arg₀ (list argᵢ …))))))) - (: (?? tag? default-tag?) (→ Any Boolean : (tag/struct Any))) - (define ((?? tag? default-tag?) x) - ((make-predicate (tag/struct Any)) x)))))] - -@chunk[ - (define-syntax-rule (defp make mt) - (begin - (define-private-tagged txyz #:? txyz? - [a Number] - [b String]) - - (define (make) (txyz 1 "b")) - - (define (mt v) - (match v - ((txyz x y) (list 'macro y x)) - (_ #f))))) - - (defp make mt) - - (define-private-tagged txyz #:? txyz? - [a Number] - [b String]) - - (check-equal?: (match (make) - ((tagged txyz x y) (list 'out y x)) - (_ #f)) - #f) - - (check-equal?: (mt (tagged txyz [x 1] [y "b"])) - #f) - - (check-equal?: (mt (make)) - '(macro "b" 1)) - - (check-not-equal?: (make) (txyz 1 "b")) - (check-equal?: (match (make) - ((txyz x y) (list 'out y x)) - (_ #f)) - #f) - - (check-equal?: (mt (txyz 1 "b")) - #f)] - -@chunk[ - (define-syntax-rule (defpc makec mtc) - (begin - (define-private-constructor cxyz #:? cxyz? Number String) - - (define (makec) (cxyz 1 "b")) - - (define (mtc v) - (match v - ((cxyz x y) (list 'macro y x)) - (_ #f))))) - - (defpc makec mtc) - - (define-private-constructor cxyz #:? cxyz? Number String) - - (check-equal?: (match (makec) - ((constructor cxyz e f) (list 'out f e)) - (_ #f)) - #f) - - (check-equal?: (mtc (constructor cxyz 1 "b")) - #f) - - (check-equal?: (mtc (makec)) - '(macro "b" 1)) - - (check-not-equal?: (makec) (cxyz 1 "b")) - (check-equal?: (match (makec) - ((cxyz e f) (list 'out f e)) - (_ #f)) - #f) - - (check-equal?: (mtc (cxyz 1 "b")) - #f)] - -@section{Conclusion} - -@chunk[<*> - (begin - (module main typed/racket - (require (for-syntax racket/list - syntax/parse - syntax/parse/experimental/template - racket/syntax - (submod "../lib/low.rkt" untyped)) - "../lib/low.rkt" - "../type-expander/multi-id.lp2.rkt" - "../type-expander/type-expander.lp2.rkt" - "structure.lp2.rkt") - (provide (rename-out [Tagged-predicate? Tagged?] - [Tagged-type TaggedTop]) - Tagged-value - constructor - define-variant - define-private-tagged - define-private-constructor) - - - - - - - - - - - - - - - - (module+ test-helpers - #;(provide Tagged-value))) - - (require 'main) - (provide (all-from-out 'main)) - - (module* test typed/racket - (require (submod "..") - (submod ".." main test-helpers) - typed/rackunit - "../lib/low.rkt" - "../type-expander/type-expander.lp2.rkt") - - - - - - - ))] diff --git a/graph-lib/graph/variant.lp2.rkt.old b/graph-lib/graph/variant.lp2.rkt.old new file mode 100644 index 00000000..7f66e9bf --- /dev/null +++ b/graph-lib/graph/variant.lp2.rkt.old @@ -0,0 +1,61 @@ +#lang scribble/lp2 +@(require "../lib/doc.rkt") +@doc-lib-setup + +@section{Uninterned tags} + +@section{Conclusion} + +@chunk[<*> + (begin + (module main typed/racket + (require (for-syntax racket/list + syntax/parse + syntax/parse/experimental/template + racket/syntax + (submod "../lib/low.rkt" untyped)) + "../lib/low.rkt" + "../type-expander/multi-id.lp2.rkt" + "../type-expander/type-expander.lp2.rkt" + "structure.lp2.rkt") + (provide (rename-out [Tagged-predicate? Tagged?] + [Tagged-type TaggedTop]) + Tagged-value + constructor + define-variant + define-private-tagged + define-private-constructor) + + + + + + + + + + + + + + + + (module+ test-helpers + #;(provide Tagged-value))) + + (require 'main) + (provide (all-from-out 'main)) + + (module* test typed/racket + (require (submod "..") + (submod ".." main test-helpers) + typed/rackunit + "../lib/low.rkt" + "../type-expander/type-expander.lp2.rkt") + + + + + + + ))] diff --git a/graph-lib/lib.rkt b/graph-lib/lib.rkt index eb8aa5c4..bcc4b2f9 100644 --- a/graph-lib/lib.rkt +++ b/graph-lib/lib.rkt @@ -10,8 +10,7 @@ (r/p "lib/low.rkt" "type-expander/multi-id.lp2.rkt" "type-expander/type-expander.lp2.rkt" - "graph/structure.lp2.rkt" - "graph/variant.lp2.rkt" + "graph/adt.lp2.rkt" "graph/graph.lp2.rkt" "graph/get.lp2.rkt" "graph/map.rkt" diff --git a/graph-lib/lib/doc/example.lp2.rkt b/graph-lib/lib/doc/example.lp2.rkt index 1e6edf33..807cc08b 100644 --- a/graph-lib/lib/doc/example.lp2.rkt +++ b/graph-lib/lib/doc/example.lp2.rkt @@ -18,7 +18,9 @@ In section @secref{doc/example|foo} we present, blah blah. @subsection[#:tag "doc/example|foo"]{My subsection} -@$${\frac{2x}{x^2}} +@$${\frac{\href{//jsmaniac.github.io}{2x}}{\class{some-css-class}{x^2}}} + + @(colorize (filled-ellipse 30 15) "blue") @; Line comment diff --git a/graph-lib/main.rkt b/graph-lib/main.rkt index 3301216c..ecf9291c 100644 --- a/graph-lib/main.rkt +++ b/graph-lib/main.rkt @@ -6,7 +6,7 @@ (require "type-expander/type-expander.lp2.rkt") (require "type-expander/multi-id.lp2.rkt") -(require "graph/variant.lp2.rkt") +(require "graph/adt.lp2.rkt") |# #| @@ -109,7 +109,7 @@ (module m typed/racket (provide ma) (require "type-expander/type-expander.lp2.rkt") - (require "graph/variant.lp2.rkt") + (require "graph/adt.lp2.rkt") ;(let () ;(define-tagged ma (fav String)) diff --git a/graph-lib/type-expander/type-expander.lp2.rkt b/graph-lib/type-expander/type-expander.lp2.rkt index e1765d52..b0a091fa 100644 --- a/graph-lib/type-expander/type-expander.lp2.rkt +++ b/graph-lib/type-expander/type-expander.lp2.rkt @@ -83,6 +83,8 @@ else. @chunk[ (define (apply-type-expander type-expander-stx stx) + (displayln type-expander-stx) + (displayln (syntax->datum type-expander-stx)) (let ([type-expander (syntax-local-value type-expander-stx)]) (((get-prop:type-expander-value type-expander) type-expander) stx)))] @@ -133,9 +135,15 @@ else. . args) ;; TODO: test #:with expanded-once #'(nested-application.expanded-once . args)) - (pattern (~datum ~>) + (pattern (~and xxx (~datum ~>)) #:with expanded-once #'() - #:when (displayln (format "dict = ~a" (dict->list env))) + #:when (display (format "dict =\n ")) + #:when (displayln (dict->list env)) + #:when (displayln #'xxx) + #:when (newline) + #:when (pretty-write (map syntax-debug-info + (map car (dict->list env)))) + #:when (pretty-write (syntax-debug-info #'xxx)) #:when #f)) (define-syntax-class fa (pattern (~or (~literal ∀) (~literal All)))) @@ -155,7 +163,8 @@ else. #,(expand-type #'T (bind-type-vars #'(TVar ...) env)))] [((~literal Rec) R:id T:expr) #`(Rec R #,(expand-type #'T (bind-type-vars #'(R) env)))] - [((~datum Let) [V:id E:id] T:expr);; TODO: ~literal instead of ~datum + [((~commit (~datum Let)) [V:id E:id] T:expr) + ;; TODO: ~literal instead of ~datum ;; TODO: ~commit when we find Let, so that syntax errors are not ;; interpreted as an arbitrary call. ;; TODO : for now we only allow aliasing (which means E is an id),