;;; fwoar-functional-utils.el --- more functional utilities for emacs -*- lexical-binding: t; -*-

;; Copyright (C) 2020 Edward Langley

;; Author: Edward Langley <fwoar@elangley.org>
;; Version: 0.0.1
;; Keywords: fp,combinators
;; URL: https://fwoar.co

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; Some functional programming utilities

;;; Code:

(eval-when (compile load eval)
  (defvar *fwoar/namespaced-funs* ()))

(cl-defmacro fwoar/def-ns-fun (name (&rest args) &body body)
  (declare (indent defun))
  (let ((namespaced-sym (intern (format "fwoar/%s" name))))
    `(progn
       (cl-pushnew '(,name ,args ,namespaced-sym)
                   *fwoar/namespaced-funs*
                   :test 'equal)
       (cl-defun ,namespaced-sym ,args
         ,@body))))

(fwoar/def-ns-fun just-after (pred)
  (lexical-let ((state nil))
    (lambda (it)
      (cond
       (state it)
       ((funcall pred it) (setf state t) nil)))))

;;;###autoload
(cl-defmacro with-unaliased (&body body)
  `(flet ,(loop for (name raw-args namespaced) in *fwoar/namespaced-funs*
                for rest-arg = (cl-find-if (fwoar/just-after
                                            (lambda (it)
                                              (member it '(&rest &body))))
                                           raw-args)
                for args = (cl-remove-if (lambda (it)
                                           (or (eql it rest-arg)
                                               (and (symbolp it)
                                                    (= ?&
                                                       (elt
                                                        (symbol-name it)
                                                        0)))))
                                         raw-args)

                collect `(,name ,raw-args
                                (,@(if rest-arg
                                       `(apply ',namespaced)
                                     (list namespaced))
                                 ,@(mapcar (lambda (it)
                                             (if (listp it)
                                                 (car it)
                                               it))
                                           args)
                                 ,@(when rest-arg
                                     (list rest-arg)))))
     ,@body))

(cl-defmacro fwoar/def-combinator (name (seq &rest args) &body body)
  (declare (indent defun))
  `(fwoar/def-ns-fun ,name ,args
     (lambda (,seq)
       ,@body)))

(fwoar/def-ns-fun iota (count &optional (start 0))
  (cl-loop for x from start
           repeat count
           collect x))

(fwoar/def-ns-fun applying (f &rest pos-args)
  (lambda (list)
    (apply f (append pos-args list))))

(fwoar/def-ns-fun on (fun key-fun)
  (lambda (it)
    (funcall fun (funcall key-fun it))))

(fwoar/def-combinator over (list f &rest args)
  (mapcar (lambda (it)
            (apply f it args))
          list))

(fwoar/def-combinator filter (list f &rest args)
  (cl-remove-if-not (lambda (it)
                      (apply f it args))
                    list))

(fwoar/def-combinator zip-with (lists f)
  (apply 'cl-mapcar f lists))

(fwoar/def-ns-fun element (num)
  (lambda (it)
    (elt it num)))

(fwoar/def-ns-fun hash-lookup (ht)
  (lambda (key)
    (gethash key ht)))

(cl-defgeneric fwoar/eq (a b)
  (:method (a b)
           (eql a b))
  (:method ((a string) (b string))
           (equal a b)))

(fwoar/def-ns-fun == (v)
  (lambda (it)
    (fwoar/eq v it)))

(fwoar/def-ns-fun applicable-when (cond fn)
  (lambda (data)
    (when (funcall cond data)
      (funcall fn data))))


(fwoar/def-ns-fun matches-regex (regex &optional start)
  (lexical-let ((regex regex))
    (lambda (data)
      (if start
          (string-match-p regex data start)
        (string-match-p regex data)))))


(cl-defmacro fwoar/and (&rest fns)
  (let ((dat (gensym "dat")))
    `(lambda (,dat)
       (and ,@(mapcar (lambda (fn)
                        `(funcall ,fn ,dat))
                      fns)))))

;; TODO: think about whether the plist behavior here makes sense
;;       should we require plists to have symbol keys?
(cl-defgeneric fwoar/extract-key (map key)
  (:method ((map hash-table) key)
           (gethash key map))
  (:method ((map list) key)
           (typecase (car map)
             (cons (cdr (cl-assoc key map :test 'equal)))
             (t (cl-loop for (a-key . value) on map by #'cddr
                         when (equal key a-key) do
                         (return (car value))))))
  (:method ((map vector) (key number))
           (elt map key)))

(fwoar/def-ns-fun key (key)
  (lambda (map)
    (fwoar/extract-key map key)))

(fwoar/def-ns-fun keys (key &rest keys)
  (lambda (map)
    (cl-loop for key in (cons key keys)
             for cur = (fwoar/extract-key map key) then (fwoar/extract-key cur key)
             finally (return cur))))

(comment
 (fwoar/def-ns-fun regex-match (regex)
   (lambda (data)
     (cl-ppcre:scan-to-strings regex data))))

(fwoar/def-ns-fun include (pred)
  (lambda (seq)
    (cl-remove-if pred seq)))

(fwoar/def-ns-fun exclude (pred)
  (lambda (seq)
    (cl-remove-if-not pred seq)))

(fwoar/def-ns-fun pick (selector)
  (lambda (seq)
    (cl-map 'list selector seq)))

(fwoar/def-ns-fun slice (start &optional end)
  (lambda (it)
    (cl-subseq it start end)))

(fwoar/def-ns-fun juxt (fun1 &rest r)
  (lambda (&rest args)
    (list* (apply fun1 args)
           (mapcar (lambda (f)
                     (apply f args))
                   r))))

(defalias 'fwoar/• '-compose)

(provide 'fwoar-functional-utils)
;;; fwoar-functional-utils.el ends here