#lang scheme/base
(require "../../base.ss")
(require (for-syntax scheme/base
scheme/list
scheme/pretty
(cce-scheme-in syntax)
(unlib-in symbol syntax)
"identifier.ss")
(only-in scheme/list filter-map)
"struct.ss")
(define-syntax (define/provide-function stx)
(syntax-case stx ()
[(_ header #:type type expr ...)
(with-syntax ([id (define-header->id #'header)])
(quasisyntax/loc stx
(begin (define-sql header #:type 'function expr ...)
(provide id))))]))
(define undefined
(gensym 'sql-undefined-arg))
(define (undefined? val)
(eq? undefined val))
(define-syntax (define-function/types stx)
(define (args->arg-formals stx)
(filter-map (lambda (stx)
(syntax-case stx ()
[[id] (identifier? #'id) #'[id undefined]]
[kw (keyword? (syntax->datum #'kw)) #'kw]
[id (identifier? #'id) #'id]))
(syntax->list stx)))
(define (args->arg-ids stx)
(filter-map (lambda (stx)
(syntax-case stx ()
[(id) (identifier? #'id) #'id]
[kw (keyword? (syntax->datum #'kw)) #f]
[id (identifier? #'id) #'id]))
(syntax->list stx)))
(define (args->arg-exprs stx)
(filter-map (lambda (stx)
(syntax-case stx ()
[(id) (identifier? #'id) #'(if (undefined? id) #f (sql-quote id))]
[kw (keyword? (syntax->datum #'kw)) #f]
[id (identifier? #'id) #'(sql-quote id)]))
(syntax->list stx)))
(syntax-case stx ()
[(_ (id arg ...) [rule type] ...)
(identifier? #'id)
(with-syntax ([(formal ...) (args->arg-formals #'(arg ...))]
[(arg ...) (args->arg-ids #'(arg ...))]
[(expr ...) (args->arg-exprs #'(arg ...))])
(syntax/loc stx
(define-sql-form (id formal ...)
(let ([arg expr] ...)
(make-function (type-rules [rule type] ...) 'id (list arg ...))))))]
[(_ (id arg ... . rest) [rule type] ...)
(identifier? #'id)
(with-syntax ([(formal ...) (args->arg-formals #'(arg ...))]
[(arg ...) (args->arg-ids #'(arg ...))]
[(expr ...) (args->arg-exprs #'(arg ...))])
(syntax/loc stx
(define-function (id formal ... . rest)
(let ([arg expr] ... [rest (map sql-quote rest)])
(make-function (type-rules [rule type] ...) 'id (list* arg ... rest))))))]))
(define-syntax (type-rules stx)
(syntax-case stx ()
[(_ [rule type] ...)
#'(cond [rule type] ...
[else (error "function not defined for the supplied types")])]))
(define-syntax (function/c stx)
(define (arg-contracts stxs)
(filter-map (lambda (stx)
(syntax-case stx ()
[(id) #f]
[id #'sql-quotable?]))
stxs))
(define (opt-arg-contracts stxs)
(filter-map (lambda (stx)
(syntax-case stx ()
[(id) #'sql-quotable?]
[id #f]))
stxs))
(syntax-case stx ()
[(_ arg ...)
(with-syntax ([(arg-contract ...) (arg-contracts (syntax->list #'(arg ...)))]
[(opt-arg-contract ...) (opt-arg-contracts (syntax->list #'(arg ...)))])
(syntax/loc stx
(->* (arg-contract ...) (opt-arg-contract ...) function?)))]
[(_ arg ... . rest)
(with-syntax ([(arg-contract ...) (arg-contracts (syntax->list #'(arg ...)))]
[(opt-arg-contract ...) (opt-arg-contracts (syntax->list #'(arg ...)))])
(syntax/loc stx
(->* (arg-contract ...) (opt-arg-contract ...) #:rest (listof sql+quotable?) function?)))]))
(provide define-function
define-function/types
type-rules
function/c
undefined
undefined?)