#lang scheme/base
(require (for-syntax scheme/base))

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

(define (identity x) x)

(define (make-keyword-thunk f)
  (make-keyword-procedure f f))

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

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

(define (constant v) (thunk v))

;; General curry* (partial application) handler,
;; with case-by-case handling of keyword vs positional-only arguments.
(define (curry*/r? sym r?)
  (let* ([append-args
          (if r?
              (lambda (args1 args2) (append args2 args1))
              (lambda (args1 args2) (append args1 args2)))])
    (make-keyword-procedure
     ;; Keyword arguments initially
     (lambda (keys1 vals1 f . args1)
       (make-keyword-procedure
        ;; Two sets of keyword arguments
        (lambda (keys2 vals2 . args2)
          (let* ([alist1 (map cons keys1 vals1)]
                 [alist2 (map cons keys2 vals2)]
                 [alist (keyword-merge sym f alist1 alist2)]
                 [keys (map car alist)]
                 [vals (map cdr alist)]
                 [args (append-args args1 args2)])
            (keyword-apply f keys vals args)))
        ;; Keyword arguments followed by positional
        (lambda args2
          (keyword-apply f keys1 vals1 (append-args args1 args2)))))
     ;; Positional arguments initially
     (lambda (f . args1)
       (make-keyword-procedure
        ;; Positional arguments followed by keyword
        (lambda (keys2 vals2 . args2)
          (keyword-apply f keys2 vals2 (append-args args1 args2)))
        ;; Two sets of positional arguments
        (lambda args2 (apply f (append-args args1 args2))))))))

(define curry* (curry*/r? 'curry* #f))
(define curryr* (curry*/r? 'curryr* #t))

(define (keyword-merge sym f one two)
  (cond
   [(null? one) two]
   [(null? two) one]
   [(keyword<? (caar one) (caar two))
    (cons (car one) (keyword-merge sym f (cdr one) two))]
   [(keyword<? (caar two) (caar one))
    (cons (car two) (keyword-merge sym f one (cdr two)))]
   [else
    (error sym
           "~s: keyword ~s has redundant values ~s and ~s"
           (or (object-name f) '<unknown>)
           (caar one) (cadr one) (cadr two))]))

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

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

(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
 ;; functions
 identity constant conjoin disjoin call curry* curryr*
 ;; macros
 thunk lambda/parameter)