Fixed storage of graph-info
This commit is contained in:
Georges Dupéron
parent
00c5471830
commit
f615ae243b
|
|
@ -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)]
|
||||
[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:
|
||||
@;{
|
||||
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 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 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)))]
|
||||
@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>
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
Loading…
Reference in New Issue
Block a user