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

Cleaned up typeclass code a little

Browse Source
This commit is contained in:
William J. Bowman 2015-09-15 17:20:37 -04:00
parent 5fec16125d
commit a29940ec69
No known key found for this signature in database
GPG Key ID: DDD48D26958F0D1A
1 changed files with 44 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
stdlib/typeclass.rkt
View File

@ -8,27 +8,32 @@
racket/dict racket/dict
racket/list)) racket/list))
;;; NB: This module is extremely unhygienic.
#| TODO:
| These typeclasses are kind of broken. There are no typeclass constraints so....
|#
(begin-for-syntax (begin-for-syntax
;; NB: Need this thing to be global w.r.t. the runtime, i.e., exist once #| NB:
;; NB: and for all no matter how many things import typeclass, i.e., not | Need this thing to be global w.r.t. the runtime, i.e., exist once
;; NB: local to this module | and for all no matter how many things import typeclass, i.e., not
(define bla (make-hash))) | local to this module.
|#
(define typeclasses (make-hash)))
(define-syntax (typeclass syn) (define-syntax (typeclass syn)
(syntax-case syn (: Type) (syntax-case syn (: Type)
[(_ (class (param : Type)) [(_ (class (param : Type)) (name : type) ...)
(name : type) ...)
;; TODO: Doing 2 loops over names, stop being stupid
(hash-set! bla (syntax->datum #'class)
(for/list ([p (syntax->list #'((name : type) ...))])
(let ([p (syntax->list p)])
`(,(syntax->datum (first p)) . ,#`(lambda (param : Type) #,(third p))))))
#`(begin #`(begin
#,@(for/list ([name (syntax->list #'(name ...))]) #,@(for/list ([name (syntax->list #'(name ...))]
;; NB: Due to implementation below, methods on typeclass [type (syntax->list #'(type ...))])
;; NB: must dispatch on type of first argument. (dict-set!
;; NB: Also prevents currying/point-free style. (dict-ref! typeclasses (syntax->datum #'class) (make-hash))
;; NB: Maybe type system hooks to get "type of current hole" (syntax->datum name)
;; NB: would help? #`(lambda (param : Type) #,type))
#| NB:
| Due to implementation below, methods on typeclass must dispatch on type of first
| argument. Also prevents currying/point-free style. Maybe type system hooks to get
| "type of current hole" would help? Related: tactics/base.rkt
|#
#`(define-syntax (#,name syn) #`(define-syntax (#,name syn)
(syntax-case syn () (syntax-case syn ()
[(_ arg args (... ...)) [(_ arg args (... ...))
@ -37,25 +42,28 @@
args (... ...))]))))])) args (... ...))]))))]))
(define-syntax (impl syn) (define-syntax (impl syn)
#| TODO:
| Need racket-like define so I can extract name/args/defs.
|#
(define (process-def def) (define (process-def def)
(syntax-case def (define) (syntax-case def (define)
[(define (name (a : t) ...) body ...) [(define (name (a : t) ...) body ...)
(values #'name #'(lambda* (a : t) ... body ...))] (values (syntax->datum #'name) #'(lambda* (a : t) ... body ...))]
[(define name body) [(define name body)
(values #'name #'body)])) (values (syntax->datum #'name) #'body)]))
(syntax-case syn () (syntax-case syn ()
[(_ (class param) [(_ (class param) defs ...)
;; TODO: Need racket-like define so I can extract
;; TODO: name/args/defs, or use local-expand or something
defs ...)
#`(begin #`(begin
#,@(for/list ([def (syntax->list #'(defs ...))]) #,@(for/list ([def (syntax->list #'(defs ...))])
(let-values ([(name body) (process-def def)]) (let-values ([(name body) (process-def def)])
(unless (type-check/syn? body #`(#,(dict-ref (unless (type-check/syn?
(dict-ref bla (syntax->datum #'class)) body
(syntax->datum name)) #`(#,(dict-ref
(dict-ref typeclasses (syntax->datum #'class))
name)
param)) param))
(raise-syntax-error 'impl (raise-syntax-error
'impl
;"Invalid implementation of typeclass ~a. Must have type ~a." ;"Invalid implementation of typeclass ~a. Must have type ~a."
"Invalid implementation of typeclass." "Invalid implementation of typeclass."
#'class #'class