#lang scheme

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  HIGHER ORDER TOOLS
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (identity x) x)

(define (constant v)
  (make-keyword-procedure (lambda _ v)))

(define (conjoin . fs)
  (make-keyword-procedure
   (lambda (keys vals . args)
     (andmap (lambda (f) (keyword-apply f keys vals args)) fs))))

(define (disjoin . fs)
  (make-keyword-procedure
   (lambda (keys vals . args)
     (ormap (lambda (f) (keyword-apply f keys vals args)) fs))))

(define-syntax (thunk stx)
  (syntax-case stx ()
    [(thunk body ...)
     (syntax/loc stx
       (make-keyword-procedure
        (lambda _ body ...)))]))

(define call
  (make-keyword-procedure
   (lambda (keys vals f . args)
     (keyword-apply f keys vals args))))

(define-syntax (lambda/parameter/derived stx)
  (syntax-case stx ()

    ;; Positional Argument
    [(lpd orig (arg . rest) lets args params body)
     (identifier? #'arg)
     (syntax/loc stx
       (lpd orig rest lets (arg . args) params body))]

    ;; Positional Optional Argument
    [(lpd orig ([arg default] . rest) lets args params body)
     (identifier? #'arg)
     (syntax/loc stx
       (lpd orig rest lets ([arg default] . rest) params body))]

    ;; Positional Paramater Argument
    [(lpd orig ([arg #:param expr] . rest) lets args params body)
     (identifier? #'arg)
     (syntax/loc stx
       (lpd orig rest
            ([it expr] . lets)
            ([arg (it)] . args)
            ([it arg] . params)
            body))]

    ;; Keyword Argument
    [(lpd orig (key arg . rest) lets args params body)
     (and (keyword? (syntax-e #'key)) (identifier? #'arg))
     (syntax/loc stx
       (lpd orig rest lets (key arg . args) params body))]

    ;; Keyword Optional Argument
    [(lpd orig (key [arg default] . rest) lets args params body)
     (and (keyword? (syntax-e #'key)) (identifier? #'arg))
     (syntax/loc stx
       (lpd orig rest lets (key [arg default] . rest) params body))]

    ;; Keyword Paramater Argument
    [(lpd orig (key [arg #:param expr] . rest) lets args params body)
     (and (keyword? (syntax-e #'key)) (identifier? #'arg))
     (syntax/loc stx
       (lpd orig rest
            ([it expr] . lets)
            (key [arg (it)] . args)
            ([it arg] . params)
            body))]

    ;; No More Arguments
    [(lpd orig () lets args params body)
     (syntax/loc stx
       (let lets (lambda args (parameterize params . body))))]

    ;; Bad Keyword Argument
    [(lpd orig (key arg . rest) lets args params body)
     (keyword? (syntax-e #'key))
     (raise-syntax-error #f "invalid keyword argument" #'orig #'arg)]

    ;; Bad Positional Argument
    [(lpd orig (arg . rest) lets args params body)
     (raise-syntax-error #f "invalid positional argument" #'orig #'arg)]

    ;; Bad Syntax
    [(lpd orig . _)
     (raise-syntax-error #f "error in expansion" #'orig)]))

(define-syntax (lambda/parameter stx)
  (syntax-case stx ()
    [(lp (clause ... . rest) . body)
     (quasisyntax/loc stx
       (lambda/parameter/derived #,stx (clause ...) () rest () body))]))

(provide/contract
 [identity (->d ([v any/c]) () [_ (one-of/c v)])]
 [constant (->d ([v any/c]) () [_ procedure?])]
 ;; procedure? above would be (unconstrained-domain-> (one-of/v)),
 ;; but unconstrained-domain-> does not allow keyword arguments.
 [conjoin (->* [] [] #:rest (listof procedure?) procedure?)]
 [disjoin (->* [] [] #:rest (listof procedure?) procedure?)]
 [call procedure?])

(provide thunk lambda/parameter)