Multiple type errors.
svn: r9405
This commit is contained in:
Sam Tobin-Hochstadt
parent
fca36c126c
commit
bd9d8b5ff3
|
|
@ -91,19 +91,30 @@
|
|||
(let loop ([args arg-types] [doms dom-types] [stxs arg-stxs] [arg-count 1])
|
||||
(cond
|
||||
[(and (null? args) (null? doms)) (values null null)] ;; here, we just return the empty effect
|
||||
[(null? args) (tc-error "Insufficient arguments to function application, expected ~a, got ~a"
|
||||
(length dom-types) (length arg-types))]
|
||||
[(null? args)
|
||||
(tc-error/delayed
|
||||
"Insufficient arguments to function application, expected ~a, got ~a"
|
||||
(length dom-types) (length arg-types))
|
||||
(values null null)]
|
||||
[(and (null? doms) rest-type)
|
||||
(if (subtype (car args) rest-type)
|
||||
(loop (cdr args) doms (cdr stxs) (add1 arg-count))
|
||||
(tc-error/stx (car stxs) "Rest argument had wrong type, expected: ~a and got: ~a" rest-type (car args)))]
|
||||
(begin
|
||||
(tc-error/delayed #:stx (car stxs)
|
||||
"Rest argument had wrong type, expected: ~a and got: ~a"
|
||||
rest-type (car args))
|
||||
(values null null)))]
|
||||
[(null? doms)
|
||||
(tc-error "Too many arguments to function, expected ~a, got ~a" (length dom-types) (length arg-types))]
|
||||
(tc-error/delayed "Too many arguments to function, expected ~a, got ~a" (length dom-types) (length arg-types))
|
||||
(values null null)]
|
||||
[(subtype (car args) (car doms))
|
||||
(loop (cdr args) (cdr doms) (cdr stxs) (add1 arg-count))]
|
||||
[else
|
||||
(tc-error/stx (car stxs) "Wrong function argument type, expected ~a, got ~a for argument ~a"
|
||||
(car doms) (car args) arg-count)]))))
|
||||
(tc-error/delayed
|
||||
#:stx (car stxs)
|
||||
"Wrong function argument type, expected ~a, got ~a for argument ~a"
|
||||
(car doms) (car args) arg-count)
|
||||
(values null null)]))))
|
||||
|
||||
|
||||
;(trace tc-args)
|
||||
|
|
@ -125,12 +136,15 @@
|
|||
(let loop ([doms* doms] [rngs* rngs] [rests* rests])
|
||||
(cond [(null? doms*)
|
||||
(if (and (not (null? doms)) (null? (cdr doms)))
|
||||
(tc-error
|
||||
(tc-error/expr
|
||||
#:return (ret (Un))
|
||||
"bad arguments to apply - function expected ~a fixed arguments and (Listof ~a) rest argument, given ~a"
|
||||
(car doms) (car rests) arg-tys0)
|
||||
(tc-error "no function domain matched - domains were: ~a arguments were ~a"
|
||||
(map printable doms rests)
|
||||
arg-tys0))]
|
||||
(tc-error/expr
|
||||
#:return (ret (Un))
|
||||
"no function domain matched - domains were: ~a arguments were ~a"
|
||||
(map printable doms rests)
|
||||
arg-tys0))]
|
||||
[(and (subtypes arg-tys (car doms*)) (car rests*) (subtype tail-ty (make-Listof (car rests*))))
|
||||
(ret (car rngs*))]
|
||||
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*))]))]
|
||||
|
|
@ -141,9 +155,14 @@
|
|||
(let loop ([doms* doms] [rngs* rngs] [rests* rests])
|
||||
(cond [(null? doms*)
|
||||
(if (= 1 (length doms))
|
||||
(tc-error "polymorphic function domain did not match - domain was: ~a arguments were ~a"
|
||||
(car doms) arg-tys0)
|
||||
(tc-error "no polymorphic function domain matched - domains were: ~a arguments were ~a" doms arg-tys0))]
|
||||
(tc-error/expr
|
||||
#:return (ret (Un))
|
||||
"polymorphic function domain did not match - domain was: ~a arguments were ~a"
|
||||
(car doms) arg-tys0)
|
||||
(tc-error/expr
|
||||
#:return (ret (Un))
|
||||
"no polymorphic function domain matched - domains were: ~a arguments were ~a"
|
||||
doms arg-tys0))]
|
||||
[(and (= (length (car doms*))
|
||||
(length arg-tys))
|
||||
(infer/list (append (car doms*) (list (make-Listof (car rests*)))) arg-tys0 vars))
|
||||
|
|
@ -155,8 +174,10 @@
|
|||
(ret (subst-all substitution (car rngs*))))]
|
||||
[else (loop (cdr doms*) (cdr rngs*) (cdr rests*))]))]
|
||||
[(tc-result: (Poly: vars (Function: '())))
|
||||
(tc-error "Function has no cases")]
|
||||
[f-ty (tc-error "Type of argument to apply is not a function type: ~n~a" f-ty)]))))
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
"Function has no cases")]
|
||||
[f-ty (tc-error/expr #:return (ret (Un))
|
||||
"Type of argument to apply is not a function type: ~n~a" f-ty)]))))
|
||||
|
||||
(define (stringify l [between " "])
|
||||
(define (intersperse v l)
|
||||
|
|
@ -187,8 +208,11 @@
|
|||
[(list t)
|
||||
(if (subtype t in)
|
||||
(ret -Void)
|
||||
(tc-error "Wrong argument to parameter - expected ~a and got ~a" in t))]
|
||||
[_ (tc-error "Wrong number of arguments to parameter - expected 0 or 1, got ~a" (length argtypes))])]
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
"Wrong argument to parameter - expected ~a and got ~a" in t))]
|
||||
[_ (tc-error/expr #:return (ret (Un))
|
||||
"Wrong number of arguments to parameter - expected 0 or 1, got ~a"
|
||||
(length argtypes))])]
|
||||
[(tc-result: (Function: (list (arr: doms rngs rests latent-thn-effs latent-els-effs) ..1)) thn-eff els-eff)
|
||||
(if (= 1 (length doms))
|
||||
(let-values ([(thn-eff els-eff)
|
||||
|
|
@ -201,7 +225,9 @@
|
|||
(ret (car rngs) eff)))
|
||||
(let loop ([doms* doms] [rngs rngs] [rests rests])
|
||||
(cond [(null? doms*)
|
||||
(tc-error "no function domain matched - domains were: ~a arguments were ~a" doms argtypes)]
|
||||
(tc-error/expr
|
||||
#:return (ret (Un))
|
||||
"no function domain matched - domains were: ~a arguments were ~a" doms argtypes)]
|
||||
[(subtypes/varargs argtypes (car doms*) (car rests)) (ret (car rngs))]
|
||||
[else (loop (cdr doms*) (cdr rngs) (cdr rests))])))]
|
||||
[(and rft (tc-result: (Poly: vars (Function: (list (arr: doms rngs #f thn-effs els-effs) ...)))))
|
||||
|
|
@ -217,10 +243,12 @@
|
|||
(cond [(null? doms*)
|
||||
(match-let ([(tc-result: (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs #f _ _) ...)))) ftype])
|
||||
(if (= 1 (length doms))
|
||||
(tc-error "Polymorphic function could not be applied to arguments:~nExpected: ~a ~nActual: ~a"
|
||||
(car msg-doms) argtypes)
|
||||
(tc-error "no polymorphic function domain matched - possible domains were: ~n~a~narguments: were ~n~a"
|
||||
(stringify (map stringify msg-doms) "\n") (stringify argtypes))))]
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
"Polymorphic function could not be applied to arguments:~nExpected: ~a ~nActual: ~a"
|
||||
(car msg-doms) argtypes)
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
"no polymorphic function domain matched - possible domains were: ~n~a~narguments: were ~n~a"
|
||||
(stringify (map stringify msg-doms) "\n") (stringify argtypes))))]
|
||||
[(and (= (length (car doms*))
|
||||
(length argtypes))
|
||||
(infer/list (car doms*) argtypes vars))
|
||||
|
|
@ -257,16 +285,17 @@
|
|||
(unless (subtypes/varargs argtypes new-dom new-rest)
|
||||
(int-err "Inconsistent substitution - arguments not subtypes"))
|
||||
(ret (subst-all substitution rng)))
|
||||
(tc-error "no polymorphic function domain matched - domain was: ~a rest type was: ~a arguments were ~a"
|
||||
(stringify dom) rest (stringify argtypes))))]
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
"no polymorphic function domain matched - domain was: ~a rest type was: ~a arguments were ~a"
|
||||
(stringify dom) rest (stringify argtypes))))]
|
||||
[(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests thn-effs els-effs) ...))))
|
||||
(tc-error "polymorphic vararg case-lambda application not yet supported")]
|
||||
(tc-error/expr #:return (ret (Un)) "polymorphic vararg case-lambda application not yet supported")]
|
||||
;; Union of function types works if we can apply all of them
|
||||
[(tc-result: (Union: (list (and fs (Function: _)) ...)) e1 e2)
|
||||
(match-let ([(list (tc-result: ts) ...) (map (lambda (f) (outer-loop
|
||||
(ret f e1 e2) argtypes arg-thn-effs arg-els-effs args)) fs)])
|
||||
(ret (apply Un ts)))]
|
||||
[(tc-result: f-ty _ _) (tc-error "Cannot apply expression of type ~a, since it is not a function type" f-ty)]))))
|
||||
[(tc-result: f-ty _ _) (tc-error #:return (ret (Un)) "Cannot apply expression of type ~a, since it is not a function type" f-ty)]))))
|
||||
|
||||
;(trace tc/funapp)
|
||||
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@
|
|||
[(byte-pregexp? v) -Byte-PRegexp]
|
||||
[(byte-regexp? v) -Byte-Regexp]
|
||||
[(regexp? v) -Regexp]
|
||||
[else (begin (printf "checking literal : ~a~n" v) Univ)]))
|
||||
[else Univ]))
|
||||
|
||||
;; typecheck an identifier
|
||||
;; the identifier has variable effect
|
||||
|
|
@ -68,19 +68,21 @@
|
|||
(define (tc-id id)
|
||||
(let* ([ty (lookup-type/lexical id)]
|
||||
[inst (syntax-property id 'type-inst)])
|
||||
(when (and inst
|
||||
(not (Poly? ty)))
|
||||
(tc-error "Cannot instantiate non-polymorphic type ~a" ty))
|
||||
(when (and inst
|
||||
(cond [(and inst
|
||||
(not (Poly? ty)))
|
||||
(tc-error/expr #:return (ret (Un)) "Cannot instantiate non-polymorphic type ~a" ty)]
|
||||
[(and inst
|
||||
(not (= (length (syntax->list inst)) (Poly-n ty))))
|
||||
(tc-error "Wrong number of type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a"
|
||||
ty (Poly-n ty) (length (syntax->list inst))))
|
||||
(let ([ty* (if inst
|
||||
(begin
|
||||
(printf/log "Type Instantiation: ~a~n" (syntax-e id))
|
||||
(instantiate-poly ty (map parse-type (syntax->list inst))))
|
||||
ty)])
|
||||
(ret ty* (list (make-Var-True-Effect id)) (list (make-Var-False-Effect id))))))
|
||||
(tc-error/expr #:return (ret (Un))
|
||||
"Wrong number of type arguments to polymorphic type ~a:~nexpected: ~a~ngot: ~a"
|
||||
ty (Poly-n ty) (length (syntax->list inst)))]
|
||||
[else
|
||||
(let ([ty* (if inst
|
||||
(begin
|
||||
(printf/log "Type Instantiation: ~a~n" (syntax-e id))
|
||||
(instantiate-poly ty (map parse-type (syntax->list inst))))
|
||||
ty)])
|
||||
(ret ty* (list (make-Var-True-Effect id)) (list (make-Var-False-Effect id))))])))
|
||||
|
||||
;; typecheck an expression, but throw away the effect
|
||||
;; tc-expr/t : Expr -> Type
|
||||
|
|
@ -91,13 +93,12 @@
|
|||
(match (list tr1 expected)
|
||||
[(list (tc-result: t1 te1 ee1) t2)
|
||||
(unless (subtype t1 t2)
|
||||
(tc-error "Expected ~a, but got ~a" t2 t1))
|
||||
(tc-error/expr "Expected ~a, but got ~a" t2 t1))
|
||||
(ret expected)]
|
||||
[(list t1 t2)
|
||||
(unless (subtype t1 t2)
|
||||
(tc-error "Expected ~a, but got ~a" t2 t1))
|
||||
(ret expected)]
|
||||
[_ (error "bad arguments to check-below")]))
|
||||
(tc-error/expr"Expected ~a, but got ~a" t2 t1))
|
||||
(ret expected)]))
|
||||
|
||||
(define (tc-expr/check form expected)
|
||||
(parameterize ([current-orig-stx form])
|
||||
|
|
@ -120,7 +121,7 @@
|
|||
(syntax-property form 'typechecker:ignore-some)
|
||||
(let ([ty (check-subforms/ignore form)])
|
||||
(unless ty
|
||||
(tc-error "internal error: ignore-some"))
|
||||
(int-err "internal error: ignore-some"))
|
||||
(check-below ty expected))]
|
||||
;; data
|
||||
[(quote #f) (ret (-val #f) (list (make-False-Effect)) (list (make-False-Effect)))]
|
||||
|
|
@ -133,13 +134,13 @@
|
|||
(match-let* ([(tc-result: id-t) (tc-id #'id)]
|
||||
[(tc-result: val-t) (tc-expr #'val)])
|
||||
(unless (subtype val-t id-t)
|
||||
(tc-error "Mutation only allowed with compatible types:~n~a is not a subtype of ~a" val-t id-t))
|
||||
(tc-error/expr "Mutation only allowed with compatible types:~n~a is not a subtype of ~a" val-t id-t))
|
||||
(ret -Void))]
|
||||
;; top-level variable reference - occurs at top level
|
||||
[(#%top . id) (check-below (tc-id #'id) expected)]
|
||||
;; weird
|
||||
[(#%variable-reference . _)
|
||||
(tc-error "#%variable-reference is not supported by Typed Scheme")]
|
||||
(tc-error/expr #:return (ret expected) "#%variable-reference is not supported by Typed Scheme")]
|
||||
;; identifiers
|
||||
[x (identifier? #'x) (check-below (tc-id #'x) expected)]
|
||||
;; w-c-m
|
||||
|
|
@ -179,7 +180,7 @@
|
|||
[(letrec-values ([(name ...) expr] ...) . body)
|
||||
(tc/letrec-values/check #'((name ...) ...) #'(expr ...) #'body form expected)]
|
||||
;; other
|
||||
[_ (tc-error "cannot typecheck unknown form : ~a~n" (syntax->datum form))]
|
||||
[_ (tc-error/expr #:return (ret expected) "cannot typecheck unknown form : ~a~n" (syntax->datum form))]
|
||||
))))
|
||||
|
||||
;; type check form in the current type environment
|
||||
|
|
@ -197,13 +198,13 @@
|
|||
(syntax-property form 'typechecker:with-handlers)
|
||||
(let ([ty (check-subforms/with-handlers form)])
|
||||
(unless ty
|
||||
(tc-error "internal error: with-handlers"))
|
||||
(int-err "internal error: with-handlers"))
|
||||
ty)]
|
||||
[stx
|
||||
(syntax-property form 'typechecker:ignore-some)
|
||||
(let ([ty (check-subforms/ignore form)])
|
||||
(unless ty
|
||||
(tc-error "internal error: ignore-some"))
|
||||
(int-err "internal error: ignore-some"))
|
||||
ty)]
|
||||
|
||||
;; data
|
||||
|
|
@ -238,7 +239,7 @@
|
|||
(match-let* ([(tc-result: id-t) (tc-id #'id)]
|
||||
[(tc-result: val-t) (tc-expr #'val)])
|
||||
(unless (subtype val-t id-t)
|
||||
(tc-error "Mutation only allowed with compatible types:~n~a is not a subtype of ~a" val-t id-t))
|
||||
(tc-error/expr "Mutation only allowed with compatible types:~n~a is not a subtype of ~a" val-t id-t))
|
||||
(ret -Void))]
|
||||
;; top-level variable reference - occurs at top level
|
||||
[(#%top . id) (tc-id #'id)]
|
||||
|
|
@ -246,7 +247,7 @@
|
|||
[(#%expression e) (tc-expr #'e)]
|
||||
;; weird
|
||||
[(#%variable-reference . _)
|
||||
(tc-error "do not use #%variable-reference")]
|
||||
(tc-error/expr #:return (ret (Un)) "#%variable-reference is not supported by Typed Scheme")]
|
||||
;; identifiers
|
||||
[x (identifier? #'x) (tc-id #'x)]
|
||||
;; application
|
||||
|
|
@ -268,7 +269,7 @@
|
|||
(begin (tc-exprs (syntax->list #'es))
|
||||
(tc-expr #'e))]
|
||||
;; other
|
||||
[_ (tc-error "cannot typecheck unknown form : ~a~n" (syntax->datum form))]))
|
||||
[_ (tc-error/expr #:return (ret (Un)) "cannot typecheck unknown form : ~a~n" (syntax->datum form))]))
|
||||
|
||||
(parameterize ([current-orig-stx form])
|
||||
;(printf "form: ~a~n" (syntax->datum form))
|
||||
|
|
@ -287,13 +288,13 @@
|
|||
(match (tc-expr method)
|
||||
[(tc-result: (Value: (? symbol? s)))
|
||||
(let* ([ftype (cond [(assq s methods) => cadr]
|
||||
[else (tc-error "send: method ~a not understood by class ~a" s c)])]
|
||||
[else (tc-error/expr "send: method ~a not understood by class ~a" s c)])]
|
||||
[ret-ty (tc/funapp rcvr args (ret ftype) (map tc-expr (syntax->list args)))])
|
||||
(if expected
|
||||
(begin (check-below ret-ty expected) (ret expected))
|
||||
ret-ty))]
|
||||
[(tc-result: t) (int-err "non-symbol methods not yet supported: ~a" t)])]
|
||||
[(tc-result: t) (tc-error "send: expected a class instance, got ~a" t)]))
|
||||
[(tc-result: t) (int-err "non-symbol methods not supported by Typed Scheme: ~a" t)])]
|
||||
[(tc-result: t) (tc-error/expr #:return (or expected (Un)) "send: expected a class instance, got ~a" t)]))
|
||||
|
||||
;; type-check a list of exprs, producing the type of the last one.
|
||||
;; if the list is empty, the type is Void.
|
||||
|
|
|
|||
|
|
@ -96,8 +96,6 @@
|
|||
(define (tc/if-onearm tst body) (tc/if-twoarm tst body (syntax/loc body (#%app void))))
|
||||
|
||||
(define (tc/if-onearm/check tst body expected)
|
||||
#;(unless (subtype -Void expected)
|
||||
(tc-error "Single-armed if may return void, but void is not allowed in this context"))
|
||||
(tc/if-twoarm/check tst body (syntax/loc body (#%app void)) expected))
|
||||
|
||||
;; the main function
|
||||
|
|
|
|||
|
|
@ -40,8 +40,13 @@
|
|||
[(args* ...)
|
||||
(if (ormap (lambda (e) (not (type-annotation e))) (syntax->list #'(args* ...)))
|
||||
(let* ([arg-list (syntax->list #'(args* ...))])
|
||||
(unless (= (length arg-list) (length arg-tys))
|
||||
(tc-error "Expected function with ~a arguments, but got function with ~a arguments" (length arg-tys) (length arg-list)))
|
||||
(let ([arg-list
|
||||
(if (= (length arg-list) (length arg-tys))
|
||||
arg-list
|
||||
(tc-error/expr
|
||||
#:return (map (lambda _ (Un)) arg-tys)
|
||||
"Expected function with ~a arguments, but got function with ~a arguments"
|
||||
(length arg-tys) (length arg-list)))])
|
||||
(for-each (lambda (a) (printf/log "Lambda Var: ~a~n" (syntax-e a))) arg-list)
|
||||
(with-lexical-env/extend
|
||||
arg-list arg-tys
|
||||
|
|
@ -172,7 +177,7 @@
|
|||
(tc/mono-lambda formals bodies expected*))])
|
||||
;(printf "plambda: ~a ~a ~a ~n" literal-tvars new-tvars ty)
|
||||
(ret (make-Poly literal-tvars ty))))]
|
||||
[_ (tc-error "Expected a value of type ~a, but got a polymorphic function." expected)]))
|
||||
[_ (tc-error/expr #:return expected "Expected a value of type ~a, but got a polymorphic function." expected)]))
|
||||
|
||||
|
||||
;; form : a syntax object for error reporting
|
||||
|
|
|
|||
|
|
@ -225,6 +225,8 @@
|
|||
(for-each tc-toplevel/pass2 forms)
|
||||
;; check that declarations correspond to definitions
|
||||
(check-all-registered-types)
|
||||
;; report delayed errors
|
||||
(report-all-errors)
|
||||
;; compute the new provides
|
||||
(with-syntax
|
||||
([((new-provs ...) ...) (map (generate-prov stx-defs val-defs) provs)])
|
||||
|
|
|
|||
|
|
@ -29,21 +29,34 @@
|
|||
;(printf "orig: ~a~n" (syntax-object->datum omodule))
|
||||
;(printf "exp: ~a~n" (syntax-object->datum emodule))
|
||||
;(printf "stx (locate): ~a~n" (syntax-object->datum stx))
|
||||
(if (and omodule emodule stx)
|
||||
(if (and (not (print-syntax?)) omodule emodule stx)
|
||||
(look-for-in-orig omodule emodule stx)
|
||||
stx))
|
||||
|
||||
(define (raise-typecheck-error msg stxs)
|
||||
(raise (make-exn:fail:syntax (string-append "typecheck: " msg)
|
||||
(current-continuation-marks)
|
||||
stxs)))
|
||||
|
||||
(define delayed-errors null)
|
||||
|
||||
(define-struct err (msg stx) #:prefab)
|
||||
|
||||
(define (report-all-errors)
|
||||
(define stxs
|
||||
(for/list ([e (reverse delayed-errors)])
|
||||
(thread (lambda () (raise-typecheck-error (err-msg e) (err-stx e))))
|
||||
(sleep .01)
|
||||
(err-stx e)))
|
||||
(unless (null? stxs)
|
||||
(raise-typecheck-error "Errors encountered" (apply append stxs))))
|
||||
|
||||
(define (tc-error/delayed msg #:stx [stx (current-orig-stx)] . rest)
|
||||
(set! delayed-errors (cons (make-err (apply format msg rest) (list (locate-stx stx))) delayed-errors)))
|
||||
|
||||
;; produce a type error, using the current syntax
|
||||
(define (tc-error msg . rest)
|
||||
(define cur-stx
|
||||
(begin
|
||||
;(printf "stx : ~a~n" (current-orig-stx))
|
||||
(if (print-syntax?)
|
||||
(current-orig-stx)
|
||||
(locate-stx (current-orig-stx)))))
|
||||
|
||||
;(printf "Aliases: ~a~n" ((current-type-names)))
|
||||
(raise-syntax-error 'typecheck (apply format msg rest) cur-stx cur-stx))
|
||||
(define (tc-error msg . rest)
|
||||
(raise-typecheck-error (apply format msg rest) (list (locate-stx (current-orig-stx)))))
|
||||
|
||||
;; produce a type error, given a particular syntax
|
||||
(define (tc-error/stx stx msg . rest)
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@
|
|||
"type-effect-printer.ss"
|
||||
"union.ss"
|
||||
"subtype.ss"
|
||||
"type-utils.ss"
|
||||
"type-utils.ss"
|
||||
"tc-utils.ss"
|
||||
scheme/promise
|
||||
(for-syntax scheme/base))
|
||||
|
||||
|
|
@ -224,4 +225,8 @@
|
|||
(exit t)))]
|
||||
[_ (exit t)]))))
|
||||
|
||||
(define (tc-error/expr msg #:return [return (Un)] #:stx [stx (current-orig-stx)] . rest)
|
||||
(tc-error/delayed #:stx stx (apply format msg rest))
|
||||
return)
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user