suzanne.soy/phc-graph
1
0
Fork 0
Code Issues 24 Pull Requests Actions Packages Projects Releases Wiki Activity

Fixed storage of graph-info

Browse Source
This commit is contained in:
Georges Dupéron 2017-01-18 04:11:41 +01:00
parent 00c5471830
commit f615ae243b
4 changed files with 125 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

150
graph-info.hl.rkt
View File

@ -24,63 +24,68 @@ We define here the compile-time metadata describing a graph type.
[root-node identifier?] [root-node identifier?]
[node-order (listof identifier?)] [node-order (listof identifier?)]
[nodes (hash/c symbol? node-info? #:immutable #t)] [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)])
#:prefab)] #: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 Since sets created with @racket[set] cannot be used within syntax objects
empty values: (they cannot be marshalled into compiled code), we fake sets using hashes with
empty values:
@chunk[<hash-set/c> @chunk[<hash-set/c>
(provide hash-set/c) (provide hash-set/c)
(define/contract (hash-set/c elem/c (define/contract (hash-set/c elem/c
#:kind [kind 'dont-care] #:kind [kind 'dont-care]
#:cmp [cmp 'dont-care]) #:cmp [cmp 'dont-care])
(->* (chaperone-contract?) (->* (chaperone-contract?)
(#:kind (or/c 'dont-care 'immutable 'mutable (#:kind (or/c 'dont-care 'immutable 'mutable
'weak 'mutable-or-weak) 'weak 'mutable-or-weak)
#:cmp (or/c 'dont-care 'equal 'eqv 'eq)) #:cmp (or/c 'dont-care 'equal 'eqv 'eq))
contract?) contract?)
(define immutable (define immutable
(case kind (case kind
[(immutable) #t] [(immutable) #t]
[(dont-care) 'dont-care] [(dont-care) 'dont-care]
[else #f])) [else #f]))
(define h (hash/c elem/c (define h (hash/c elem/c
null? null?
#:immutable immutable)) #:immutable immutable))
(define cmp-contracts (define cmp-contracts
(case cmp (case cmp
[(dont-care) empty] [(dont-care) empty]
[(equal) (list hash-equal?)] [(equal) (list hash-equal?)]
[(eqv) (list hash-eqv?)] [(eqv) (list hash-eqv?)]
[(eq) (list hash-eq?)])) [(eq) (list hash-eq?)]))
(define weak-contracts (define weak-contracts
(case kind (case kind
[(weak) (list hash-weak?)] [(weak) (list hash-weak?)]
;; This is redundant as the mutable check is already included above ;; This is redundant as the mutable check is already included above
[(mutable-or-weak) (list (or/c hash-weak? (not/c immutable?)))] [(mutable-or-weak) (list (or/c hash-weak? (not/c immutable?)))]
[(dont-care) empty] [(dont-care) empty]
[else (list (not/c hash-weak?))])) [else (list (not/c hash-weak?))]))
(if (empty? (append cmp-contracts weak-contracts)) (if (empty? (append cmp-contracts weak-contracts))
h h
(apply and/c (append (list h) cmp-contracts weak-contracts))))] (apply and/c (append (list h) cmp-contracts weak-contracts))))]
@chunk[<hash-set/c> @chunk[<hash-set/c>
(provide equal-hash-set/c) (provide equal-hash-set/c)
(define/contract (equal-hash-set/c elem/c (define/contract (equal-hash-set/c elem/c
#:kind [kind 'dont-care]) #:kind [kind 'dont-care])
(->* (chaperone-contract?) (->* (chaperone-contract?)
(#:kind (or/c 'dont-care 'immutable 'mutable (#:kind (or/c 'dont-care 'immutable 'mutable
'weak 'mutable-or-weak)) 'weak 'mutable-or-weak))
contract?) contract?)
(hash-set/c elem/c #:kind kind #:cmp 'equal))] (hash-set/c elem/c #:kind kind #:cmp 'equal))]
@chunk[<hash-set/c> @chunk[<hash-set/c>
(provide list->equal-hash-set) (provide list->equal-hash-set)
(define/contract (list->equal-hash-set l) (define/contract (list->equal-hash-set l)
(-> (listof any/c) (equal-hash-set/c any/c #:kind 'immutable)) (-> (listof any/c) (equal-hash-set/c any/c #:kind 'immutable))
(make-immutable-hash (map (λ (v) (cons v null)) l)))] (make-immutable-hash (map (λ (v) (cons v null)) l)))]
}
@section{Graph builder information} @section{Graph builder information}
@ -91,14 +96,18 @@ empty values:
[root-node identifier?] [root-node identifier?]
[node-order (listof identifier?)] [node-order (listof identifier?)]
[nodes (hash/c symbol? node-info? #:immutable #t)] [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?] ([multi-constructor identifier?]
[root-mapping identifier?] [root-mapping identifier?]
[mapping-order (listof identifier?)] [mapping-order (listof identifier?)]
[mappings (hash/c symbol? mapping-info? #:immutable #t)] [mappings (hash/c symbol? mapping-info? #:immutable #t)]
[dependent-invariants (equal-hash-set/c dependent-invariant-info? [dependent-invariants (set/c dependent-invariant-info?
#:kind 'immutable)]) #:kind 'immutable
#:prefab)] #:cmp 'equal)])
#:transparent
#:methods gen:custom-write
[(define write-proc (struct-printer 'graph-builder-info))]
#:property prop:custom-print-quotable 'never)]
@section{Node information} @section{Node information}
@ -110,7 +119,10 @@ empty values:
[promise-type identifier?] [promise-type identifier?]
[make-incomplete-type identifier?] [make-incomplete-type identifier?]
[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} @section{Field information}
@ -119,7 +131,10 @@ A field has a type.
@chunk[<field-info> @chunk[<field-info>
(struct+/contract field-info (struct+/contract field-info
([type identifier?]) ([type identifier?])
#:prefab)] #:transparent
#:methods gen:custom-write
[(define write-proc (struct-printer 'field-info))]
#:property prop:custom-print-quotable 'never)]
@;[incomplete-type identifier?] @;[incomplete-type identifier?]
@ -129,7 +144,10 @@ A field has a type.
(struct+/contract invariant-info (struct+/contract invariant-info
([predicate identifier?] ; (→ RootNode Boolean : +witness-type) ([predicate identifier?] ; (→ RootNode Boolean : +witness-type)
[witness-type identifier?]) [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} @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 (struct+/contract dependent-invariant-info
([checker identifier?] ; (→ RootMappingArguments… NewGraphRoot Boolean) ([checker identifier?] ; (→ RootMappingArguments… NewGraphRoot Boolean)
[name identifier?]) [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} @section{Mapping information}
@ -151,7 +172,10 @@ which relate the old and the new graph in a graph transformation.
[with-promises-type identifier?] [with-promises-type identifier?]
[make-placeholder-type identifier?] [make-placeholder-type identifier?]
[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} @section{Printing}
@ -261,7 +285,7 @@ data.
[field contract] [field contract]
...)))))))) ...))))))))
<hash-set/c> ;<hash-set/c>
<printer> <printer>
<field-info> <field-info>

34
graph-type.hl.rkt
View File

@ -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 @require[scribble-math
scribble-enhanced/doc scribble-enhanced/doc
@ -45,20 +45,20 @@
[else [else
(old-print-convert-hook val basic-convert sub-convert)])) (old-print-convert-hook val basic-convert sub-convert)]))
(define-syntax/parse (define-graph-type . :signature) (define-for-syntax compute-graph-info
(define gi <graph-info>) (syntax-parser
[:signature <graph-info>]))
(define-syntax/parse (define-graph-type . whole:signature)
(local-require racket/pretty) (local-require racket/pretty)
#;(let ([old-print-convert-hook (current-print-convert-hook)]) ;; fire off the eventual errors within macro-expansion.
(parameterize ([constructor-style-printing #t] (compute-graph-info #'whole)
[show-sharing #f]
[current-print-convert-hook
(syntax-convert old-print-convert-hook)])
(parameterize ([pretty-print-columns 188])
(pretty-write (print-convert gi)))))
#`(begin #`(begin
(define-syntax name #,gi)))] (define-syntax whole.name
(compute-graph-info (quote-syntax whole)))))]
@chunk[<graph-info> @chunk[<graph-info>
#:with (node-incompleteᵢ …) (stx-map #λ(format-id % " ~a-incomplete" %)
#'(nodeᵢ …))
(graph-info #'name (graph-info #'name
(syntax->list (if (attribute tvar) #'(tvar …) #'())) (syntax->list (if (attribute tvar) #'(tvar …) #'()))
#'root-node #'root-node
@ -66,10 +66,12 @@
(make-immutable-hash (make-immutable-hash
(map cons (map cons
(stx-map syntax-e #'(nodeᵢ …)) (stx-map syntax-e #'(nodeᵢ …))
(stx-map (λ/syntax-case (nodeᵢ [fieldᵢⱼ τᵢⱼ] …) () (stx-map (λ/syntax-case (nodeᵢ node-incompleteᵢ
[fieldᵢⱼ τᵢⱼ] …) ()
<node-info>) <node-info>)
#'([nodeᵢ [fieldᵢⱼ τᵢⱼ] …] …)))) #'([nodeᵢ node-incompleteᵢ
(list->equal-hash-set [fieldᵢⱼ τᵢⱼ] …] …))))
(list->set
(append (append
(stx-map (λ/syntax-case (op a b) () <invariant-info-op>) (stx-map (λ/syntax-case (op a b) () <invariant-info-op>)
#'([op a b] …)) #'([op a b] …))
@ -110,7 +112,9 @@
phc-toolkit/untyped phc-toolkit/untyped
(subtract-in syntax/parse phc-graph/subtemplate) (subtract-in syntax/parse phc-graph/subtemplate)
racket/set racket/set
phc-graph/subtemplate-override)) phc-graph/subtemplate-override
racket/syntax)
(for-meta 2 racket/base))
(provide define-graph-type) (provide define-graph-type)

4
test/adt-pre-declarations.rkt
View File

@ -10,3 +10,7 @@
(remembered! tagged-structure (node-incompleteᵢ houses name)) (remembered! tagged-structure (node-incompleteᵢ houses name))
(remembered! tagged-structure (node-incompleteᵢ owner)) (remembered! tagged-structure (node-incompleteᵢ owner))
(remembered! tagged-structure (node-incompleteᵢ name)) (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))

35
test/test-graph-type.rkt
View File

@ -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 (require phc-adt
(lib "phc-graph/graph-type.hl.rkt")) (lib "phc-graph/graph-type.hl.rkt"))
(adt-init) (adt-init)
#;(define-graph-type g1 (define-graph-type g1
[City [name : String] [City [name : String]
[streets : (Listof Street)] [streets : (Listof Street)]
[citizens : (Listof Person)]] [citizens : (Listof Person)]]
[Street [name : String] [Street [name : String]
[houses : (Listof House)]] [houses : (Listof House)]]
[House [owner : Person]] [House [owner : Person]]
[Person [name : String]] [Person [name : String]]
#:invariant City.citizens._ ∈ City.streets._.houses._.owner #:invariant City.citizens._ ∈ City.streets._.houses._.owner
#: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))))