✨ Contextual has categories

contextual.asd

@@ -22,6 +22,7 @@
      (:file "internal")
      (:file "derivation")
      (:file "monoid")
+     (:file "category")
      (:file "functor")
      (:file "applicative")
      (:file "monad")
@@ -61,7 +62,8 @@
      (:file "bare-function-test")
      (:file "bare-state-test")
      (:file "unitary-list-test")
-     (:file "monoid-test"))))
+     (:file "monoid-test")
+     (:file "category-test"))))
   :perform (test-op (o s)
              (symbol-call :binding-syntax-helpers-test :run-all-tests!)
              (symbol-call :contextual-internal-test :run-all-tests!)
@@ -75,4 +77,5 @@
              (symbol-call :contextual-bare-function-test :run-all-tests!)
              (symbol-call :contextual-bare-state-test :run-all-tests!)
              (symbol-call :contextual-unitary-list-test :run-all-tests!)
-             (symbol-call :contextual-monoid-test :run-all-tests!)))
+             (symbol-call :contextual-monoid-test :run-all-tests!)
+             (symbol-call :contextual-category-test :run-all-tests!)))

src/category.lisp

@@ -0,0 +1,49 @@
+(in-package :contextual)
+
+(defgeneric comp-func (obj))
+(defun ask-comp () (ctx-asks #'comp-func))
+(defun comp (ccat0 ccat1)
+  (let-app/ctx ((comp (ask-comp))
+                (cat0 (ctx-injest ccat0))
+                (cat1 (ctx-injest ccat1)))
+    (funcall comp cat0 cat1)))
+
+(defgeneric id-value (obj))
+(defun ask-id () (ctx-asks #'id-value))
+(defun id ()
+  (let-app/ctx ((id (ask-id)))
+    id))
+
+(defclass category-operators ()
+  ((comp :initarg :comp :type function :reader comp-func)
+   (id :initarg :id :reader id-value)))
+
+(defmethod initialize-instance ((obj category-operators) &rest args)
+  (validate-minimal-category-definition obj args)
+  (initialize-id obj args)
+  (initialize-comp obj args))
+
+(defun validate-minimal-category-definition (obj args)
+  (with-init-lookup (args obj)
+      (id comp)
+    (unless (and comp id)
+      (error "insufficient input to define category operators"))))
+
+(defun initialize-id (obj args)
+  (with-init-lookup (args obj) (id)
+    (setf (slot-value obj 'id) id)))
+
+(defun initialize-comp (obj args)
+  (with-init-lookup (args obj) (comp)
+    (setf (slot-value obj 'comp) comp)))
+
+(defun <<< (&rest fs)
+  (let ((n (length fs)))
+    (case n
+      ((2) (comp (car fs) (cadr fs)))
+      ((1) (car fs))
+      ((0) (id))
+      (otherwise (fold #'comp (car fs) (cdr fs))))))
+
+(defun >>> (&rest fs)
+    (apply #'<<< (reverse fs)))

src/package.lisp

@@ -74,6 +74,7 @@
 (defpackage :contextual
   (:use :cl :binding-syntax-helpers :contextual-utility :contextual-internal :contextual-derivation)
   (:export
+   #:ctx-injest
    #:fmap
    #:pure #:fapply #:product
    #:mreturn #:flatmap #:flatten
@@ -121,7 +122,15 @@
    #:mget
    #:mput
    #:select
-   #:modify))
+   #:modify)
+
+  ;; Category
+  (:export
+   #:category-operators
+   #:comp
+   #:id
+   #:<<<
+   #:>>>))
 
 (defpackage :contextual-bare
   (:use :cl :contextual)

test/category-test.lisp

@@ -0,0 +1,80 @@
+(in-package :cl-user)
+
+(defpackage :contextual-category-test
+  (:use :cl :5am :contextual)
+  (:shadowing-import-from :5am #:fail)
+  (:export #:run-all-tests!))
+
+(in-package :contextual-category-test)
+
+(defun run-all-tests! ()
+  (run! 'category))
+
+(def-suite category)
+
+(in-suite category)
+
+(defun sqr (x)
+  (* x x))
+
+(defun twc (x)
+  (+ x x))
+
+
+(defun run-func (arg func)
+  (funcall func arg))
+
+(defun compose (f g)
+  (declare (type function f g))
+  (lambda (x) (funcall f (funcall g x))))
+
+(defun make-function-category ()
+  (make-instance 'category-operators
+    :id #'identity
+    :comp #'compose))
+
+(test category-function
+  (let ((context (make-function-category)))
+    (is (typep context 'category-operators))
+    (is (functionp (ctx-run context (id))))
+    (is (eq 'x (run-func 'x (ctx-run context (id)))))
+    (is (equal "X" (run-func 'x (ctx-run context (<<< #'symbol-name (id))))))
+    (is (equal "X" (run-func 'x (ctx-run context (<<< (id) #'symbol-name)))))
+    (is (equal "X" (run-func 'x (ctx-run context (>>> #'symbol-name (id))))))
+    (is (equal "X" (run-func 'x (ctx-run context (>>> (id) #'symbol-name)))))
+    (is (equal 36 (run-func 3 (ctx-run context (>>> #'twc #'sqr)))))))
+
+(defstruct simple-function
+  (func #'identity :type function))
+
+(defun simple-function-compose (f g)
+  (declare (type simple-function f g))
+  (make-simple-function
+   :func (compose (simple-function-func f)
+                  (simple-function-func g))))
+
+(defun simple-function-id ()
+  (make-simple-function))
+
+(defun make-simple-function-category ()
+  (make-instance 'category-operators
+    :id (simple-function-id)
+    :comp #'simple-function-compose))
+
+(defun run-simple-function (arg cf)
+  (funcall (simple-function-func cf) arg))
+
+(test category-simple-function-context
+  (let ((context (make-simple-function-category))
+        (sfsqr (make-simple-function :func #'sqr))
+        (sftwc (make-simple-function :func #'twc)))
+    (is (typep context 'category-operators))
+    (is (simple-function-p (ctx-run context (id))))
+    (is (eq 'x (run-simple-function 'x (ctx-run context (id)))))
+    (is (= 9 (run-simple-function 3 (ctx-run context (ctx-injest sfsqr)))))
+    (is (= 36 (run-simple-function 3
+                (ctx-run context
+                  (<<< sfsqr sftwc)))))
+    (is (= 36 (run-simple-function 3
+                (ctx-run context
+                  (>>> sftwc sfsqr)))))))