165 lines
5.4 KiB
Racket
165 lines
5.4 KiB
Racket
#lang scribble/lp2
|
|
@(require "../lib/doc.rkt")
|
|
@doc-lib-setup
|
|
|
|
@title[#:style manual-doc-style]{Syntactic sugar for @racket[graph]: named
|
|
constructors}
|
|
|
|
@(table-of-contents)
|
|
|
|
@section{Introduction}
|
|
|
|
We define a wrapper around the @tc[graph] macro, which
|
|
|
|
@chunk[<signature>
|
|
(define-graph/multi-ctor name:id
|
|
((~commit [node:id <field-signature> …])
|
|
…)
|
|
(~commit <mapping-declaration>)
|
|
…)]
|
|
|
|
Where @tc[<field-signature>] is:
|
|
|
|
@chunk[<field-signature>
|
|
(~describe "[field : type]"
|
|
[field:id c:colon field-type:expr])]
|
|
|
|
And @tc[<mapping-declaration>] is:
|
|
|
|
@chunk[<mapping-declaration>
|
|
(~describe "[(mapping [param : type] …) : result . body]"
|
|
[(mapping:id [param:id :colon param-type:expr] …)
|
|
cm:colon result-node:id
|
|
. body])]
|
|
|
|
@chunk[<graph-multi-ctor>
|
|
(define-syntax/parse <signature>
|
|
(define-temp-ids "~a/wrapped" name)
|
|
(define-temp-ids "~a/mapping" (node …))
|
|
(define-temp-ids "~a/arg" (node …))
|
|
(define-temp-ids "~a/function" (mapping …))
|
|
(define-temp-ids "~a/hide" (node …))
|
|
(define-temp-ids "~a/hide" (result-node …))
|
|
(define/with-syntax ([(grouped-mapping
|
|
grouped-mapping/function
|
|
[(grouped-param . grouped-param-type) …]
|
|
grouped-result-node
|
|
grouped-body) …] …)
|
|
(stx-map (λ (n)
|
|
(multiassoc-syntax n #'((result-node
|
|
mapping
|
|
mapping/function
|
|
[(param . param-type) …]
|
|
result-node
|
|
body) …)))
|
|
#'(node …)))
|
|
(define/with-syntax (mapping/grouped …)
|
|
(stx-map (λ (mr) (cdr-assoc-syntax mr #'([node . node/mapping] …)))
|
|
#'(result-node …)))
|
|
(define/with-syntax all-nodes #'(node …))
|
|
|
|
; TODO: we should order the graph's nodes so that the root is
|
|
; the first one! (or add a #:root)
|
|
(define/with-syntax ((root-param …) . _) #'((param …) …))
|
|
(define/with-syntax ((root-param-type …) . _) #'((param-type …) …))
|
|
|
|
#`(debug
|
|
(begin
|
|
(define-graph name/wrapped
|
|
#:definitions
|
|
((define-multi-id name
|
|
#:type-expander
|
|
(λ (stx)
|
|
(syntax-case stx ()
|
|
[(_ . rest) #'(name/wrapped . rest)]))
|
|
#:else-id name/constructor)
|
|
(define (name/constructor [root-param : root-param-type] …)
|
|
(list name/wrapped root-param …))
|
|
<define-mappings>)
|
|
[node [field c field-type] …
|
|
((node/mapping [node/arg : <node-arg-type>])
|
|
<mapping-body>)]
|
|
…))))]
|
|
|
|
Where the type for the merged mapping is:
|
|
|
|
@chunk[<node-arg-type>
|
|
(U (List 'grouped-mapping grouped-param-type …) …)]
|
|
|
|
@chunk[<define-mappings>
|
|
(define (mapping/function node/hide … ; nodes
|
|
result-node/hide ; self
|
|
[param : param-type] …)
|
|
: (name result-node)
|
|
(let ([node node/hide] …)
|
|
(let ([result-node result-node/hide])
|
|
(? '<bdy>))))
|
|
…]
|
|
|
|
@chunk[<bdy>
|
|
(let ([node-names… node_]
|
|
;[mapping mapping/grouped] …
|
|
[node-name_ node_])
|
|
body)]
|
|
|
|
We then select in the grouped mapping which one to call.
|
|
|
|
@chunk[<mapping-body>
|
|
(let ((a node/arg))
|
|
(cond
|
|
[(eq? (car a) 'grouped-mapping)
|
|
(apply grouped-mapping/function
|
|
#,@#'(node …)
|
|
grouped-result-node
|
|
(cdr a))]
|
|
…))]
|
|
|
|
TODO: At the call site, use a macro and annotate the function (given by its
|
|
name) with the right type, so that the user doesn't see all the types in the
|
|
(U …).
|
|
|
|
@chunk[<test-graph-multi-ctor>
|
|
(check-equal? 42 42)]
|
|
|
|
@section{Conclusion}
|
|
|
|
@chunk[<module-main>
|
|
(module main typed/racket
|
|
(require (for-syntax syntax/parse
|
|
racket/syntax
|
|
syntax/stx
|
|
"../lib/low-untyped.rkt"
|
|
"../lib/low/multiassoc-syntax.rkt")
|
|
"../lib/low.rkt"
|
|
"graph.lp2.rkt"
|
|
"get.lp2.rkt"
|
|
"../type-expander/type-expander.lp2.rkt"
|
|
"../type-expander/multi-id.lp2.rkt")
|
|
(provide define-graph/multi-ctor)
|
|
|
|
(require (for-syntax racket/pretty))
|
|
(define-syntax (debug stx)
|
|
(syntax-case stx ()
|
|
[(_ body)
|
|
;; syntax->string
|
|
(pretty-print (syntax->datum #'body))
|
|
#'body]))
|
|
|
|
<graph-multi-ctor>)]
|
|
|
|
@chunk[<module-test>
|
|
(module* test typed/racket
|
|
(require (submod "..")
|
|
typed/rackunit)
|
|
|
|
<test-graph-multi-ctor>)]
|
|
|
|
@chunk[<*>
|
|
(begin
|
|
<module-main>
|
|
|
|
(require 'main)
|
|
(provide (all-from-out 'main))
|
|
|
|
<module-test>)]
|