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)))
(define (var-equal? (v1 : Var) (v2 : Var))
(case* Var Type v1 () (lambda (v : Var) Bool)
[(avar (n1 : Nat)) IH: ()
(case* Var Type v2 () (lambda (v : Var) Bool)
[(avar (n2 : Nat)) IH: ()
(match v1
[(avar (n1 : Nat))
(match v2
[(avar (n2 : Nat))
(nat-equal? n1 n2)])]))
(module+ test
(require rackunit)

2
stdlib/bool.rkt
View File

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

36
stdlib/sugar.rkt
View File

@ -113,39 +113,46 @@
#`(elim D U P #,@(map rewrite-clause (syntax->list #'(clause* ...))) p ... e)]))
(begin-for-syntax
(define-struct clause (args body))
(define-struct clause (args types decl body))
(define ih-dict (make-hash))
(define (clause-parse syn)
(syntax-case syn (:)
[((con (a : A) ...) body)
(make-clause #'((a : A) ...) #'body)]
(make-clause (syntax->list #'(a ...)) (syntax->list #'(A ...)) #'((a : A) ...) #'body)]
[(e body)
(make-clause #'() #'body)]))
(make-clause '() '() #'() #'body)]))
(define (infer-result clauses)
(or
(for/or ([clause clauses])
(type-infer/syn (clause-body clause))))
(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)
(syntax-case args-syn (:)
[((a : A) ...)
(define (infer-ihs D motive args types)
(for/fold ([ih-dict (make-immutable-hash)])
([type-syn (syntax->list #'(A ...))]
[arg-syn (syntax->list #'(a ...))]
([type-syn types]
[arg-syn args]
;; NB: Non-hygenic
#: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))))]
[() '()]))
(dict-set ih-dict (syntax->datum arg-syn) `(,(format-id arg-syn "ih-~a" arg-syn) . ,#`(#,motive #,arg-syn)))))
(define (clause->method D motive clause)
(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
ihs
(lambda (k v)
(dict-set! ih-dict k (car 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)
(syntax-case syn ()
@ -165,7 +172,8 @@
[(_ e clause* ...)
(let* ([clauses (map clause-parse (syntax->list #'(clause* ...)))]
[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)]
[U (type-infer/syn R)])
#`((elim #,D #,U)