From 3caeea4d9ff979113fd5f0acad7889c726f912af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Wed, 18 Jan 2017 02:27:11 +0100 Subject: [PATCH] Fixed 3D syntax issues by using prefabs. --- graph-info.hl.rkt | 118 ++++++++++++++++++++++++++++++++-------------- graph-type.hl.rkt | 2 +- 2 files changed, 83 insertions(+), 37 deletions(-) diff --git a/graph-info.hl.rkt b/graph-info.hl.rkt index e070cad..0f580a0 100644 --- 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[ + (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[ + (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[ + (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[ (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] ...)))))))) - + + diff --git a/graph-type.hl.rkt b/graph-type.hl.rkt index edf4968..d0f8710 100644 --- a/graph-type.hl.rkt +++ b/graph-type.hl.rkt @@ -44,7 +44,7 @@ (stx-map (λ/syntax-case (nodeᵢ [fieldᵢⱼ τᵢⱼ] …) () ) #'([nodeᵢ [fieldᵢⱼ τᵢⱼ] …] …)))) - (list->set + (list->equal-hash-set (append (stx-map (λ/syntax-case (op a b) () ) #'([op a b] …))