diff --git a/networks.rkt b/networks.rkt index 14747d8..f3a89ef 100644 --- a/networks.rkt +++ b/networks.rkt @@ -679,15 +679,18 @@ (: pretty-print-state-graph-with (-> Graph (-> Any Any) Graph)) (define (pretty-print-state-graph-with gr pprinter) - (define (e-pprinter/any [x : Any]) - (pretty-print-set-sets (assert-type x (Setof (Setof Any))))) - (update-graph gr #:v-func pprinter #:e-func e-pprinter/any)) + (update-graph + gr + #:v-func pprinter + #:e-func (relax-arg-type/any pretty-print-set-sets (Setof (Setof Any))))) (: pretty-print-state-graph (-> Graph Graph)) (define (pretty-print-state-graph gr) (define (pprinter/any [x : Any]) (pretty-print-state (assert-type x (State Any)))) - (pretty-print-state-graph-with gr pprinter/any)) + (pretty-print-state-graph-with + gr + (relax-arg-type/any pretty-print-state (State Any)))) (define ppsg pretty-print-state-graph) diff --git a/scribblings/utils.scrbl b/scribblings/utils.scrbl index 5af8c72..739968f 100644 --- a/scribblings/utils.scrbl +++ b/scribblings/utils.scrbl @@ -107,6 +107,21 @@ is abstract. (eval:error (send obj abstract-increment 1)) ]} +@defform[(relax-arg-type/any name arg-type)]{ + +Defines a unary anonymous function whose argument type is @racket[Any], and +which calls @racket[name], with the argument coerced to @racket[arg-type]. + +@ex[ +(relax-arg-type/any add1 Number) +] + +The main use of this macro is to allow easily passing different one-argument +functions as arguments of the type @racket[(-> Any Any)]. See for example +@racket[update-graph]. + +} + @section{Hashtable injection} This section defines some utilities to streamline the usage of hash tables diff --git a/utils.rkt b/utils.rkt index b55ba0c..7477c4b 100644 --- a/utils.rkt +++ b/utils.rkt @@ -7,6 +7,7 @@ Variable VariableMapping GeneralPair assert-type for/first/typed for*/first/typed define/abstract/error + relax-arg-type/any eval-with eval1-with auto-hash-ref/explicit auto-hash-ref/: extract-symbols any->string stringify-variable-mapping string->any handle-org-booleans map-sexp read-org-sexp unorg unstringify-pairs @@ -65,6 +66,9 @@ [(_ (name:id args:id ...)) #`(define/public (name args ...) (error 'name "abstract method"))]) +(define-syntax-parse-rule (relax-arg-type/any name:id arg-type:expr) + (λ ([x : Any]) (name (assert-type x arg-type)))) + (: eval-with (-> (VariableMapping Any) Any AnyValues)) (define (eval-with ht expr) (parameterize ([current-namespace (make-base-namespace)])