57 lines
1.7 KiB
Racket
57 lines
1.7 KiB
Racket
#lang turnstile
|
|
|
|
(provide Observe★
|
|
RoleNTimes
|
|
(for-syntax RoleNTimes*))
|
|
|
|
(require "core-types.rkt")
|
|
(require turnstile/typedefs)
|
|
|
|
(define-syntax (Observe★ stx)
|
|
(define star (type-eval #'★/t))
|
|
(syntax-parse stx
|
|
[(_ TyCons:id)
|
|
#:do [(define arity? (get-type-arity #'TyCons))]
|
|
#:when arity?
|
|
(mk-Observe- (list (reassemble-type #'TyCons (make-list (arity-min arity?) star))))]
|
|
[(_ t)
|
|
#:with (~Any/new TyCons τ ...) (type-eval #'t)
|
|
#:when (reassemblable? #'TyCons)
|
|
(mk-Observe- (list (reassemble-type #'TyCons (stx-map (lambda (_) star) #'(τ ...)))))]
|
|
[_
|
|
(raise-syntax-error #f "Not a type that can automatically be subscribed to" stx)]))
|
|
|
|
(begin-for-syntax
|
|
;; Arity -> Nat
|
|
(define (arity-min a)
|
|
(match a
|
|
[(arity-eq n) n]
|
|
[(arity-ge n) n])))
|
|
|
|
(define-for-syntax (RoleNTimes* n Step behav)
|
|
(let loop ([i 1])
|
|
(define nm (format-id behav "step~a" i))
|
|
(quasisyntax/loc behav
|
|
(Role (#,nm)
|
|
#,@(if (= i 1)
|
|
(list #'(Shares Unit))
|
|
(list))
|
|
(Reacts #,(if (= i 1)
|
|
#'(Asserted Unit)
|
|
#`(Message #,Step))
|
|
#,@(if (= i n)
|
|
(list)
|
|
(list #`(Sends #,Step))))
|
|
(Reacts (Message #,Step)
|
|
(Effs #,behav
|
|
(Stop #,nm
|
|
#,@(if (< i n)
|
|
(if (= i 1)
|
|
(list #`(Sends #,Step) (loop (add1 i)))
|
|
(list (loop (add1 i))))
|
|
(list)))))))))
|
|
|
|
(define-syntax-parser RoleNTimes
|
|
[(_ ~! n:nat Step:type behav:type)
|
|
(RoleNTimes* (syntax-e #'n) #'Step.norm #'behav.norm)])
|