commit f615ae243bb146ca90072abbfc2d11cc19da49a1
parent 00c5471830ada9e0223843a498816d226c69fef7
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Wed, 18 Jan 2017 04:11:41 +0100
Fixed storage of graph-info
Diffstat:
4 files changed, 130 insertions(+), 102 deletions(-)
diff --git a/graph-info.hl.rkt b/graph-info.hl.rkt
@@ -24,63 +24,68 @@ We define here the compile-time metadata describing a graph type.
[root-node identifier?]
[node-order (listof identifier?)]
[nodes (hash/c symbol? node-info? #:immutable #t)]
- [invariants (equal-hash-set/c invariant-info? #:kind 'immutable)])
- #:prefab)]
-
-Since sets created with @racket[set] cannot be used within syntax objects
-(they cannot be marshalled into compiled code), we fake sets using hashes with
-empty values:
-
-@chunk[<hash-set/c>
- (provide hash-set/c)
- (define/contract (hash-set/c elem/c
- #:kind [kind 'dont-care]
- #:cmp [cmp 'dont-care])
- (->* (chaperone-contract?)
- (#:kind (or/c 'dont-care 'immutable 'mutable
- 'weak 'mutable-or-weak)
- #:cmp (or/c 'dont-care 'equal 'eqv 'eq))
- contract?)
- (define immutable
- (case kind
- [(immutable) #t]
- [(dont-care) 'dont-care]
- [else #f]))
- (define h (hash/c elem/c
- null?
- #:immutable immutable))
- (define cmp-contracts
- (case cmp
- [(dont-care) empty]
- [(equal) (list hash-equal?)]
- [(eqv) (list hash-eqv?)]
- [(eq) (list hash-eq?)]))
- (define weak-contracts
- (case kind
- [(weak) (list hash-weak?)]
- ;; This is redundant as the mutable check is already included above
- [(mutable-or-weak) (list (or/c hash-weak? (not/c immutable?)))]
- [(dont-care) empty]
- [else (list (not/c hash-weak?))]))
- (if (empty? (append cmp-contracts weak-contracts))
- h
- (apply and/c (append (list h) cmp-contracts weak-contracts))))]
-
-@chunk[<hash-set/c>
- (provide equal-hash-set/c)
- (define/contract (equal-hash-set/c elem/c
- #:kind [kind 'dont-care])
- (->* (chaperone-contract?)
- (#:kind (or/c 'dont-care 'immutable 'mutable
- 'weak 'mutable-or-weak))
- contract?)
- (hash-set/c elem/c #:kind kind #:cmp 'equal))]
-
-@chunk[<hash-set/c>
- (provide list->equal-hash-set)
- (define/contract (list->equal-hash-set l)
- (-> (listof any/c) (equal-hash-set/c any/c #:kind 'immutable))
- (make-immutable-hash (map (λ (v) (cons v null)) l)))]
+ [invariants (set/c invariant-info? #:kind 'immutable #:cmp 'equal)])
+ #:transparent
+ #:methods gen:custom-write
+ [(define write-proc (struct-printer 'graph-info))]
+ #:property prop:custom-print-quotable 'never)]
+
+@;{
+ Since sets created with @racket[set] cannot be used within syntax objects
+ (they cannot be marshalled into compiled code), we fake sets using hashes with
+ empty values:
+
+ @chunk[<hash-set/c>
+ (provide hash-set/c)
+ (define/contract (hash-set/c elem/c
+ #:kind [kind 'dont-care]
+ #:cmp [cmp 'dont-care])
+ (->* (chaperone-contract?)
+ (#:kind (or/c 'dont-care 'immutable 'mutable
+ 'weak 'mutable-or-weak)
+ #:cmp (or/c 'dont-care 'equal 'eqv 'eq))
+ contract?)
+ (define immutable
+ (case kind
+ [(immutable) #t]
+ [(dont-care) 'dont-care]
+ [else #f]))
+ (define h (hash/c elem/c
+ null?
+ #:immutable immutable))
+ (define cmp-contracts
+ (case cmp
+ [(dont-care) empty]
+ [(equal) (list hash-equal?)]
+ [(eqv) (list hash-eqv?)]
+ [(eq) (list hash-eq?)]))
+ (define weak-contracts
+ (case kind
+ [(weak) (list hash-weak?)]
+ ;; This is redundant as the mutable check is already included above
+ [(mutable-or-weak) (list (or/c hash-weak? (not/c immutable?)))]
+ [(dont-care) empty]
+ [else (list (not/c hash-weak?))]))
+ (if (empty? (append cmp-contracts weak-contracts))
+ h
+ (apply and/c (append (list h) cmp-contracts weak-contracts))))]
+
+ @chunk[<hash-set/c>
+ (provide equal-hash-set/c)
+ (define/contract (equal-hash-set/c elem/c
+ #:kind [kind 'dont-care])
+ (->* (chaperone-contract?)
+ (#:kind (or/c 'dont-care 'immutable 'mutable
+ 'weak 'mutable-or-weak))
+ contract?)
+ (hash-set/c elem/c #:kind kind #:cmp 'equal))]
+
+ @chunk[<hash-set/c>
+ (provide list->equal-hash-set)
+ (define/contract (list->equal-hash-set l)
+ (-> (listof any/c) (equal-hash-set/c any/c #:kind 'immutable))
+ (make-immutable-hash (map (λ (v) (cons v null)) l)))]
+}
@section{Graph builder information}
@@ -91,14 +96,18 @@ empty values:
[root-node identifier?]
[node-order (listof identifier?)]
[nodes (hash/c symbol? node-info? #:immutable #t)]
- [invariants (equal-hash-set/c invariant-info? #:kind 'immutable)])
+ [invariants (set/c invariant-info? #:kind 'immutable #:cmp 'equal)])
([multi-constructor identifier?]
[root-mapping identifier?]
[mapping-order (listof identifier?)]
[mappings (hash/c symbol? mapping-info? #:immutable #t)]
- [dependent-invariants (equal-hash-set/c dependent-invariant-info?
- #:kind 'immutable)])
- #:prefab)]
+ [dependent-invariants (set/c dependent-invariant-info?
+ #:kind 'immutable
+ #:cmp 'equal)])
+ #:transparent
+ #:methods gen:custom-write
+ [(define write-proc (struct-printer 'graph-builder-info))]
+ #:property prop:custom-print-quotable 'never)]
@section{Node information}
@@ -110,7 +119,10 @@ empty values:
[promise-type identifier?]
[make-incomplete-type identifier?]
[incomplete-type identifier?])
- #:prefab)]
+ #:transparent
+ #:methods gen:custom-write
+ [(define write-proc (struct-printer 'node-info))]
+ #:property prop:custom-print-quotable 'never)]
@section{Field information}
@@ -119,7 +131,10 @@ A field has a type.
@chunk[<field-info>
(struct+/contract field-info
([type identifier?])
- #:prefab)]
+ #:transparent
+ #:methods gen:custom-write
+ [(define write-proc (struct-printer 'field-info))]
+ #:property prop:custom-print-quotable 'never)]
@;[incomplete-type identifier?]
@@ -129,7 +144,10 @@ A field has a type.
(struct+/contract invariant-info
([predicate identifier?] ; (→ RootNode Boolean : +witness-type)
[witness-type identifier?])
- #:prefab)]
+ #:transparent
+ #:methods gen:custom-write
+ [(define write-proc (struct-printer 'invariant-info))]
+ #:property prop:custom-print-quotable 'never)]
@section{Dependent invariant information}
@@ -141,7 +159,10 @@ which relate the old and the new graph in a graph transformation.
(struct+/contract dependent-invariant-info
([checker identifier?] ; (→ RootMappingArguments… NewGraphRoot Boolean)
[name identifier?])
- #:prefab)]
+ #:transparent
+ #:methods gen:custom-write
+ [(define write-proc (struct-printer 'dependent-invariant-info))]
+ #:property prop:custom-print-quotable 'never)]
@section{Mapping information}
@@ -151,7 +172,10 @@ which relate the old and the new graph in a graph transformation.
[with-promises-type identifier?]
[make-placeholder-type identifier?]
[placeholder-type identifier?])
- #:prefab)]
+ #:transparent
+ #:methods gen:custom-write
+ [(define write-proc (struct-printer 'mapping-info))]
+ #:property prop:custom-print-quotable 'never)]
@section{Printing}
@@ -261,7 +285,7 @@ data.
[field contract]
...))))))))
- <hash-set/c>
+ ;<hash-set/c>
<printer>
<field-info>
diff --git a/graph-type.hl.rkt b/graph-type.hl.rkt
@@ -1,4 +1,4 @@
-#lang hyper-literate typed/racket #:no-auto-require
+#lang aful/unhygienic hyper-literate typed/racket #:no-auto-require
@require[scribble-math
scribble-enhanced/doc
@@ -45,20 +45,20 @@
[else
(old-print-convert-hook val basic-convert sub-convert)]))
- (define-syntax/parse (define-graph-type . :signature)
- (define gi <graph-info>)
+ (define-for-syntax compute-graph-info
+ (syntax-parser
+ [:signature <graph-info>]))
+ (define-syntax/parse (define-graph-type . whole:signature)
(local-require racket/pretty)
- #;(let ([old-print-convert-hook (current-print-convert-hook)])
- (parameterize ([constructor-style-printing #t]
- [show-sharing #f]
- [current-print-convert-hook
- (syntax-convert old-print-convert-hook)])
- (parameterize ([pretty-print-columns 188])
- (pretty-write (print-convert gi)))))
+ ;; fire off the eventual errors within macro-expansion.
+ (compute-graph-info #'whole)
#`(begin
- (define-syntax name #,gi)))]
+ (define-syntax whole.name
+ (compute-graph-info (quote-syntax whole)))))]
@chunk[<graph-info>
+ #:with (node-incompleteᵢ …) (stx-map #λ(format-id % " ~a-incomplete" %)
+ #'(nodeᵢ …))
(graph-info #'name
(syntax->list (if (attribute tvar) #'(tvar …) #'()))
#'root-node
@@ -66,10 +66,12 @@
(make-immutable-hash
(map cons
(stx-map syntax-e #'(nodeᵢ …))
- (stx-map (λ/syntax-case (nodeᵢ [fieldᵢⱼ τᵢⱼ] …) ()
+ (stx-map (λ/syntax-case (nodeᵢ node-incompleteᵢ
+ [fieldᵢⱼ τᵢⱼ] …) ()
<node-info>)
- #'([nodeᵢ [fieldᵢⱼ τᵢⱼ] …] …))))
- (list->equal-hash-set
+ #'([nodeᵢ node-incompleteᵢ
+ [fieldᵢⱼ τᵢⱼ] …] …))))
+ (list->set
(append
(stx-map (λ/syntax-case (op a b) () <invariant-info-op>)
#'([op a b] …))
@@ -110,7 +112,9 @@
phc-toolkit/untyped
(subtract-in syntax/parse phc-graph/subtemplate)
racket/set
- phc-graph/subtemplate-override))
+ phc-graph/subtemplate-override
+ racket/syntax)
+ (for-meta 2 racket/base))
(provide define-graph-type)
diff --git a/test/adt-pre-declarations.rkt b/test/adt-pre-declarations.rkt
@@ -10,3 +10,7 @@
(remembered! tagged-structure (node-incompleteᵢ houses name))
(remembered! tagged-structure (node-incompleteᵢ owner))
(remembered! tagged-structure (node-incompleteᵢ name))
+(remembered! tagged-structure (| City-incomplete| citizens name streets))
+(remembered! tagged-structure (| Street-incomplete| houses name))
+(remembered! tagged-structure (| House-incomplete| owner))
+(remembered! tagged-structure (| Person-incomplete| name))
diff --git a/test/test-graph-type.rkt b/test/test-graph-type.rkt
@@ -1,26 +1,21 @@
-#lang racket
+#lang typed/racket
-(define-syntax (mk stx)
- (syntax-case stx ()
- [(_ x)
- #`(define-syntax x
- #,(make-prefab-struct 's (hash)))]))
-(mk x)
-
-#|
(require phc-adt
(lib "phc-graph/graph-type.hl.rkt"))
(adt-init)
-#;(define-graph-type g1
- [City [name : String]
- [streets : (Listof Street)]
- [citizens : (Listof Person)]]
- [Street [name : String]
- [houses : (Listof House)]]
- [House [owner : Person]]
- [Person [name : String]]
- #:invariant City.citizens._ ∈ City.streets._.houses._.owner
- #:invariant City.citizens._ ∋ City.streets._.houses._.owner)
-|#
+(define-graph-type g1
+ [City [name : String]
+ [streets : (Listof Street)]
+ [citizens : (Listof Person)]]
+ [Street [name : String]
+ [houses : (Listof House)]]
+ [House [owner : Person]]
+ [Person [name : String]]
+ #:invariant City.citizens._ ∈ City.streets._.houses._.owner
+ #:invariant City.citizens._ ∋ City.streets._.houses._.owner)
+(begin-for-syntax
+ (require racket/pretty)
+ (parameterize ([pretty-print-columns 188])
+ (pretty-print (syntax-local-value #'g1))))
+\ No newline at end of file
