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

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  Degenerate Functions
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (identity x) x)

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

(define (constant v) (thunk v))

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

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  Higher-Order Boolean Operations
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(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))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  Function Invocation (partial or indirect)
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (curryn* n f r? keys0 vals0 args0)
  (if (<= n 0)
      (keyword-apply f keys0 vals0 args0)
      (make-keyword-procedure
       (lambda (keys1 vals1 . args1)
         (let*-values ([(keys2 vals2)
                        (merge-keywords r? keys0 vals0 keys1 vals1)]
                       [(args2)
                        (if r? (append args1 args0) (append args0 args1))])
           (curryn* (sub1 n) f r? keys2 vals2 args2))))))

(define-syntax-rule (cons2 one two rest)
  (let*-values ([(ones twos) rest])
    (values (cons one ones) (cons two twos))))

(define merge-keywords
  (match-lambda*
    [(or (list _ '() '() keys vals)
         (list _ keys vals '() '()))
     (values keys vals)]
    [(list r?
           (and keys1* (cons key1 keys1)) (and vals1* (cons val1 vals1))
           (and keys2* (cons key2 keys2)) (and vals2* (cons val2 vals2)))
     (cond
      [(keyword<? key1 key2)
       (cons2 key1 val1 (merge-keywords r? keys1 vals1 keys2* vals2*))]
      [(keyword<? key2 key1)
       (cons2 key2 val2 (merge-keywords r? keys1* vals1* keys2 vals2))]
      [else
       (error (if r? 'currynr 'curryn)
              "duplicate values for ~s: ~s and ~s"
              key1 val1 val2)])]))

(define curryn
  (make-keyword-procedure
   (lambda (keys vals n f . args)
     (curryn* n f #f keys vals args))))

(define currynr
  (make-keyword-procedure
   (lambda (keys vals n f . args)
     (curryn* n f #t keys vals args))))

(define papply (curryn 1 curryn 1))
(define papplyr (curryn 1 currynr 1))

(define call (papply curryn 0))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Parameter arguments
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-for-syntax (strip-param orig p-arg)
  (syntax-case p-arg ()
    [(id #:param param)
     (values (syntax/loc p-arg (id (param)))
             (syntax/loc p-arg [param id]))]
    [_ (values p-arg #f)]))

(define-for-syntax (strip-params orig p-args)
  (syntax-case p-args ()
    [(key p-arg . rest)
     (keyword? #'key)
     (let*-values ([(arg param) (strip-param orig #'p-arg)]
                   [(args params) (strip-params orig #'rest)])
       (values (cons #'key (cons arg args))
               (if param (cons param params) params)))]
    [(p-arg . rest)
     (let*-values ([(arg param) (strip-param orig #'p-arg)]
                   [(args params) (strip-params orig #'rest)])
       (values (cons arg args)
               (if param (cons param params) params)))]
    [_ (values p-args null)]))

(define-syntax (lambda/parameter stx)
  (syntax-case stx ()
    [(_ p-args . body)
     (let*-values ([(args params) (strip-params stx #'p-args)])
       (quasisyntax/loc stx
         (lambda #,args (parameterize #,params . body))))]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Exports
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(provide
 ;; functions
 identity
 thunk constant
 conjoin disjoin
 curryn currynr papply papplyr call
 ;; macros
 thunk lambda/parameter)