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

eliminate dup expansion of some args in mlish #%app

Browse Source
This commit is contained in:
Stephen Chang 2016-04-05 00:14:43 -04:00
parent 33e17dd282
commit a0f4d9e3a9
7 changed files with 42 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
tapl/mlish.rkt
View File

@ -89,19 +89,22 @@
#'()))
(syntax-parse stx
[(_ e_fn . args)
(define maybe-solved-tys
(try-to-solve Xs
(for/fold ([cs initial-cs])
(define-values (as- cs)
(for/fold ([as- null] [cs initial-cs])
([a (in-list (syntax->list #'args))]
[tyXin (in-list (syntax->list #'(τ_inX ...)))]
#:break (try-to-solve Xs cs))
(define/with-syntax [_ ty_a] (infer+erase a))
(stx-append cs (compute-constraint (list tyXin #'ty_a))))))
(or maybe-solved-tys
(type-error #:src stx
#:msg (mk-app-err-msg stx #:expected #'(τ_inX ...) #:given (infers+erase #'args)
#:note (format "Could not infer instantiation of polymorphic function ~a."
(syntax->datum #'e_fn)))))])]))
(define/with-syntax [a- ty_a] (infer+erase a))
(values
(cons #'a- as-)
(stx-append cs (compute-constraint (list tyXin #'ty_a))))))
(define maybe-solved-tys (try-to-solve Xs cs))
(if maybe-solved-tys
(list (reverse as-) maybe-solved-tys)
(type-error #:src stx
#:msg (mk-app-err-msg stx #:expected #'(τ_inX ...) #:given (infers+erase #'args)
#:note (format "Could not infer instantiation of polymorphic function ~a."
(syntax->datum #'e_fn)))))])]))
;; instantiate polymorphic types
(define (inst-type ty-solved Xs ty)
@ -704,27 +707,34 @@
#'(ext-stlc:#%app e_fn/ty (add-expected e_arg τ_inX) ...)])]
[else
;; ) solve for type variables Xs
(define tys-solved (solve #'Xs #'tyX_args stx))
(define/with-syntax ((e_arg1- ...) tys-solved)
(solve #'Xs #'tyX_args stx))
;; ) instantiate polymorphic function type
(syntax-parse (inst-types tys-solved #'Xs #'tyX_args)
(syntax-parse (inst-types #'tys-solved #'Xs #'tyX_args)
[(τ_in ... τ_out) ; concrete types
;; ) arity check
#:fail-unless (stx-length=? #'(τ_in ...) #'e_args)
(mk-app-err-msg stx #:expected #'(τ_in ...)
#:note "Wrong number of arguments.")
;; ) compute argument types; (possibly) double-expand args (for now)
#:with ([e_arg- τ_arg] ...) (infers+erase (stx-map add-expected-ty #'e_args #'(τ_in ...)))
;; ) compute argument types; re-use args expanded during solve
#:with ([e_arg2- τ_arg2] ...) (let ([n (stx-length #'(e_arg1- ...))])
(infers+erase
(stx-map add-expected-ty
(stx-drop #'e_args n) (stx-drop #'(τ_in ...) n))))
#:with (τ_arg1 ...) (stx-map typeof #'(e_arg1- ...))
#:with (τ_arg ...) #'(τ_arg1 ... τ_arg2 ...)
#:with (e_arg- ...) #'(e_arg1- ... e_arg2- ...)
;; ) typecheck args
#:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in ...))
(mk-app-err-msg stx
#:given #'(τ_arg ...)
#:given #'(τ_arg ...)
#:expected
(stx-map
(lambda (tyin)
(define old-orig (get-orig tyin))
(define new-orig
(and old-orig
(substs (stx-map get-orig tys-solved) #'Xs old-orig
(substs (stx-map get-orig #'tys-solved) #'Xs old-orig
(lambda (x y) (equal? (syntax->datum x) (syntax->datum y))))))
(syntax-property tyin 'orig (list new-orig)))
#'(τ_in ...)))

2
tapl/notes.txt
View File

@ -321,8 +321,10 @@ debugging notes -------------
?: literal data is not allowed;
no #%datum syntax transformer is bound in: #f
- happens when you try to syntax->datum or local-expand a #f value
- likely indicates use of wrong version of some overloaded form
- eg, using stlc:lambda instead of racket's lambda
- could also be trying to ty-eval a (#f) expected-type
- vague "bad syntax" error
- means a syntax-parse #:when or #:with matching failed

3
tapl/stx-utils.rkt
View File

@ -65,6 +65,9 @@
(define (stx-appendmap f stx)
(stx-flatten (stx-map f stx)))
(define (stx-drop stx n)
(drop (syntax->list stx) n))
;; based on make-variable-like-transformer from syntax/transformer,
;; but using (#%app id ...) instead of ((#%expression id) ...)
(define (make-variable-like-transformer ref-stx)

4
tapl/tests/mlish/queens.mlish
View File

@ -9,11 +9,11 @@
(typecheck-fail
(match (Cons 1 Nil) with
[Nil -> 1])
#:with-msg "match: clauses not exhaustive; missing: Cons")
#:with-msg "clauses not exhaustive; missing\\: Cons")
(typecheck-fail
(match (Cons 1 Nil) with
[Cons x xs -> 1])
#:with-msg "match: clauses not exhaustive; missing: Nil")
#:with-msg "clauses not exhaustive; missing: Nil")
;; list fns ----------

7
tapl/tests/run-all-mlish-tests.rkt
View File

@ -17,16 +17,23 @@
(displayln "----- General tests and queens: ---------------------------------")
(write-string (port->string err1))
(write-string (port->string i1))
(displayln "----- Shootout tests: -------------------------------------------")
(write-string (port->string err1b))
(write-string (port->string i1b))
(displayln "----- RW OCaml tests: -------------------------------------------")
(write-string (port->string err2))
(write-string (port->string i2))
(displayln "----- Ben's tests: ----------------------------------------------")
(write-string (port->string err3))
(write-string (port->string i3))
(write-string (port->string err3b))
(write-string (port->string i3b))
(write-string (port->string err3c))
(write-string (port->string i3c))
(displayln "----- Okasaki / polymorphic recursion tests: --------------------")
(write-string (port->string err4))
(write-string (port->string i4))
(close-input-port i1)
(close-output-port o1)

2
tapl/tests/run-mlish-tests1.rkt
View File

@ -1,6 +1,6 @@
#lang racket
(require "mlish-tests.rkt")
(require "mlish/queens.mlish")
;(require "mlish/queens.mlish")
(require "mlish/listpats.mlish")
(require "mlish/match2.mlish")

2
tapl/tests/run-mlish-tests1b.rkt
View File

@ -1,6 +1,6 @@
#lang racket
;; (require "mlish-tests.rkt")
;; (require "mlish/queens.mlish")
(require "mlish/queens.mlish")
(require "mlish/trees-tests.mlish")
(require "mlish/chameneos.mlish")
(require "mlish/ack.mlish")