id manipulation, inject-syntax*
This commit is contained in:
Matthew Butterick
parent
c59b34f868
commit
2d5db8afb5
127
beautiful-racket-lib/br/scope.rkt
Normal file
127
beautiful-racket-lib/br/scope.rkt
Normal file
|
|
@ -0,0 +1,127 @@
|
|||
#lang racket/base
|
||||
(require (for-syntax racket/base br/syntax racket/syntax) syntax/strip-context racket/function)
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define (->syntax x)
|
||||
(if (syntax? x) x (datum->syntax #f x)))
|
||||
|
||||
|
||||
(define (context stx)
|
||||
(hash-ref (syntax-debug-info stx) 'context))
|
||||
|
||||
(define-syntax-rule (scopes stx)
|
||||
(format "~a = ~a" 'stx
|
||||
(cons (syntax->datum stx)
|
||||
(for/list ([scope (in-list (context stx))])
|
||||
scope))))
|
||||
|
||||
(define (syntax-find stx stx-or-datum)
|
||||
(unless (syntax? stx)
|
||||
(raise-argument-error 'syntax-find "not given syntax object as first argument" stx))
|
||||
(define datum
|
||||
(cond [(syntax? stx-or-datum) (syntax->datum stx-or-datum)]
|
||||
[(symbol? stx-or-datum) stx-or-datum]
|
||||
[else (raise-argument-error 'syntax-find "not given syntax or datum as second argument" stx-or-datum)]))
|
||||
(let/ec exit
|
||||
(let loop ([so stx])
|
||||
(cond
|
||||
[(eq? (syntax->datum so) datum) (exit so)]
|
||||
[(syntax->list so) => (curry map loop)]))))
|
||||
|
||||
(define-syntax (define-scope stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
#'(define-scope id ())]
|
||||
[(_ id scope-ids)
|
||||
(with-syntax ([id-sis (suffix-id #'id "-sis")]
|
||||
[add-id (prefix-id "add-" #'id)]
|
||||
[flip-id (prefix-id "flip-" #'id)]
|
||||
[id-binding-form (suffix-id #'id "-binding-form")]
|
||||
[define-id (prefix-id "define-" #'id)]
|
||||
[with-id-identifiers (infix-id "with-" #'id "-identifiers")]
|
||||
[let-id-syntax (infix-id "let-" #'id "-syntax")]
|
||||
[with-id-binding-form (infix-id "with-" #'id "-binding-form")]
|
||||
[remove-id (prefix-id "remove-" #'id)]
|
||||
[id? (suffix-id #'id "?")]
|
||||
[id* (suffix-id #'id "*")]
|
||||
[(scope-id-sis ...) (suffix-ids #'scope-ids "-sis")])
|
||||
#'(begin
|
||||
(define id-sis
|
||||
(let ([sis-in (list scope-id-sis ...)])
|
||||
(if (pair? sis-in)
|
||||
(apply append sis-in)
|
||||
(list
|
||||
(let ([si (make-syntax-introducer #t)])
|
||||
(list (procedure-rename (curryr si 'add) 'add-id)
|
||||
(procedure-rename (curryr si 'flip) 'flip-id)
|
||||
(procedure-rename (curryr si 'remove) 'remove-id)))))))
|
||||
(define add-id (λ(x) ((apply compose1 (map car id-sis)) (->syntax x))))
|
||||
(define flip-id (λ(x) ((apply compose1 (map cadr id-sis)) (->syntax x))))
|
||||
(define remove-id (λ(x) ((apply compose1 (map caddr id-sis)) (->syntax x))))
|
||||
(define (id x) (add-id (datum->syntax #f (syntax-e (->syntax x)))))
|
||||
(define (id-binding-form x) (syntax-local-introduce (id x)))
|
||||
(define (id* x) (replace-context (add-id (datum->syntax #f '_)) (->syntax x)))
|
||||
(define (id? x)
|
||||
(and
|
||||
(member (car (context (add-id (datum->syntax #f '_))))
|
||||
(context (->syntax x)))
|
||||
#t))
|
||||
(define-syntax-rule (with-id-identifiers (name (... ...)) . body)
|
||||
(with-syntax ([name (id* 'name)] (... ...)) . body))
|
||||
(define-syntax-rule (with-id-binding-form (name (... ...)) . body)
|
||||
(with-syntax ([name (id-binding-form 'name)] (... ...)) . body))
|
||||
(define-syntax-rule (let-id-syntax ([pat val] (... ...)) . body)
|
||||
(let-syntax ([pat (id* val)] (... ...)) . body))))]))
|
||||
|
||||
(define (scopes-equal? stxl stxr)
|
||||
;; "A bound-identifier=? comparison checks that two identifiers have exactly the same scope sets"
|
||||
(bound-identifier=? (datum->syntax stxl '_) (datum->syntax stxr '_)))
|
||||
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(define-scope red)
|
||||
|
||||
(define stx (datum->syntax #f 'x))
|
||||
|
||||
(define red-stx (add-red stx))
|
||||
(define double-red-stx (add-red (add-red stx)))
|
||||
|
||||
|
||||
(check-false (red? stx))
|
||||
(check-true (red? red-stx))
|
||||
(check-true (red? double-red-stx))
|
||||
(check-false (scopes-equal? stx red-stx))
|
||||
(check-true (scopes-equal? red-stx double-red-stx))
|
||||
(check-false (scopes-equal? red-stx (remove-red double-red-stx)))
|
||||
|
||||
|
||||
(define-scope blue) ; scope addition is commutative
|
||||
(define blue-stx (blue stx))
|
||||
(check-true (scopes-equal? (add-blue red-stx) (add-red blue-stx)))
|
||||
(check-true (scopes-equal? (remove-red (add-blue red-stx)) (remove-red (add-red blue-stx))))
|
||||
|
||||
|
||||
(define-scope green) ; replace scopes at outer layer
|
||||
(check-true (scopes-equal? (green red-stx) (green blue-stx)))
|
||||
|
||||
|
||||
;; replace scopes everywhere
|
||||
(check-true (scopes-equal? (car (syntax->list (green* #`(#,blue-stx #,red-stx))))
|
||||
(car (syntax->list (green* #`(#,red-stx #,blue-stx))))))
|
||||
|
||||
;; todo: test flipping
|
||||
|
||||
|
||||
(define-scope purple (red blue))
|
||||
|
||||
(check-true (purple? (add-purple stx)))
|
||||
(check-true (scopes-equal? (purple (green stx)) (add-blue (remove-green (add-red (add-green (add-blue stx))))))))
|
||||
|
||||
|
||||
(define-syntax (with-scopes stx)
|
||||
(syntax-case stx (syntax)
|
||||
[(_ (scope-id) (syntax expr))
|
||||
(with-syntax ([add-scope-id (format-id #'scope-id "add-~a" #'scope-id)])
|
||||
#'(add-scope-id expr))]))
|
||||
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
#lang br
|
||||
(require (for-syntax br/syntax))
|
||||
(require (for-syntax br/scope))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-scope blue))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
#lang br
|
||||
(require (for-syntax br/syntax sugar/debug) br/syntax)
|
||||
(require (for-syntax br/syntax sugar/debug br/scope) br/syntax br/scope)
|
||||
|
||||
(begin-for-syntax
|
||||
(define-scope blue)
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@
|
|||
#'(syntax-case stx-arg ()
|
||||
[pattern body ...] ...)]))
|
||||
|
||||
(define-syntax (add-syntax stx)
|
||||
(define-syntax (inject-syntax stx)
|
||||
;; todo: permit mixing of two-arg and one-arg binding forms
|
||||
;; one-arg form allows you to inject an existing syntax object using its current name
|
||||
(syntax-case stx (syntax)
|
||||
|
|
@ -20,171 +20,74 @@
|
|||
[(_ ([sid] ...) body ...)
|
||||
#'(with-syntax ([sid sid] ...) body ...)]))
|
||||
|
||||
(define-syntax syntax-let (make-rename-transformer #'add-syntax))
|
||||
|
||||
(define-syntax inject-syntax (make-rename-transformer #'add-syntax))
|
||||
|
||||
(define-syntax (map-syntax stx)
|
||||
(define-syntax (inject-syntax* stx)
|
||||
(syntax-case stx ()
|
||||
[(_ _proc _args)
|
||||
#'(let ([args _args])
|
||||
(unless (and (syntax? args) (list? (syntax-e args)))
|
||||
(raise-argument-error 'map-syntax "not a syntax list"))
|
||||
(for/list ([arg (in-list (syntax->list args))])
|
||||
(_proc arg)))]))
|
||||
[(_ () . body) #'(begin . body)]
|
||||
[(_ (stx-expr0 stx-expr ...) . body)
|
||||
#'(inject-syntax (stx-expr0)
|
||||
(inject-syntax* (stx-expr ...) . body))]))
|
||||
|
||||
(define-syntax syntax-let (make-rename-transformer #'inject-syntax))
|
||||
(define-syntax add-syntax (make-rename-transformer #'inject-syntax))
|
||||
|
||||
|
||||
(define (check-syntax-list-argument caller-name arg)
|
||||
(cond
|
||||
[(and (syntax? arg) (syntax->list arg))]
|
||||
[(list? arg) arg]
|
||||
[else (raise-argument-error caller-name "list of syntax, or syntaxed list" arg)]))
|
||||
|
||||
|
||||
(define identity (λ(arg) arg))
|
||||
(define-syntax-rule (syntax-case-partition _stx-list _literals . _matchers)
|
||||
(partition (λ(stx-item)
|
||||
(with-handlers ([exn:fail:syntax? (λ (exn) #f)])
|
||||
(syntax-case stx-item _literals
|
||||
. _matchers))) (if (syntax? _stx-list)
|
||||
(syntax->list _stx-list)
|
||||
_stx-list)))
|
||||
. _matchers))) (check-syntax-list-argument 'syntax-case-partition _stx-list)))
|
||||
|
||||
|
||||
(define-syntax-rule (syntax-case-filter _stx-list _literals . _matchers)
|
||||
(let-values ([(matches others) (syntax-case-partition _stx-list _literals . _matchers)])
|
||||
matches))
|
||||
(filter (λ(stx-item)
|
||||
(with-handlers ([exn:fail:syntax? (λ (exn) #f)])
|
||||
(syntax-case stx-item _literals
|
||||
. _matchers))) (check-syntax-list-argument 'syntax-case-filter _stx-list)))
|
||||
|
||||
|
||||
(define-syntax-rule (syntax-case-map _stx-list _literals . _matchers)
|
||||
(map (λ(stx-item)
|
||||
(syntax-case stx-item _literals
|
||||
. _matchers)) (if (syntax? _stx-list)
|
||||
(syntax->list _stx-list)
|
||||
_stx-list)))
|
||||
. _matchers)) (check-syntax-list-argument 'syntax-case-map _stx-list)))
|
||||
|
||||
|
||||
(define-syntax-rule (reformat-id fmt id0 id ...)
|
||||
(format-id id0 fmt id0 id ...))
|
||||
|
||||
|
||||
#;(define-syntax syntax-variable (make-rename-transformer #'format-id))
|
||||
|
||||
(define (context stx)
|
||||
(hash-ref (syntax-debug-info stx) 'context))
|
||||
|
||||
(define-syntax-rule (scopes stx)
|
||||
(format "~a = ~a" 'stx
|
||||
(cons (syntax->datum stx)
|
||||
(for/list ([scope (in-list (context stx))])
|
||||
scope))))
|
||||
|
||||
(define (syntax-find stx stx-or-datum)
|
||||
(unless (syntax? stx)
|
||||
(raise-argument-error 'syntax-find "not given syntax object as first argument" stx))
|
||||
(define datum
|
||||
(cond [(syntax? stx-or-datum) (syntax->datum stx-or-datum)]
|
||||
[(symbol? stx-or-datum) stx-or-datum]
|
||||
[else (raise-argument-error 'syntax-find "not given syntax or datum as second argument" stx-or-datum)]))
|
||||
(let/ec exit
|
||||
(let loop ([so stx])
|
||||
(cond
|
||||
[(eq? (syntax->datum so) datum) (exit so)]
|
||||
[(syntax->list so) => (curry map loop)]))))
|
||||
(define-syntax-rule (format-string fmt id0 id ...)
|
||||
(datum->syntax id0 (format fmt (syntax->datum id0) (syntax->datum id) ...)))
|
||||
|
||||
|
||||
(define (->syntax x)
|
||||
(if (syntax? x) x (datum->syntax #f x)))
|
||||
|
||||
|
||||
(define-syntax (define-scope stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
#'(define-scope id ())]
|
||||
[(_ id scope-ids)
|
||||
(with-syntax ([id-sis (format-id #'id "~a-sis" #'id)]
|
||||
[add-id (format-id #'id "add-~a" #'id)]
|
||||
[flip-id (format-id #'id "flip-~a" #'id)]
|
||||
[id-binding-form (format-id #'id "~a-binding-form" #'id)]
|
||||
[define-id (format-id #'id "define-~a" #'id)]
|
||||
[with-id-identifiers (format-id #'id "with-~a-identifiers" #'id)]
|
||||
[let-id-syntax (format-id #'id "let-~a-syntax" #'id)]
|
||||
[with-id-binding-form (format-id #'id "with-~a-binding-form" #'id)]
|
||||
[remove-id (format-id #'id "remove-~a" #'id)]
|
||||
[id? (format-id #'id "~a?" #'id)]
|
||||
[id* (format-id #'id "~a*" #'id)]
|
||||
[(scope-id-sis ...) (map (λ(sid) (format-id sid "~a-sis" sid)) (syntax->list #'scope-ids))])
|
||||
#'(begin
|
||||
(define id-sis
|
||||
(let ([sis-in (list scope-id-sis ...)])
|
||||
(if (pair? sis-in)
|
||||
(apply append sis-in)
|
||||
(list
|
||||
(let ([si (make-syntax-introducer #t)])
|
||||
(list (procedure-rename (curryr si 'add) 'add-id)
|
||||
(procedure-rename (curryr si 'flip) 'flip-id)
|
||||
(procedure-rename (curryr si 'remove) 'remove-id)))))))
|
||||
(define add-id (λ(x) ((apply compose1 (map car id-sis)) (->syntax x))))
|
||||
(define flip-id (λ(x) ((apply compose1 (map cadr id-sis)) (->syntax x))))
|
||||
(define remove-id (λ(x) ((apply compose1 (map caddr id-sis)) (->syntax x))))
|
||||
(define (id x) (add-id (datum->syntax #f (syntax-e (->syntax x)))))
|
||||
(define (id-binding-form x) (syntax-local-introduce (id x)))
|
||||
(define (id* x) (replace-context (add-id (datum->syntax #f '_)) (->syntax x)))
|
||||
(define (id? x)
|
||||
(and
|
||||
(member (car (context (add-id (datum->syntax #f '_))))
|
||||
(context (->syntax x)))
|
||||
#t))
|
||||
(define-syntax-rule (with-id-identifiers (name (... ...)) . body)
|
||||
(with-syntax ([name (id* 'name)] (... ...)) . body))
|
||||
(define-syntax-rule (with-id-binding-form (name (... ...)) . body)
|
||||
(with-syntax ([name (id-binding-form 'name)] (... ...)) . body))
|
||||
(define-syntax-rule (let-id-syntax ([pat val] (... ...)) . body)
|
||||
(let-syntax ([pat (id* val)] (... ...)) . body))))]))
|
||||
|
||||
(define (scopes-equal? stxl stxr)
|
||||
;; "A bound-identifier=? comparison checks that two identifiers have exactly the same scope sets"
|
||||
(bound-identifier=? (datum->syntax stxl '_) (datum->syntax stxr '_)))
|
||||
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(define-scope red)
|
||||
|
||||
(define stx (datum->syntax #f 'x))
|
||||
|
||||
(define red-stx (add-red stx))
|
||||
(define double-red-stx (add-red (add-red stx)))
|
||||
|
||||
|
||||
(check-false (red? stx))
|
||||
(check-true (red? red-stx))
|
||||
(check-true (red? double-red-stx))
|
||||
(check-false (scopes-equal? stx red-stx))
|
||||
(check-true (scopes-equal? red-stx double-red-stx))
|
||||
(check-false (scopes-equal? red-stx (remove-red double-red-stx)))
|
||||
|
||||
|
||||
(define-scope blue) ; scope addition is commutative
|
||||
(define blue-stx (blue stx))
|
||||
(check-true (scopes-equal? (add-blue red-stx) (add-red blue-stx)))
|
||||
(check-true (scopes-equal? (remove-red (add-blue red-stx)) (remove-red (add-red blue-stx))))
|
||||
|
||||
|
||||
(define-scope green) ; replace scopes at outer layer
|
||||
(check-true (scopes-equal? (green red-stx) (green blue-stx)))
|
||||
|
||||
|
||||
;; replace scopes everywhere
|
||||
(check-true (scopes-equal? (car (syntax->list (green* #`(#,blue-stx #,red-stx))))
|
||||
(car (syntax->list (green* #`(#,red-stx #,blue-stx))))))
|
||||
|
||||
;; todo: test flipping
|
||||
|
||||
|
||||
(define-scope purple (red blue))
|
||||
|
||||
(check-true (purple? (add-purple stx)))
|
||||
(check-true (scopes-equal? (purple (green stx)) (add-blue (remove-green (add-red (add-green (add-blue stx))))))))
|
||||
|
||||
|
||||
(define-syntax (with-scopes stx)
|
||||
(syntax-case stx (syntax)
|
||||
[(_ (scope-id) (syntax expr))
|
||||
(with-syntax ([add-scope-id (format-id #'scope-id "add-~a" #'scope-id)])
|
||||
#'(add-scope-id expr))]))
|
||||
(define-syntax-rule (->unsyntax x)
|
||||
(if (syntax? x)
|
||||
(syntax->datum x)
|
||||
x))
|
||||
|
||||
(define-syntax-rule (prefix-id _prefix ... _base)
|
||||
(format-id _base "~a~a" (string-append (format "~a" (->unsyntax _prefix)) ...) _base))
|
||||
|
||||
(define-syntax-rule (prefix-ids _prefix ... _bases)
|
||||
(syntax-case-map _bases ()
|
||||
[_base (prefix-id _prefix ... #'_base)]))
|
||||
|
||||
(define-syntax-rule (infix-id _prefix _base _suffix ...)
|
||||
(format-id _base "~a~a~a" (->unsyntax _prefix) _base (string-append (format "~a" (->unsyntax _suffix)) ...)))
|
||||
|
||||
(define-syntax-rule (infix-ids _prefix _bases _suffix ...)
|
||||
(syntax-case-map _bases ()
|
||||
[_base (infix-id _prefix #'_base _suffix ...)]))
|
||||
|
||||
(define-syntax-rule (suffix-id _base _suffix ...)
|
||||
(infix-id "" _base _suffix ...))
|
||||
|
||||
(define-syntax-rule (suffix-ids _bases _suffix ...)
|
||||
(infix-ids "" _bases _suffix ...))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -4,29 +4,26 @@
|
|||
|
||||
|
||||
(define #'(chip-program _chipname
|
||||
(in-spec (_input-pin _input-width ...) ...)
|
||||
(out-spec (_output-pin _output-width ...) ...)
|
||||
(in-spec (_in-bus _in-width ...) ...)
|
||||
(out-spec (_out-bus _out-width ...) ...)
|
||||
_part ...)
|
||||
(with-syntax* ([chip-prefix (reformat-id "~a-" #'_chipname)]
|
||||
[(in-pin-write ...) (syntax-case-map #'(_input-pin ...) ()
|
||||
[iw (reformat-id "~a-write" #'iw)])]
|
||||
[(prefixed-output-pin ...) (syntax-case-map #'(_output-pin ...) ()
|
||||
[op (format-id #'op "~a~a" #'chip-prefix #'op)])])
|
||||
#'(begin
|
||||
(provide (prefix-out chip-prefix (combine-out _input-pin ... in-pin-write ...)))
|
||||
(define-input-bus _input-pin _input-width ...) ...
|
||||
_part ...
|
||||
(provide prefixed-output-pin ...)
|
||||
(define-output-bus prefixed-output-pin _output-pin _output-width ...) ...)))
|
||||
(inject-syntax* ([#'_chip-prefix (suffix-id #'_chipname "-")]
|
||||
[#'(_in-bus-write ...) (suffix-ids #'(_in-bus ...) "-write")]
|
||||
[#'(_prefix-out-bus ...) (prefix-ids #'_chip-prefix #'(_out-bus ...))])
|
||||
#'(begin
|
||||
(provide (prefix-out _chip-prefix (combine-out _in-bus ... _in-bus-write ...)))
|
||||
(define-input-bus _in-bus _in-width ...) ...
|
||||
_part ...
|
||||
(provide _prefix-out-bus ...)
|
||||
(define-output-bus _prefix-out-bus _out-bus _out-width ...) ...)))
|
||||
|
||||
|
||||
(define #'(part _prefix ((_wire . _wireargs) _wirevalue) ...)
|
||||
(with-syntax ([(prefixed-wire ...) (syntax-case-map #'(_wire ...) ()
|
||||
[s (format-id #'s "~a-~a" #'_prefix #'s)])]
|
||||
[chip-module-path (datum->syntax #'_prefix (format "~a.hdl.rkt" (syntax->datum #'_prefix)))])
|
||||
#'(begin
|
||||
(require (import-chip chip-module-path) (for-syntax (import-chip chip-module-path)))
|
||||
(handle-wires ((prefixed-wire . _wireargs) _wirevalue) ...))))
|
||||
(define #'(part _partname ((_bus-left . _busargs) _bus-expr-right) ...)
|
||||
(inject-syntax ([#'(_partname-bus-left ...) (prefix-ids #'_partname "-" #'(_bus-left ...))]
|
||||
[#'_chip-module-path (format-string "~a.hdl.rkt" #'_partname)])
|
||||
#'(begin
|
||||
(require (import-chip _chip-module-path) (for-syntax (import-chip _chip-module-path)))
|
||||
(handle-buses ((_partname-bus-left . _busargs) _bus-expr-right) ...))))
|
||||
|
||||
|
||||
(define-syntax import-chip
|
||||
|
|
@ -37,17 +34,16 @@
|
|||
(expand-import #'module-path)]))))
|
||||
|
||||
|
||||
(define #'(handle-wires _wire-assignments ...)
|
||||
(let-values ([(in-wire-stxs out-wire-stxs)
|
||||
(syntax-case-partition #'(_wire-assignments ...) ()
|
||||
[((prefixed-wire . _wireargs) _)
|
||||
(syntax-local-eval (syntax-shift-phase-level #'(input-bus? prefixed-wire) 1))])])
|
||||
(with-syntax* ([(((in-wire in-arg ...) input-expr) ...) in-wire-stxs]
|
||||
[(in-wire-write ...) (syntax-case-map #'(in-wire ...) ()
|
||||
[iw (reformat-id "~a-write" #'iw)])]
|
||||
[(((out-wire out-arg ...) (out-bus)) ...) out-wire-stxs])
|
||||
#'(begin
|
||||
(define-output-bus out-bus
|
||||
(λ ()
|
||||
(in-wire-write in-arg ... input-expr) ...
|
||||
(out-wire out-arg ...))) ...))))
|
||||
(define #'(handle-buses _bus-assignments ...)
|
||||
(let-values ([(_in-bus-assignments _out-bus-assignments)
|
||||
(syntax-case-partition #'(_bus-assignments ...) ()
|
||||
[((prefixed-wire . _wireargs) _)
|
||||
(syntax-local-eval (syntax-shift-phase-level #'(input-bus? prefixed-wire) 1))])])
|
||||
(inject-syntax* ([#'(((_in-bus _in-bus-arg ...) _in-bus-value) ...) _in-bus-assignments]
|
||||
[#'(_in-bus-write ...) (suffix-ids #'(_in-bus ...) "-write")]
|
||||
[#'((_out-bus-expr (_new-out-bus)) ...) _out-bus-assignments])
|
||||
#'(begin
|
||||
(define-output-bus _new-out-bus
|
||||
(λ ()
|
||||
(_in-bus-write _in-bus-arg ... _in-bus-value) ...
|
||||
_out-bus-expr)) ...))))
|
||||
Loading…
Reference in New Issue
Block a user