suzanne.soy/cur
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Improvements to match; replacing uses of case

Browse Source 
* Match now infers the result more by adding pattern variables to
  local-env while inferring types.
* Replaced uses of case* and case with match when possible
This commit is contained in:
William J. Bowman 2016-01-09 00:24:23 -05:00
parent 7b10648eb9
commit 61e99c8a2e
No known key found for this signature in database
GPG Key ID: DDD48D26958F0D1A
3 changed files with 31 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
oll.rkt
View File

@ -238,10 +238,10 @@
(data Var : Type (avar : (-> Nat Var))) (data Var : Type (avar : (-> Nat Var)))
(define (var-equal? (v1 : Var) (v2 : Var)) (define (var-equal? (v1 : Var) (v2 : Var))
(case* Var Type v1 () (lambda (v : Var) Bool) (match v1
[(avar (n1 : Nat)) IH: () [(avar (n1 : Nat))
(case* Var Type v2 () (lambda (v : Var) Bool) (match v2
[(avar (n2 : Nat)) IH: () [(avar (n2 : Nat))
(nat-equal? n1 n2)])])) (nat-equal? n1 n2)])]))
(module+ test (module+ test
(require rackunit) (require rackunit)

2
stdlib/bool.rkt
View File

@ -7,7 +7,7 @@
(false : Bool)) (false : Bool))
(define-syntax-rule (if t s f) (define-syntax-rule (if t s f)
(case t (match t
[true s] [true s]
[false f])) [false f]))

44
stdlib/sugar.rkt
View File

@ -113,39 +113,46 @@
#`(elim D U P #,@(map rewrite-clause (syntax->list #'(clause* ...))) p ... e)])) #`(elim D U P #,@(map rewrite-clause (syntax->list #'(clause* ...))) p ... e)]))
(begin-for-syntax (begin-for-syntax
(define-struct clause (args body)) (define-struct clause (args types decl body))
(define ih-dict (make-hash)) (define ih-dict (make-hash))
(define (clause-parse syn) (define (clause-parse syn)
(syntax-case syn (:) (syntax-case syn (:)
[((con (a : A) ...) body) [((con (a : A) ...) body)
(make-clause #'((a : A) ...) #'body)] (make-clause (syntax->list #'(a ...)) (syntax->list #'(A ...)) #'((a : A) ...) #'body)]
[(e body) [(e body)
(make-clause #'() #'body)])) (make-clause '() '() #'() #'body)]))
(define (infer-result clauses) (define (infer-result clauses)
(for/or ([clause clauses]) (or
(type-infer/syn (clause-body clause)))) (for/or ([clause clauses])
(type-infer/syn
(clause-body clause)
#:local-env (for/fold ([d '()])
([arg (clause-args clause)]
[type (clause-types clause)])
(dict-set d arg type))))
(raise-syntax-error
'match
"Could not infer type of result."
(clause-body (car clauses)))))
(define (infer-ihs D motive args-syn) (define (infer-ihs D motive args types)
(syntax-case args-syn (:) (for/fold ([ih-dict (make-immutable-hash)])
[((a : A) ...) ([type-syn types]
(for/fold ([ih-dict (make-immutable-hash)]) [arg-syn args]
([type-syn (syntax->list #'(A ...))] ;; NB: Non-hygenic
[arg-syn (syntax->list #'(a ...))] #:when (cur-equal? type-syn D))
;; NB: Non-hygenic (dict-set ih-dict (syntax->datum arg-syn) `(,(format-id arg-syn "ih-~a" arg-syn) . ,#`(#,motive #,arg-syn)))))
#:when (cur-equal? type-syn D))
(dict-set ih-dict (syntax->datum arg-syn) `(,(format-id args-syn "ih-~a" arg-syn) . ,#`(#,motive #,arg-syn))))]
[() '()]))
(define (clause->method D motive clause) (define (clause->method D motive clause)
(dict-clear! ih-dict) (dict-clear! ih-dict)
(let* ([ihs (infer-ihs D motive (clause-args clause))] (let* ([ihs (infer-ihs D motive (clause-args clause) (clause-types clause))]
[ih-args (dict-map [ih-args (dict-map
ihs ihs
(lambda (k v) (lambda (k v)
(dict-set! ih-dict k (car v)) (dict-set! ih-dict k (car v))
#`(#,(car v) : #,(cdr v))))]) #`(#,(car v) : #,(cdr v))))])
#`(lambda* #,@(clause-args clause) #,@ih-args #,(clause-body clause))))) #`(lambda* #,@(clause-decl clause) #,@ih-args #,(clause-body clause)))))
(define-syntax (recur syn) (define-syntax (recur syn)
(syntax-case syn () (syntax-case syn ()
@ -165,7 +172,8 @@
[(_ e clause* ...) [(_ e clause* ...)
(let* ([clauses (map clause-parse (syntax->list #'(clause* ...)))] (let* ([clauses (map clause-parse (syntax->list #'(clause* ...)))]
[R (infer-result clauses)] [R (infer-result clauses)]
[D (type-infer/syn #'e)] [D (or (type-infer/syn #'e)
(raise-syntax-error 'match "Could not infer discrimnant's type." syn))]
[motive #`(lambda (x : #,D) #,R)] [motive #`(lambda (x : #,D) #,R)]
[U (type-infer/syn R)]) [U (type-infer/syn R)])
#`((elim #,D #,U) #`((elim #,D #,U)