commit 3caeea4d9ff979113fd5f0acad7889c726f912af
parent 32ac4188a64a2c15d8f34b264a8b673cae67103e
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Wed, 18 Jan 2017 02:27:11 +0100
Fixed 3D syntax issues by using prefabs.
Diffstat:
2 files changed, 83 insertions(+), 37 deletions(-)
diff --git a/graph-info.hl.rkt b/graph-info.hl.rkt
@@ -24,11 +24,63 @@ 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 (set/c invariant-info? #:kind 'immutable)])
- #:transparent
- #:methods gen:custom-write
- [(define write-proc (struct-printer 'graph-info))]
- #:property prop:custom-print-quotable 'never)]
+ [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)))]
@section{Graph builder information}
@@ -39,16 +91,14 @@ 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 (set/c invariant-info? #:kind 'immutable)])
+ [invariants (equal-hash-set/c invariant-info? #:kind 'immutable)])
([multi-constructor identifier?]
[root-mapping identifier?]
[mapping-order (listof identifier?)]
[mappings (hash/c symbol? mapping-info? #:immutable #t)]
- [dependent-invariants (set/c dependent-invariant-info?)])
- #:transparent
- #:methods gen:custom-write
- [(define write-proc (struct-printer 'graph-builder-info))]
- #:property prop:custom-print-quotable 'never)]
+ [dependent-invariants (equal-hash-set/c dependent-invariant-info?
+ #:kind 'immutable)])
+ #:prefab)]
@section{Node information}
@@ -60,10 +110,7 @@ We define here the compile-time metadata describing a graph type.
[promise-type identifier?]
[make-incomplete-type identifier?]
[incomplete-type identifier?])
- #:transparent
- #:methods gen:custom-write
- [(define write-proc (struct-printer 'node-info))]
- #:property prop:custom-print-quotable 'never)]
+ #:prefab)]
@section{Field information}
@@ -72,10 +119,7 @@ A field has a type.
@chunk[<field-info>
(struct+/contract field-info
([type identifier?])
- #:transparent
- #:methods gen:custom-write
- [(define write-proc (struct-printer 'field-info))]
- #:property prop:custom-print-quotable 'never)]
+ #:prefab)]
@;[incomplete-type identifier?]
@@ -85,10 +129,7 @@ A field has a type.
(struct+/contract invariant-info
([predicate identifier?] ; (→ RootNode Boolean : +witness-type)
[witness-type identifier?])
- #:transparent
- #:methods gen:custom-write
- [(define write-proc (struct-printer 'invariant-info))]
- #:property prop:custom-print-quotable 'never)]
+ #:prefab)]
@section{Dependent invariant information}
@@ -100,10 +141,7 @@ which relate the old and the new graph in a graph transformation.
(struct+/contract dependent-invariant-info
([checker identifier?] ; (→ RootMappingArguments… NewGraphRoot Boolean)
[name identifier?])
- #:transparent
- #:methods gen:custom-write
- [(define write-proc (struct-printer 'dependent-invariant-info))]
- #:property prop:custom-print-quotable 'never)]
+ #:prefab)]
@section{Mapping information}
@@ -113,10 +151,7 @@ which relate the old and the new graph in a graph transformation.
[with-promises-type identifier?]
[make-placeholder-type identifier?]
[placeholder-type identifier?])
- #:transparent
- #:methods gen:custom-write
- [(define write-proc (struct-printer 'mapping-info))]
- #:property prop:custom-print-quotable 'never)]
+ #:prefab)]
@section{Printing}
@@ -191,7 +226,9 @@ data.
mzlib/pconvert
(for-syntax phc-toolkit/untyped
syntax/parse
- syntax/parse/experimental/template))
+ syntax/parse/experimental/template
+ racket/syntax))
+
(define-syntax/parse
(struct+/contract name {~optional parent}
{~optional ([parent-field parent-contract] ...)}
@@ -203,19 +240,28 @@ data.
_)
(~maybe #:property
{~literal prop:custom-print-quotable}
- _))))
+ _)))
+ {~optional {~and prefab #:prefab}})
+ #:with name/c (format-id #'name "~a/c" #'name)
(quasisyntax/top-loc this-syntax
#,(template
(begin
(struct name (?? parent) (field ...)
(?? transparent)
- methods+props ...)
- (provide (contract-out (struct (?? (name parent) name)
+ methods+props ...
+ (?? prefab))
+ (define name/c
+ (struct/c name
+ (?? (?@ parent-contract ...))
+ contract ...))
+ (provide name/c
+ (contract-out (struct (?? (name parent) name)
((?? (?@ [parent-field parent-contract]
...))
[field contract]
...))))))))
-
+
+ <hash-set/c>
<printer>
<field-info>
diff --git a/graph-type.hl.rkt b/graph-type.hl.rkt
@@ -44,7 +44,7 @@
(stx-map (λ/syntax-case (nodeᵢ [fieldᵢⱼ τᵢⱼ] …) ()
<node-info>)
#'([nodeᵢ [fieldᵢⱼ τᵢⱼ] …] …))))
- (list->set
+ (list->equal-hash-set
(append
(stx-map (λ/syntax-case (op a b) () <invariant-info-op>)
#'([op a b] …))
